The World of Computer Software/World_Of_Computer_Software-02-387-Vol-3of3.iso/s/sc-23.zip/SC-OLOAD.EL

Lisp/Scheme | 1993-01-08 | 10KB | 263 lines

;; -*- Mode: Emacs-Lisp -*-
;; sc-oloads.el  --  Version 2.3

;; ========== Introduction ==========
;; This file contains overloading facilities for supercite.  Supercite
;; interfaces to various news and mail reading packages in a standard
;; way, as determined in 1989 by the supercite mailing list
;; participants.  Many mail/news package authors participated in the
;; discussion and the standard is an outcome of those discussions.

;; As of the date of this writing (7-Feb-1991), both VM 4.40+ and MH-E
;; 3.7+ (as shipped with emacs 18.57) conform to the standard
;; out-of-the-package.  Since RMAIL, GNUS, RNEWS, and other packages
;; utilize elisp in the emacs 18.57 distribution, and since this
;; distribution does not conform to the standard, the interface
;; functions provided in this file are required to make supercite work
;; with those packages.

;; Previous versions of supercite provided patches to distribution
;; elisp (18.55) but this method is no longer viable for a number of
;; reasons. The function overloads are the only supported way to
;; interface supercite with non-conforming packages. Using this
;; package, you should be able to interface supercite with all the
;; 18.55+ based readers including GNUS 3.12+, RMAIL and RNEWS, GNEWS
;; and PCMAIL. If you come across other reader packages that you'd
;; like to interface, please let me know.

;; ========== Disclaimer ==========
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor accepts
;; responsibility to anyone for the consequences of using it or for
;; whether it serves any particular purpose or works at all, unless he
;; says so in writing.

;; Some of this software was written as part of the supercite author's
;; official duty as an employee of the United States Government and is
;; thus in the public domain.  You are free to use that particular
;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER.  It
;; would be nice, though if when you use any of this code, you give
;; due credit to the author.

;; Other parts of this code were written by other people.  Wherever
;; possible, credit to that author, and the copy* notice supplied by
;; the author are included with that code. In all cases, the spirit,
;; if not the letter of the GNU General Public Licence applies.

;; ========== Author (unless otherwise stated) ==========
;; NAME: Barry A. Warsaw        USMAIL: Century Computing, Inc.
;; TELE: [phone]                 1014 West Street
;; UUCP: uunet!cen.com!bwarsaw          Laurel, MD 20707
;; INET: [e-mail]

;; Want to be on the Supercite mailing list?
;;
;; Send articles to:
;;         INET: [e-mail]
;;         UUCP: uunet!warsaw.nlm.nih.gov!supercite
;;
;; Send administrivia (additions/deletions to list, etc) to:
;;         INET: [e-mail]
;;         UUCP: uunet!warsaw.nlm.nih.gov!supercite-request
;;
(provide 'sc-oloads)



;; ======================================================================
;; functions which do the overloading
;; based on code supplied by [e-mail]

(defvar sc-overload-functions
  '((mail-yank-original       sc-mail-yank-original)
    (news-reply-yank-original sc-news-reply-yank-original)
    (reply-yank               sc-gnews-reply-yank)
    (group-reply-yank         sc-group-reply-yank)
    (group-follow-yank        sc-group-follow-yank)
    )
  "*Functions to be overloaded by supercite.
It is a list of '(original overload)', where original is the original
function symbol, overload is the supercite equivalent function.")


(defun sc-overload-functions ()
  "Overload functions defined by the variable sc-overload-functions.
If the original symbol is not yet bound, it will not be overloaded.
Also, if the symbol has already been overloaded, it will not be
overloaded again."
  (let ((binding nil)
    (overloads sc-overload-functions))
    (while overloads
      (setq binding (car overloads)
        overloads (cdr overloads))
      (and (fboundp (car binding))
       (not (get (car binding) 'sc-overloaded))
       (progn
         (fset (car binding) (symbol-function (car (cdr binding))))
         (put (car binding) 'sc-overloaded 'sc-overloaded))
       )
      )))



;; ======================================================================
;; sendmail.el overload functions. This is the heart of supercite
;; conformance by packages which rely on distribution emacs elisp. You
;; should almost always overload this function.

(defun sc-mail-yank-original (arg)
  "Supercite version of mail-yank-original.
This function is the workhorse which many packages rely upon to do
citing. It inserts the message being replied to in the reply buffer.
Puts point before the mail headers and mark after body of text.

Citation is accomplished by running the hook mail-yank-hooks and is
thus user configurable. Default is to indent each nonblank line ARG
spaces (default 3). Just \\[universal-argument] as argument means
don't indent and don't delete any header fields."
  (interactive "P")
  (if mail-reply-buffer
      (let ((start (point)))
    (delete-windows-on mail-reply-buffer)
    (insert-buffer mail-reply-buffer)
    (if (consp arg)
        nil
      ;; mod 28-Jul-1989 [e-mail]
      ;; generalized, hookified citations
      (run-hooks 'mail-yank-hooks))
    (exchange-point-and-mark)
    (if (not (eolp)) (insert ?\n)))))

;; added 28-Jul-1989 [e-mail]
;; generalized, hookified citations
(defvar mail-indention-spaces 3
  "*Set to number of spaces to indent when yanking a reply.")


;; added 28-Jul-1989 [e-mail]
;; generalized, hookified citations
(defvar mail-yank-hooks
  '(lambda ()
     (indent-rigidly (point) (mark) mail-indention-spaces))
  "*Hook to run citation function.
Expects point and mark to be set to the region to cite.")



;; ======================================================================
;; rnewspost.el overload functions.  Not strictly necessary for supercite
;; to work but it reduces the amount of manual cleaning the user has to
;; do for GNUS and other news readers.

(defun sc-news-reply-yank-original (arg)
  "Supercite version of news-reply-yank-original.
Insert the message being replied to in the reply buffer. Puts point
before the mail headers and mark after body of the text.  Calls
mail-yank-original to actually yank the message into the buffer and
cite text.

If mail-yank-original is not overloaded by supercite, each nonblank
line is indented ARG spaces (default 3).  Just \\[universal-argument]
as ARG means don't indent and don't delete any header fields."
  (interactive "P")
  (mail-yank-original arg)
  (exchange-point-and-mark)
  ;; added 14-Jun-1989 [e-mail]
  ;; generalized, hookified citations
  (run-hooks 'news-reply-header-hook))


;; added 14-Jun-1989 [e-mail] generalized, hookified
;; citations (modified 18-Jul-1990)
(defvar news-reply-header-hook
  '(lambda ()
     (insert "In article " news-reply-yank-message-id
         " " news-reply-yank-from " writes:\n\n"))
  "*Hook for inserting a header at the top of a yanked message.")



;; ======================================================================
;; gnews overloads supplied by:
;; Piet* van Oostrum, Dept of Computer Science, Utrecht University,
;; Padualaan 14, P.O. Box 80.089, 3508 TB Utrecht, The Netherlands.
;; Telephone: [phone]   Uucp:   uunet!mcsun!ruuinf!piet
;; Telefax:   [phone]   Internet:  [e-mail]   (*`Pete')
;;
;; His overload functions were provided in a mail message dated
;; 5-Oct-1990, in which he also gives this caveat:
;;
;; I use Gnews as my newsreader. I hacked a few definitions to use
;; supercite with gnews. The definitions are a hack in that you can't
;; easily customize them to get the original behaviour, but anyway,
;; here are they:
;;
(defun sc-gnews-reply-yank (arg)
  (interactive "P")
  (open-line 2)
  (delete-blank-lines)
  (forward-char 1)
  (mail-yank-original arg)
  (exchange-point-and-mark)
  (run-hooks 'gnews-reply-header-hook))


(defun sc-group-reply-yank (pfx arg)
  "Reply by e-mail to current article with original article inserted.
With non-nil prefix argument PFX, set up the current article for e-mail
forwarding."
  (interactive "P\np")
  (if pfx (group-forward-article)
    (if (group-reply)
    (progn
      (forward-paragraph)
      (sc-gnews-reply-yank 1)
      (run-hooks 'group-reply-hook)
      (set-buffer-modified-p nil)))))


(defun sc-group-follow-yank (pfx arg)
  "Follow up to current article with that article inserted, indented
using the value of reply-prefix.\n
Otherwise identical to group-follow, which see."
  (interactive "P\np")
  (let ((end (< article-final article-current))
    file goal-column)
    (if end (setq file (read-file-name "Include file: " nil "" t)
          file (if (string< "" file) (expand-file-name file))))
    (if (group-follow pfx arg)
    (progn
      (if file
          (progn
        (goto-char (point-max))
        (insert ?\n?\n)
        (insert-file file)
        (if (looking-at "^\\(Newsgroups\\|Path\\|From\\): ")
            (delete-region 1 (point)))))
      (forward-paragraph)
      (if (not file) (open-line 1))
      (forward-line 1)
      (if (not end)
          (sc-gnews-reply-yank 1))
      (run-hooks 'group-follow-hook)
      (set-buffer-modified-p nil)))))

(defvar gnews-reply-header-hook nil
  "*Hook for inserting a header at the top of a yanked message.")

;    (setq gnews-reply-header-hook
;      '(lambda ()
;         (insert "In article " (article-field "Message-ID")
;                 " " (article-field "From") " writes:\n\n")))

;; This is now done by sc-overload-functions
;;  5-Oct-1990 [e-mail]
;;
; (defun sc-gnews-redefine ()
;  (fset 'reply-yank 'sc-gnews-reply-yank)
;  (fset 'group-reply-yank 'sc-group-reply-yank)
;  (fset 'group-follow-yank 'sc-group-follow-yank)
; )

; (setq gnews-ready-hook 'sc-gnews-redefine)