mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-28 10:56:36 +00:00
Code Issues Releases Activity
7163b71c97
emacs/lisp/sc.el
Richard M. Stallman 26ff8619bb (sc-glom-headers): Bind mark-active around calling region-... 
(sc-cite-original): Likewise.
1993-09-12 11:25:16 +00:00

1548 lines
54 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;; -*- Mode: Emacs-Lisp -*-
;; sc.el -- Version 2.3 (used to be supercite.el)
;; ========== Introduction ==========
;; Citation and attribution package for various GNU emacs news and
;; electronic mail reading subsystems. This version of supercite should
;; work with Rmail and GNUS as found in Emacs 19. It may also work with
;; VM 4.40+ and MH-E 3.7.
;; This package does not do any yanking of messages, but instead
;; massages raw reply buffers set up by the reply/forward functions in
;; the news/mail subsystems. Therefore, such useful operations as
;; yanking and citing portions of the original article (instead of the
;; whole article) are not within the ability or responsibility of
;; supercite.
;; ========== Disclaimer ==========
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor, nor any
;; author's past, present, or future employers 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 not subject to copyright. 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 or other freely
;; available 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. The supercite author is no
;; longer an employee of the U.S. Government so the GNU Public Licence
;; should be considered in effect for all enhancements and bug fixes
;; performed by the author.
;; ========== Author (unless otherwise stated) ========================
;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
;; TELE: (301) 593-3330 1014 West Street
;; INET: bwarsaw@cen.com Laurel, Md 20707
;; UUCP: uunet!cen.com!bwarsaw
;;
;; Want to be on the Supercite mailing list?
;;
;; Send articles to:
;; Internet: supercite@anthem.nlm.nih.gov
;; UUCP: uunet!anthem.nlm.nih.gov!supercite
;;
;; Send administrivia (additions/deletions to list, etc) to:
;; Internet: supercite-request@anthem.nlm.nih.gov
;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request
;; ========== Credits and Thanks ==========
;; This package was derived from the Superyank 1.11 package as posted
;; to the net. Superyank 1.11 was inspired by code and ideas from
;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved
;; through the comments and suggestions of the supercite mailing list
;; which consists of many authors and users of the various mail and
;; news reading subsystems.
;; Many folks on the supercite mailing list have contributed their
;; help in debugging, making suggestions and supplying support code or
;; bug fixes for the previous versions of supercite. I want to thank
;; everyone who helped, especially (in no particular order):
;;
;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle
;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van
;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells.
;;
;; I don't mean to leave anyone out. All who have helped have been
;; appreciated.
;; ========== Getting Started ==========
;; Here is a quick guide to getting started with supercite. The
;; information contained here is mostly excerpted from the more
;; detailed explanations given in the accompanying README file.
;; Naturally, there are many customizations you can do to give your
;; replies that personalized flair, but the instructions in this
;; section should be sufficient for getting started.
;; First, to connect supercite to any mail/news reading subsystem, put
;; this in your .emacs file:
;;
;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents
;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only
;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents
;;
;; If supercite is not pre-loaded into your emacs session, you should
;; add the following autoload:
;;
;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t)
;;
;; Finally, if you want to customize supercite, you should do it in a
;; function called my-supercite-hook and:
;;
;; (setq sc-load-hook 'my-supercite-hook)
(require 'assoc)
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
;; start of user defined variables
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
(defvar sc-nested-citation-p nil
"*Controls whether to use nested or non-nested citation style.
Non-nil uses nested citations, nil uses non-nested citations. Type
\\[sc-describe] for more information.")
(defvar sc-citation-leader " "
"*String comprising first part of a citation.")
(defvar sc-citation-delimiter ">"
"*String comprising third part of a citation.
This string is used in both nested and non-nested citations.")
(defvar sc-citation-separator " "
"*String comprising fourth and last part of a citation.")
(defvar sc-default-author-name "Anonymous"
"*String used when author's name cannot be determined.")
(defvar sc-default-attribution "Anon"
"*String used when author's attribution cannot be determined.")
;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite
;; mailing list:
;; I use supercite in Nemacs-3.3.2. In order to handle citation using
;; Kanji, [...set sc-cite-regexp to...]
;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+"
;;
(defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *"
"*Regular expression describing how a already cited line begins.
The regexp is only used at the beginning of a line, so it doesn't need
to start with a '^'.")
(defvar sc-titlecue-regexp "\\s +-+\\s +"
"*Regular expression describing the separator between names and titles.
Set to nil to treat entire field as a name.")
(defvar sc-spacify-name-chars '(?_ ?* ?+ ?=)
"*List of characters to convert to spaces if found in an author's name.")
(defvar sc-nicknames-alist
'(("Michael" "Mike")
("Daniel" "Dan")
("David" "Dave")
("Jonathan" "John")
("William" "Bill")
("Elizabeth" "Beth")
("Elizabeth" "Betsy")
("Kathleen" "Kathy")
("Smith" "Smitty"))
"*Association list of names and their common nicknames.
Entries are of the form (NAME NICKNAME), and NAMEs can have more than
one nickname. Nicknames will not be automatically used as an
attribution string, since I'm not sure this is really polite, but if a
name is glommed from the author name and presented in the attribution
string completion list, the matching nicknames will also be presented.
Set this variable to nil to defeat nickname expansions. Also note that
nicknames are not put in the supercite information alist.")
(defvar sc-confirm-always-p t
"*If non-nil, always confirm attribution string before citing text body.")
(defvar sc-preferred-attribution 'firstname
"*Specifies which part of the author's name becomes the attribution.
The value of this variable must be one of the following quoted symbols:
emailname -- email terminus name
initials -- initials of author
firstname -- first name of author
lastname -- last name of author
middlename1 -- first middle name of author
middlename2 -- second middle name of author
...
Middle name indexes can be any positive integer greater than 0, though
it is unlikely that many authors will supply more than one middle
name, if that many.")
(defvar sc-use-only-preference-p nil
"*Controls what happens when the preferred attribution cannot be found.
If non-nil, then sc-default-attribution will be used. If nil, then
some secondary scheme will be employed to find a suitable attribution
string.")
(defvar sc-downcase-p nil
"*Non-nil means downcase the attribution and citation strings.")
(defvar sc-rewrite-header-list
'((sc-no-header)
(sc-header-on-said)
(sc-header-inarticle-writes)
(sc-header-regarding-adds)
(sc-header-attributed-writes)
(sc-header-verbose)
(sc-no-blank-line-or-header)
)
"*List of reference header rewrite functions.
The variable sc-preferred-header-style controls which function in this
list is chosen for automatic reference header insertions. Electric
reference mode will cycle through this list of functions. For more
information, type \\[sc-describe].")
(defvar sc-preferred-header-style 1
"*Index into sc-rewrite-header-list specifying preferred header style.
Index zero accesses the first function in the list.")
(defvar sc-electric-references-p t
"*Use electric references if non-nil.")
(defvar sc-electric-circular-p t
"*Treat electric references as circular if non-nil.")
(defvar sc-mail-fields-list
'("date" "message-id" "subject" "newsgroups" "references"
"from" "return-path" "path" "reply-to" "organization"
"reply" )
"*List of mail header whose values will be saved by supercite.
These values can be used in header rewrite functions by accessing them
with the sc-field function. Mail headers in this list are case
insensitive and do not require a trailing colon.")
(defvar sc-mumble-string ""
"*Value returned by sc-field if chosen field cannot be found.")
(defvar sc-nuke-mail-headers-p t
"*Nuke or don't nuke mail headers.
If non-nil, nuke mail headers after gleaning useful information from
them.")
(defvar sc-reference-tag-string ">>>>> "
"*String used at the beginning of built-in reference headers.")
(defvar sc-fill-paragraph-hook 'sc-fill-paragraph
"*Hook for filling a paragraph.
This hook gets executed when you fill a paragraph either manually or
automagically. It expects point to be within the extent of the
paragraph that is going to be filled. This hook allows you to use a
different paragraph filling package than the one supplied with
supercite.")
(defvar sc-auto-fill-region-p nil
"*If non-nil, automatically fill each paragraph after it has been cited.")
(defvar sc-auto-fill-query-each-paragraph-p nil
"*If non-nil, query before filling each paragraph.
No querying and no filling will be performed if sc-auto-fill-region-p
is set to nil.")
(defvar sc-fixup-whitespace-p nil
"*If non-nil, delete all leading white space before citing.")
(defvar sc-all-but-cite-p nil
"*If non-nil, sc-cite-original does everything but cite the text.
This is useful for manually citing large messages, or portions of
large messages. When non-nil, sc-cite-original will still set up all
necessary variables and databases, but will skip the citing routine
which modify the reply buffer's text.")
(defvar sc-load-hook nil
"*User definable hook.
Runs after supercite is loaded. Set your customizations here.")
(defvar sc-pre-hook nil
"*User definable hook.
Runs before sc-cite-original executes.")
(defvar sc-post-hook nil
"*User definable hook.
Runs after sc-cite-original executes.")
(defvar sc-header-nuke-list
'("via" "origin" "status" "received" "remailed" "cc" "sender" "replied"
"organization" "keywords" "distribution" "xref" "references" "expires"
"approved" "summary" "precedence" "subject" "newsgroup[s]?"
"\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to"
"x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]"
"\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date"
"\\(mail-\\)?from")
"*List of mail headers to remove from body of reply.")
;; ======================================================================
;; keymaps
(defvar sc-default-keymap
'(lambda ()
(local-set-key "\C-c\C-r" 'sc-insert-reference)
(local-set-key "\C-c\C-t" 'sc-cite)
(local-set-key "\C-c\C-a" 'sc-recite)
(local-set-key "\C-c\C-u" 'sc-uncite)
(local-set-key "\C-c\C-i" 'sc-insert-citation)
(local-set-key "\C-c\C-o" 'sc-open-line)
(local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
(local-set-key "\C-cq" 'sc-fill-paragraph-manually)
(local-set-key "\C-c\C-m" 'sc-modify-information)
(local-set-key "\C-cf" 'sc-view-field)
(local-set-key "\C-cg" 'sc-glom-headers)
(local-set-key "\C-c\C-v" 'sc-version)
(local-set-key "\C-c?" 'sc-describe)
)
"*Default keymap if major-mode can't be found in `sc-local-keymaps'.")
(defvar sc-local-keymaps
'((mail-mode
(lambda ()
(local-set-key "\C-c\C-r" 'sc-insert-reference)
(local-set-key "\C-c\C-t" 'sc-cite)
(local-set-key "\C-c\C-a" 'sc-recite)
(local-set-key "\C-c\C-u" 'sc-uncite)
(local-set-key "\C-c\C-i" 'sc-insert-citation)
(local-set-key "\C-c\C-o" 'sc-open-line)
(local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
(local-set-key "\C-cq" 'sc-fill-paragraph-manually)
(local-set-key "\C-c\C-m" 'sc-modify-information)
(local-set-key "\C-cf" 'sc-view-field)
(local-set-key "\C-cg" 'sc-glom-headers)
(local-set-key "\C-c\C-v" 'sc-version)
(local-set-key "\C-c?" 'sc-describe)
))
(mh-letter-mode
(lambda ()
(local-set-key "\C-c\C-r" 'sc-insert-reference)
(local-set-key "\C-c\C-t" 'sc-cite)
(local-set-key "\C-c\C-a" 'sc-recite)
(local-set-key "\C-c\C-u" 'sc-uncite)
(local-set-key "\C-ci" 'sc-insert-citation)
(local-set-key "\C-c\C-o" 'sc-open-line)
(local-set-key "\C-cq" 'sc-fill-paragraph-manually)
(local-set-key "\C-c\C-m" 'sc-modify-information)
(local-set-key "\C-cf" 'sc-view-field)
(local-set-key "\C-cg" 'sc-glom-headers)
(local-set-key "\C-c\C-v" 'sc-version)
(local-set-key "\C-c?" 'sc-describe)
))
(news-reply-mode mail-mode)
(vm-mail-mode mail-mode)
(e-reply-mode mail-mode)
(n-reply-mode mail-mode)
)
"*List of keymaps to use with the associated major-mode.")
(defvar sc-electric-mode-map nil
"*Keymap for sc-electric-mode.")
(if sc-electric-mode-map
nil
(setq sc-electric-mode-map (make-sparse-keymap))
(define-key sc-electric-mode-map "p" 'sc-eref-prev)
(define-key sc-electric-mode-map "n" 'sc-eref-next)
(define-key sc-electric-mode-map "s" 'sc-eref-setn)
(define-key sc-electric-mode-map "j" 'sc-eref-jump)
(define-key sc-electric-mode-map "x" 'sc-eref-abort)
(define-key sc-electric-mode-map "\r" 'sc-eref-exit)
(define-key sc-electric-mode-map "\n" 'sc-eref-exit)
(define-key sc-electric-mode-map "q" 'sc-eref-exit)
(define-key sc-electric-mode-map "g" 'sc-eref-goto)
)
;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;; end of user defined variables
;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;; ======================================================================
;; global variables, not user accessible
(defconst sc-version-number "2.3"
"Supercite's version number.")
;; when rnewspost.el patch is installed (or function is overloaded)
;; this should be nil since supercite now does this itself.
(setq news-reply-header-hook nil)
;; autoload for sc-electric-mode
(autoload 'sc-electric-mode "sc-elec"
"Quasi-major mode for viewing supercite reference headers." nil)
;; global alists (gals), misc variables. make new bytecompiler happy
(defvar sc-gal-information nil
"Internal global alist variable containing information.")
(defvar sc-gal-attributions nil
"Internal global alist variable containing attributions.")
(defvar sc-fill-arg nil
"Internal fill argument holder.")
(defvar sc-cite-context nil
"Internal citation context holder.")
(defvar sc-force-confirmation-p nil
"Internal variable.")
(make-variable-buffer-local 'sc-gal-attributions)
(make-variable-buffer-local 'sc-gal-information)
(make-variable-buffer-local 'sc-leached-keymap)
(make-variable-buffer-local 'sc-fill-arg)
(make-variable-buffer-local 'sc-cite-context)
(setq-default sc-gal-attributions nil)
(setq-default sc-gal-information nil)
(setq-default sc-leached-keymap (current-local-map))
(setq-default sc-fill-arg nil)
(setq-default sc-cite-context nil)
;; ======================================================================
;; miscellaneous support functions
(defun sc-mark ()
"Mark compatibility between emacs v18 and v19."
(let ((zmacs-regions nil))
(marker-position (mark-marker))))
(defun sc-update-gal (attribution)
"Update the information alist.
Add ATTRIBUTION and compose the nested and non-nested citation
strings."
(let ((attrib (if sc-downcase-p (downcase attribution) attribution)))
(aput 'sc-gal-information "sc-attribution" attrib)
(aput 'sc-gal-information "sc-nested-citation"
(concat attrib sc-citation-delimiter))
(aput 'sc-gal-information "sc-citation"
(concat sc-citation-leader
attrib
sc-citation-delimiter
sc-citation-separator))))
(defun sc-valid-index-p (index)
"Returns t if INDEX is a valid index into sc-rewrite-header-list."
(let ((last (1- (length sc-rewrite-header-list))))
(and (natnump index) ;; a number, and greater than or equal to zero
(<= index last) ;; less than or equal to the last index
)))
(defun sc-string-car (namestring)
"Return the string-equivalent \"car\" of NAMESTRING.
example: (sc-string-car \"John Xavier Doe\")
=> \"John\""
(substring namestring
(progn (string-match "\\s *" namestring) (match-end 0))
(progn (string-match "\\s *\\S +" namestring) (match-end 0))))
(defun sc-string-cdr (namestring)
"Return the string-equivalent \"cdr\" of NAMESTRING.
example: (sc-string-cdr \"John Xavier Doe\")
=> \"Xavier Doe\""
(substring namestring
(progn (string-match "\\s *\\S +\\s *" namestring)
(match-end 0))))
(defun sc-linepos (&optional position col-p)
"Return the character position at various line positions.
Optional POSITION can be one of the following symbols:
bol == beginning of line
boi == beginning of indentation
eol == end of line [default]
Optional COL-P non-nil returns current-column instead of character position."
(let ((tpnt (point))
rval)
(cond
((eq position 'bol) (beginning-of-line))
((eq position 'boi) (back-to-indentation))
(t (end-of-line)))
(setq rval (if col-p (current-column) (point)))
(goto-char tpnt)
rval))
;; ======================================================================
;; this section snarfs mail fields and places them in the info alist
(defun sc-build-header-zap-regexp ()
"Return a regexp for sc-mail-yank-clear-headers."
(let ((headers sc-header-nuke-list)
(regexp nil))
(while headers
(setq regexp (concat regexp
"^" (car headers) ":"
(if (cdr headers) "\\|" nil)))
(setq headers (cdr headers)))
regexp))
(defun sc-mail-yank-clear-headers (start end)
"Nuke mail headers between START and END."
(if (and sc-nuke-mail-headers-p sc-header-nuke-list)
(let ((regexp (sc-build-header-zap-regexp)))
(save-excursion
(goto-char start)
(if (search-forward "\n\n" end t)
(save-restriction
(narrow-to-region start (point))
(goto-char start)
(while (let ((case-fold-search t))
(re-search-forward regexp nil t))
(beginning-of-line)
(delete-region (point)
(progn (re-search-forward "\n[^ \t]")
(forward-char -1)
(point)))
)))
))))
(defun sc-mail-fetch-field (field)
"Return the value of the header field FIELD.
The buffer is expected to be narrowed to just the headers of the
message."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
(name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*")))
(goto-char (point-min))
(if (re-search-forward name nil t)
(let ((opoint (point)))
(while (progn (forward-line 1)
(looking-at "[ \t]")))
(buffer-substring opoint (1- (point))))))))
(defun sc-fetch-fields (start end)
"Fetch the mail fields in the region from START to END.
These fields can be accessed in header rewrite functions with sc-field."
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(let ((fields sc-mail-fields-list))
(while fields
(let ((value (sc-mail-fetch-field (car fields)))
(next (cdr fields)))
(and value
(aput 'sc-gal-information (car fields) value))
(setq fields next)))
(if (sc-mail-fetch-field "from")
(aput 'sc-gal-information "from" (sc-mail-fetch-field "from")))))))
(defun sc-field (field)
"Return the alist information associated with the FIELD.
If FIELD is not a valid key, return sc-mumble-string."
(or (aget sc-gal-information field) sc-mumble-string))
;; ======================================================================
;; built-in reference header rewrite functions
(defun sc-no-header ()
"Does nothing. Use this instead of nil to get a blank header."
())
(defun sc-no-blank-line-or-header()
"Similar to sc-no-header except it removes the preceding blank line."
(if (not (bobp))
(if (and (eolp)
(progn (forward-line -1)
(or (looking-at mail-header-separator)
(and (eq major-mode 'mh-letter-mode)
(mh-in-header-p)))))
(progn (forward-line)
(let ((kill-lines-magic t)) (kill-line))))))
(defun sc-header-on-said ()
"\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be
found, in which case nothing is inserted; or 2. the \"date\" field is
missing in which case only the from part is printed."
(let* ((sc-mumble-string "")
(whofrom (sc-field "from"))
(when (sc-field "date")))
(if (not (string= whofrom ""))
(insert sc-reference-tag-string
(if (not (string= when ""))
(concat "On " when ", ") "")
whofrom " said:\n"))))
(defun sc-header-inarticle-writes ()
"\"In article <message-id>, <from> writes:\"
Treats \"message-id\" and \"from\" fields similar to sc-header-on-said."
(let* ((sc-mumble-string "")
(whofrom (sc-field "from"))
(msgid (sc-field "message-id")))
(if (not (string= whofrom ""))
(insert sc-reference-tag-string
(if (not (string= msgid ""))
(concat "In article " msgid ", ") "")
whofrom " writes:\n"))))
(defun sc-header-regarding-adds ()
"\"Regarding <subject>; <from> adds:\"
Treats \"subject\" and \"from\" fields similar to sc-header-on-said."
(let* ((sc-mumble-string "")
(whofrom (sc-field "from"))
(subj (sc-field "subject")))
(if (not (string= whofrom ""))
(insert sc-reference-tag-string
(if (not (string= subj ""))
(concat "Regarding " subj "; ") "")
whofrom " adds:\n"))))
(defun sc-header-attributed-writes ()
"\"<sc-attribution>\" == <sc-author> <address> writes:
Treats these fields in a similar manner to sc-header-on-said."
(let* ((sc-mumble-string "")
(whofrom (sc-field "from"))
(reply (sc-field "sc-reply-address"))
(from (sc-field "sc-from-address"))
(attr (sc-field "sc-attribution"))
(auth (sc-field "sc-author")))
(if (not (string= whofrom ""))
(insert sc-reference-tag-string
(if (not (string= attr ""))
(concat "\"" attr "\" == " ) "")
(if (not (string= auth ""))
(concat auth " ") "")
(if (not (string= reply ""))
(concat "<" reply ">")
(if (not (string= from ""))
(concat "<" from ">") ""))
" writes:\n"))))
(defun sc-header-verbose ()
"Very verbose, some say gross."
(let* ((sc-mumble-string "")
(whofrom (sc-field "from"))
(reply (sc-field "sc-reply-address"))
(from (sc-field "sc-from-address"))
(author (sc-field "sc-author"))
(date (sc-field "date"))
(org (sc-field "organization"))
(msgid (sc-field "message-id"))
(ngrps (sc-field "newsgroups"))
(subj (sc-field "subject"))
(refs (sc-field "references"))
(cite (sc-field "sc-citation"))
(nl sc-reference-tag-string))
(if (not (string= whofrom ""))
(insert (if (not (string= date ""))
(concat nl "On " date ",\n") "")
(concat nl (if (not (string= author ""))
author
whofrom) "\n")
(if (not (string= org ""))
(concat nl "from the organization of " org "\n") "")
(if (not (string= reply ""))
(concat nl "who can be reached at: " reply "\n")
(if (not (string= from ""))
(concat nl "who can be reached at: " from "\n") ""))
(if (not (string= cite ""))
(concat nl "(whose comments are cited below with \""
cite "\"),\n") "")
(if (not (string= msgid ""))
(concat nl "had this to say in article " msgid "\n") "")
(if (not (string= ngrps ""))
(concat nl "in newsgroups " ngrps "\n") "")
(if (not (string= subj ""))
(concat nl "concerning the subject of " subj "\n") "")
(if (not (string= refs ""))
(concat nl "(see " refs " for more details)\n") "")
))))
;; ======================================================================
;; this section queries the user for necessary information
(defun sc-query (&optional default)
"Query for an attribution string with the optional DEFAULT choice.
Returns the string entered by the user, if non-empty and non-nil, or
DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution
is used."
(if (not default) (setq default sc-default-attribution))
(let* ((prompt (concat "Enter attribution string: (default " default ") "))
(query (read-string prompt)))
(if (or (null query)
(string= query ""))
default
query)))
(defun sc-confirm ()
"Confirm the preferred attribution with the user."
(if (or sc-confirm-always-p
sc-force-confirmation-p)
(aput 'sc-gal-attributions
(let* ((default (aheadsym sc-gal-attributions))
chosen
(prompt (concat "Complete "
(cond
((eq sc-cite-context 'citing) "cite")
((eq sc-cite-context 'reciting) "recite")
(t ""))
" attribution string: (default "
default ") "))
(minibuffer-local-completion-map
(copy-keymap minibuffer-local-completion-map)))
(define-key minibuffer-local-completion-map "\C-g"
'(lambda () (interactive) (beep) (throw 'select-abort nil)))
(setq chosen (completing-read prompt sc-gal-attributions))
(if (or (not chosen)
(string= chosen ""))
default
chosen)))))
;; ======================================================================
;; this section contains primitive functions used in the email address
;; parsing schemes. they extract name fields from various parts of
;; the "from:" field.
(defun sc-style1-addresses (from-string &optional delim)
"Extract the author's email terminus from email address FROM-STRING.
Match addresses of the style \"name%[stuff].\" when called with DELIM
of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when
called with DELIM \"@\". If DELIM is nil or not provided, matches
addresses of the style \"name\"."
(and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0)
(substring from-string
(match-beginning 0)
(- (match-end 0) (if (null delim) 0 1)))))
(defun sc-style2-addresses (from-string)
"Extract the author's email terminus from email address FROM-STRING.
Match addresses of the style \"[stuff]![stuff]...!name[stuff].\""
(let ((eos (length from-string))
(mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)"
from-string 0))
(mend (match-end 0)))
(and mstart
(substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1)))
)))
(defun sc-get-address (from-string author)
"Get the full email address path from FROM-STRING.
AUTHOR is the author's name (which is removed from the address)."
(let ((eos (length from-string)))
(if (string-match (concat "\\(^\\|^\"\\)" author
"\\(\\s +\\|\"\\s +\\)") from-string 0)
(let ((addr (substring from-string (match-end 0) eos)))
(if (and (= (aref addr 0) ?<)
(= (aref addr (1- (length addr))) ?>))
(substring addr 1 (1- (length addr)))
addr))
(if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0)
(substring from-string (match-beginning 0) (match-end 0))
"")
)))
(defun sc-get-emailname (from-string)
"Get the email terminus name from FROM-STRING."
(cond
((sc-style1-addresses from-string "%"))
((sc-style1-addresses from-string "@"))
((sc-style2-addresses from-string))
((sc-style1-addresses from-string nil))
(t (substring from-string 0 10))))
;; ======================================================================
;; this section contains functions that will extract a list of names
;; from the name field string.
(defun sc-spacify-name-chars (name)
(let ((len (length name))
(s 0))
(while (< s len)
(if (memq (aref name s) sc-spacify-name-chars)
(aset name s 32))
(setq s (1+ s)))
name))
(defun sc-name-substring (string start end extend)
"Extract the specified substring of STRING from START to END.
EXTEND is the number of characters on each side to extend the
substring."
(and start
(let ((sos (+ start extend))
(eos (- end extend)))
(substring string sos
(or (string-match sc-titlecue-regexp string sos) eos)
))))
(defun sc-extract-namestring (from-string)
"Extract the name string from FROM-STRING.
This should be the author's full name minus an optional title."
(let ((pstart (string-match "(.*)" from-string 0))
(pend (match-end 0))
(qstart (string-match "\".*\"" from-string 0))
(qend (match-end 0))
(bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0))
(bend (match-end 0)))
(sc-spacify-name-chars
(cond
((sc-name-substring from-string pstart pend 1))
((sc-name-substring from-string qstart qend 1))
((sc-name-substring from-string bstart bend 0))
))))
(defun sc-chop-namestring (namestring)
"Convert NAMESTRING to a list of names.
example: (sc-namestring-to-list \"John Xavier Doe\")
=> (\"John\" \"Xavier\" \"Doe\")"
(if (not (string= namestring ""))
(append (list (sc-string-car namestring))
(sc-chop-namestring (sc-string-cdr namestring)))))
(defun sc-strip-initials (namelist)
"Extract the author's initials from the NAMELIST."
(if (not namelist)
nil
(concat (if (string= (car namelist) "")
""
(substring (car namelist) 0 1))
(sc-strip-initials (cdr namelist)))))
;; ======================================================================
;; this section handles selection of the attribution and citation strings
(defun sc-populate-alists (from-string)
"Put important and useful information in the alists using FROM-STRING.
Return the list of name symbols."
(let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string)))
(revnames (reverse (cdr namelist)))
(midnames (reverse (cdr revnames)))
(firstname (car namelist))
(midnames (reverse (cdr revnames)))
(lastname (car revnames))
(initials (sc-strip-initials namelist))
(emailname (sc-get-emailname from-string))
(n 1)
(symlist (list 'emailname 'initials 'firstname 'lastname)))
;; put basic information
(aput 'sc-gal-attributions 'firstname firstname)
(aput 'sc-gal-attributions 'lastname lastname)
(aput 'sc-gal-attributions 'emailname emailname)
(aput 'sc-gal-attributions 'initials initials)
(aput 'sc-gal-information "sc-firstname" firstname)
(aput 'sc-gal-information "sc-lastname" lastname)
(aput 'sc-gal-information "sc-emailname" emailname)
(aput 'sc-gal-information "sc-initials" initials)
;; put middle names and build sc-author entry
(let ((author (concat firstname " ")))
(while midnames
(let ((name (car midnames))
(next (cdr midnames))
(symbol (intern (format "middlename%d" n)))
(string (format "sc-middlename-%d" n)))
;; first put new middlename
(aput 'sc-gal-attributions symbol name)
(aput 'sc-gal-information string name)
(setq n (1+ n))
(nconc symlist (list symbol))
;; now build author name
(setq author (concat author name " "))
;; incr loop
(setq midnames next)
))
(setq author (concat author lastname))
;; put author name and email address
(aput 'sc-gal-information "sc-author" author)
(aput 'sc-gal-information "sc-from-address"
(sc-get-address from-string author))
(aput 'sc-gal-information "sc-reply-address"
(sc-get-address (sc-field "reply-to") author))
)
;; return value
symlist))
(defun sc-sort-attribution-alist ()
"Put preferred attribution at head of attributions alist."
(asort 'sc-gal-attributions sc-preferred-attribution)
;; use backup scheme if preference is not legal
(if (or (null sc-preferred-attribution)
(anot-head-p sc-gal-attributions sc-preferred-attribution)
(let ((prefval (aget sc-gal-attributions
sc-preferred-attribution)))
(or (null prefval)
(string= prefval ""))))
;; no legal attribution
(if sc-use-only-preference-p
(aput 'sc-gal-attributions 'sc-user-query
(sc-query sc-default-attribution))
;; else use secondary scheme
(asort 'sc-gal-attributions 'firstname))))
(defun sc-build-attribution-alist (from-string)
"Extract attributions from FROM-STRING, applying preferences."
(let ((symlist (sc-populate-alists from-string))
(headval (progn (sc-sort-attribution-alist)
(aget sc-gal-attributions
(aheadsym sc-gal-attributions) t))))
;; for each element in the symlist, remove the corresponding
;; key-value pair in the alist, then insert just the value.
(while symlist
(let ((value (aget sc-gal-attributions (car symlist) t))
(next (cdr symlist)))
(if (not (or (null value)
(string= value "")))
(aput 'sc-gal-attributions value))
(adelete 'sc-gal-attributions (car symlist))
(setq symlist next)))
;; add nicknames to the completion list
(let ((gal sc-gal-attributions))
(while gal
(let ((nns sc-nicknames-alist)
(galname (car (car gal))))
(while nns
(if (string= galname (car (car nns)))
(aput 'sc-gal-attributions (car (cdr (car nns)))))
(setq nns (cdr nns)))
(setq gal (cdr gal)))))
;; now reinsert the head (preferred) attribution unless it is nil,
;; this effectively just moves the head value to the front of the
;; list.
(if headval
(aput 'sc-gal-attributions headval))
;; check to be sure alist is not nil
(if (null sc-gal-attributions)
(aput 'sc-gal-attributions sc-default-attribution))))
(defun sc-select ()
"Select an attribution and create a citation string."
(cond
(sc-nested-citation-p
(sc-update-gal ""))
((null (aget sc-gal-information "from" t))
(aput 'sc-gal-information "sc-author" sc-default-author-name)
(sc-update-gal (sc-query sc-default-attribution)))
((null sc-gal-attributions)
(sc-build-attribution-alist (aget sc-gal-information "from" t))
(sc-confirm)
(sc-update-gal (aheadsym sc-gal-attributions)))
(t
(sc-confirm)
(sc-update-gal (aheadsym sc-gal-attributions))))
t)
;; ======================================================================
;; region citing and unciting
(defun sc-cite-region (start end)
"Cite a region delineated by START and END."
(save-excursion
;; set real end-of-region
(goto-char end)
(forward-line 1)
(set-mark (point))
;; goto real beginning-of-region
(goto-char start)
(beginning-of-line)
(let ((fstart (point))
(fend (point)))
(while (< (point) (sc-mark))
;; remove leading whitespace if desired
(and sc-fixup-whitespace-p
(fixup-whitespace))
;; if end of line then perhaps autofill
(cond ((eolp)
(or (= fstart fend)
(not sc-auto-fill-region-p)
(and sc-auto-fill-query-each-paragraph-p
(not (y-or-n-p "Fill this paragraph? ")))
(save-excursion (set-mark fend)
(goto-char (/ (+ fstart fend 1) 2))
(run-hooks 'sc-fill-paragraph-hook)))
(setq fstart (point)
fend (point)))
;; not end of line so perhaps cite it
((not (looking-at sc-cite-regexp))
(insert (aget sc-gal-information "sc-citation")))
(sc-nested-citation-p
(insert (aget sc-gal-information "sc-nested-citation"))))
(setq fend (point))
(forward-line 1))
(and sc-auto-fill-query-each-paragraph-p
(message " "))
)))
(defun sc-uncite-region (start end cite-regexp)
"Uncite a previously cited region delineated by START and END.
CITE-REGEXP describes how a cited line of texts starts. Unciting also
auto-fills paragraph if sc-auto-fill-region-p is non-nil."
(save-excursion
(set-mark end)
(goto-char start)
(beginning-of-line)
(let ((fstart (point))
(fend (point)))
(while (< (point) (sc-mark))
;; if end of line, then perhaps autofill
(cond ((eolp)
(or (= fstart fend)
(not sc-auto-fill-region-p)
(and sc-auto-fill-query-each-paragraph-p
(not (y-or-n-p "Fill this paragraph? ")))
(save-excursion (set-mark fend)
(goto-char (/ (+ fstart fend 1) 2))
(run-hooks 'sc-fill-paragraph-hook)))
(setq fstart (point)
fend (point)))
;; not end of line so perhaps uncite it
((looking-at cite-regexp)
(save-excursion
(save-restriction
(narrow-to-region (sc-linepos 'bol) (sc-linepos))
(beginning-of-line)
(delete-region (point-min)
(progn (re-search-forward cite-regexp
(point-max)
t)
(match-end 0)))))))
(setq fend (point))
(forward-line 1)))))
;; ======================================================================
;; this section contains paragraph filling support
(defun sc-guess-fill-prefix (&optional literalp)
"Guess the fill prefix used on the current line.
Use various heuristics to find the fill prefix. Search begins on first
non-blank line after point.
1) If fill-prefix is already bound to the empty string, return
nil.
2) If fill-prefix is already bound, but not to the empty
string, return the value of fill-prefix.
3) If the current line starts with the last chosen citation
string, then that string is returned.
4) If the current line starts with a string matching the regular
expression sc-cite-regexp, return the match. Note that if
optional LITERALP is provided and non-nil, then the *string*
that matches the regexp is return. Otherwise, if LITERALP is
not provided or is nil, the *regexp* sc-cite-regexp is
returned.
5) If the current line starts with any number of characters,
followed by the sc-citation-delimiter and then white space,
that match is returned. See comment #4 above for handling of
LITERALP.
6) Nil is returned."
(save-excursion
;; scan for first non-blank line in the region
(beginning-of-line)
(skip-chars-forward "\n\t ")
(beginning-of-line)
(let ((citation (aget sc-gal-information "sc-citation"))
(generic-citation
(concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +")))
(cond
((string= fill-prefix "") nil) ;; heuristic #1
(fill-prefix) ;; heuristic #2
((looking-at (regexp-quote citation)) citation) ;; heuristic #3
((looking-at sc-cite-regexp) ;; heuristic #4
(if literalp
(buffer-substring
(point)
(progn (re-search-forward (concat sc-cite-regexp "\\s *")
(point-max) nil)
(point)))
sc-cite-regexp))
((looking-at generic-citation) ;; heuristic #5
(if literalp
(buffer-substring
(point)
(progn (re-search-forward generic-citation) (point)))
generic-citation))
(t nil))))) ;; heuristic #6
(defun sc-consistent-cite-p (prefix)
"Check current paragraph for consistent citation.
Scans to paragraph delineated by (forward|backward)-paragraph to see
if all lines start with PREFIX. Returns t if entire paragraph is
consistently cited, nil otherwise."
(save-excursion
(let ((end (progn (forward-paragraph)
(beginning-of-line)
(or (not (eolp))
(forward-char -1))
(point)))
(start (progn (backward-paragraph)
(beginning-of-line)
(or (not (eolp))
(forward-char 1))
(point)))
(badline t))
(goto-char start)
(beginning-of-line)
(while (and (< (point) end)
badline)
(setq badline (looking-at prefix))
(forward-line 1))
badline)))
(defun sc-fill-start (fill-prefix)
"Find buffer position of start of region which begins with FILL-PREFIX.
Restrict scan to current paragraph."
(save-excursion
(let ((badline nil)
(top (save-excursion
(backward-paragraph)
(beginning-of-line)
(or (not (eolp))
(forward-char 1))
(point))))
(while (and (not badline)
(> (point) top))
(forward-line -1)
(setq badline (not (looking-at fill-prefix)))))
(forward-line 1)
(point)))
(defun sc-fill-end (fill-prefix)
"Find the buffer position of end of region which begins with FILL-PREFIX.
Restrict scan to current paragraph."
(save-excursion
(let ((badline nil)
(bot (save-excursion
(forward-paragraph)
(beginning-of-line)
(or (not (eolp))
(forward-char -1))
(point))))
(while (and (not badline)
(< (point) bot))
(beginning-of-line)
(setq badline (not (looking-at fill-prefix)))
(forward-line 1)))
(forward-line -1)
(point)))
(defun sc-fill-paragraph ()
"Supercite's paragraph fill function.
Fill the paragraph containing or following point. Use
sc-guess-fill-prefix to find the fill-prefix for the paragraph.
If the paragraph is inconsistently cited (mixed fill-prefix), then the
user is queried to restrict the the fill to only those lines around
point which begin with the fill prefix.
The variable sc-fill-arg is passed to fill-paragraph and
fill-region-as-paragraph which controls justification of the
paragraph. sc-fill-arg is set by sc-fill-paragraph-manually."
(save-excursion
(let ((pnt (point))
(fill-prefix (sc-guess-fill-prefix t)))
(cond
((not fill-prefix)
(fill-paragraph sc-fill-arg))
((sc-consistent-cite-p fill-prefix)
(fill-paragraph sc-fill-arg))
((y-or-n-p "Inconsistent citation found. Restrict? ")
(message "")
(fill-region-as-paragraph (progn (goto-char pnt)
(sc-fill-start fill-prefix))
(progn (goto-char pnt)
(sc-fill-end fill-prefix))
sc-fill-arg))
(t
(message "")
(progn
(setq fill-prefix (aget sc-gal-information "sc-citation"))
(fill-paragraph sc-fill-arg)))))))
;; ======================================================================
;; the following functions are the top level, interactive commands that
;; can be bound to key strokes
(defun sc-insert-reference (arg)
"Insert, at point, a reference header in the body of the reply.
Numeric ARG indicates which header style from sc-rewrite-header-list
to use when rewriting the header. No supplied ARG indicates use of
sc-preferred-header-style.
With just \\[universal-argument], electric reference insert mode is
entered, regardless of the value of sc-electric-references-p. See
sc-electric-mode for more information."
(interactive "P")
(if (consp arg)
(sc-electric-mode)
(let ((pref (cond ((sc-valid-index-p arg) arg)
((sc-valid-index-p sc-preferred-header-style)
sc-preferred-header-style)
(t 0))))
(if sc-electric-references-p (sc-electric-mode pref)
(condition-case err
(eval (nth pref sc-rewrite-header-list))
(void-function
(progn (message
"Symbol's function definition is void: %s. (Header %d)."
(symbol-name (car (cdr err)))
pref)
(beep)))
(error
(progn (message "Error evaluating rewrite header function %d."
pref)
(beep)))
)))))
(defun sc-cite (arg)
"Cite the region of text between point and mark.
Numeric ARG, if supplied, is passed unaltered to sc-insert-reference."
(interactive "P")
(if (not (sc-mark))
(error "Please designate a region to cite (i.e. set the mark)."))
(catch 'select-abort
(let ((sc-cite-context 'citing)
(sc-force-confirmation-p (interactive-p)))
(sc-select)
(undo-boundary)
(let ((xchange (if (> (sc-mark) (point)) nil
(exchange-point-and-mark)
t)))
(sc-insert-reference arg)
(sc-cite-region (point) (sc-mark))
;; leave point on first cited line
(while (and (< (point) (sc-mark))
(not (looking-at (aget sc-gal-information
(if sc-nested-citation-p
"sc-nested-citation"
"sc-citation")))))
(forward-line 1))
(and xchange
(exchange-point-and-mark))
))))
(defun sc-uncite ()
"Uncite the region between point and mark."
(interactive)
(if (not (sc-mark))
(error "Please designate a region to uncite (i.e. set the mark)."))
(undo-boundary)
(let ((xchange (if (> (sc-mark) (point)) nil
(exchange-point-and-mark)
t))
(fp (or (sc-guess-fill-prefix)
"")))
(sc-uncite-region (point) (sc-mark) fp)
(and xchange
(exchange-point-and-mark))))
(defun sc-recite ()
"Recite the region by first unciting then citing the text."
(interactive)
(if (not (sc-mark))
(error "Please designate a region to recite (i.e. set the mark)."))
(catch 'select-abort
(let ((sc-cite-context 'reciting)
(sc-force-confirmation-p t))
(sc-select)
(undo-boundary)
(let ((xchange (if (> (sc-mark) (point)) nil
(exchange-point-and-mark)
t))
(fp (or (sc-guess-fill-prefix)
"")))
(sc-uncite-region (point) (sc-mark) fp)
(sc-cite-region (point) (sc-mark))
(and xchange
(exchange-point-and-mark))
))))
(defun sc-insert-citation ()
"Insert citation string at beginning of current line."
(interactive)
(save-excursion
(beginning-of-line)
(insert (aget sc-gal-information "sc-citation"))))
(defun sc-open-line (arg)
"Insert a newline and leave point before it.
Also inserts the guessed prefix at the beginning of the new line. With
numeric ARG, inserts that many new lines."
(interactive "p")
(save-excursion
(let ((start (point))
(string (or (sc-guess-fill-prefix t)
"")))
(open-line arg)
(goto-char start)
(forward-line 1)
(while (< 0 arg)
(insert string)
(forward-line 1)
(setq arg (- arg 1))))))
(defun sc-fill-paragraph-manually (arg)
"Fill current cited paragraph.
Really just runs the hook sc-fill-paragraph-hook, however it does set
the global variable sc-fill-arg to the value of ARG. This is
currently the only way to pass an argument to a hookified function."
(interactive "P")
(setq sc-fill-arg arg)
(run-hooks 'sc-fill-paragraph-hook))
(defun sc-modify-information (arg)
"Interactively modify information in the information alist.
\\[universal-argument] if supplied, deletes the entry from the alist.
You can add an entry by supplying a key instead of completing."
(interactive "P")
(let* ((delete-p (consp arg))
(action (if delete-p "delete" "modify"))
(defaultkey (aheadsym sc-gal-information))
(prompt (concat "Select information key to "
action ": (default "
defaultkey ") "))
(key (completing-read prompt sc-gal-information))
)
(if (or (string= key "")
(null key))
(setq key defaultkey))
(if delete-p (adelete 'sc-gal-information key)
(let* ((oldval (aget sc-gal-information key t))
(prompt (concat "Enter new value for key \""
key "\" (default \"" oldval "\") "))
(newval (read-input prompt)))
(if (or (string= newval "")
(null newval))
nil
(aput 'sc-gal-information key newval)
)))))
(defun sc-view-field (arg)
"View field values in the information alist.
This is essentially an interactive version of sc-field, and is similar
to sc-modify-information, except that the field values can't be
modified. With \\[universal-argument], if supplied, inserts the value
into the current buffer as well."
(interactive "P")
(let* ((defaultkey (aheadsym sc-gal-information))
(prompt (concat "View information key: (default "
defaultkey ") "))
(key (completing-read prompt sc-gal-information)))
(if (or (string= key "")
(null key))
(setq key defaultkey))
(let* ((val (aget sc-gal-information key t))
(pval (if val (concat "\"" val "\"") "nil")))
(message "value of key %s: %s" key pval)
(if (and key (consp arg)) (insert val)))))
(defun sc-glom-headers ()
"Glom information from mail headers in region between point and mark.
Any old information is lost, unless an error occurs."
(interactive)
(let ((attr (copy-sequence sc-gal-attributions))
(info (copy-sequence sc-gal-information)))
(setq sc-gal-attributions nil
sc-gal-information nil)
(let (start end
(sc-force-confirmation-p t)
(sc-cite-context nil))
(let ((mark-active t))
(setq start (region-beginning)
end (region-end)))
(sc-fetch-fields start end)
(if (null sc-gal-information)
(progn
(message "No mail headers found! Restoring old information.")
(setq sc-gal-attributions attr
sc-gal-information info))
(sc-mail-yank-clear-headers start end)
(if (not (catch 'select-abort
(condition-case foo
(sc-select)
(quit (beep) (throw 'select-abort nil)))
))
(setq sc-gal-attributions attr
sc-gal-information info))
))))
(defun sc-version (arg)
"Show supercite version.
Universal argument (\\[universal-argument]) ARG inserts version
information in the current buffer instead of printing the message in
the echo area."
(interactive "P")
(if (consp arg)
(insert "Using Supercite version " sc-version-number)
(message "Using Supercite version %s" sc-version-number)))
;; ======================================================================
;; leach onto current mode
(defun sc-append-current-keymap ()
"Append some useful key bindings to the current local key map.
This searches sc-local-keymap for the keymap to install based on the
major-mode of the current buffer."
(let ((hook (car (cdr (assq major-mode sc-local-keymaps)))))
(cond
((not hook)
(run-hooks 'sc-default-keymap))
((not (listp hook))
(setq hook (car (cdr (assq hook sc-local-keymaps))))
(run-hooks 'hook))
(t
(run-hooks 'hook))))
(setq sc-leached-keymap (current-local-map)))
(defun sc-snag-all-keybindings ()
"Snag all keybindings in major-mode's current keymap."
(let* ((curkeymap (current-local-map))
(symregexp ".*sc-.*\n")
(docstring (substitute-command-keys "\\{curkeymap}"))
(start 0)
(maxend (length docstring))
(spooge ""))
(while (and (< start maxend)
(string-match symregexp docstring start))
(setq spooge (concat spooge (substring docstring
(match-beginning 0)
(match-end 0))))
(setq start (match-end 0)))
spooge))
(defun sc-spoogify-docstring ()
"Modifies (makes into spooge) the docstring for the current major mode.
This will leach the keybinding descriptions for supercite onto the end
of the current major mode's docstring. If major mode is preloaded,
this function will first make a copy of the list associated with the
mode, then modify this copy."
(let* ((symfunc (symbol-function major-mode))
(doc-cdr (and (listp symfunc) (nthcdr 2 symfunc)))
(doc-str (documentation major-mode)))
(cond
;; is a docstring even provided?
((not (stringp doc-str)))
;; have we already leached on?
((string-match "Supercite" doc-str))
;; lets build the new doc string
(t
(let* ((described (sc-snag-all-keybindings))
(commonstr "
The major mode for this buffer has been modified to include the
Supercite 2.3 package for handling attributions and citations of
original messages in email replies. For more information on this
package, type \"\\[sc-describe]\".")
(newdoc-str
(concat doc-str commonstr
(if (not (string= described ""))
(concat "\n\nThe following keys are bound "
"to Supercite commands:\n\n"
described)))
))
(cond
(doc-cdr
(condition-case nil
(setcar doc-cdr newdoc-str)
(error
;; the major mode must be preloaded, make a copy first
(setq symfunc (copy-sequence (symbol-function major-mode))
doc-cdr (nthcdr 2 symfunc))
(setcar doc-cdr newdoc-str)
(fset major-mode symfunc))))
;; lemacs 19 byte-code.
;; Set function to a new byte-code vector with the
;; new documentation in the documentation slot (element 4).
;; We can't use aset because aset won't allow you to modify
;; a byte-code vector.
;; Include element 5 if the vector has one.
(t
(fset major-mode
(apply 'make-byte-code
(aref symfunc 0) (aref symfunc 1)
(aref symfunc 2) (aref symfunc 3)
newdoc-str
(if (> (length symfunc) 5)
(list (aref symfunc 5)))))
)))))))
;; ======================================================================
;; this section contains default hooks and hook support for execution
;;;###autoload
(defun sc-cite-original ()
"Hook version of sc-cite.
This is callable from the various mail and news readers' reply
function according to the agreed upon standard. See \\[sc-describe]
for more details. Sc-cite-original does not do any yanking of the
original message but it does require a few things:
1) The reply buffer is the current buffer.
2) The original message has been yanked and inserted into the
reply buffer.
3) Verbose mail headers from the original message have been
inserted into the reply buffer directly before the text of the
original message.
4) Point is at the beginning of the verbose headers.
5) Mark is at the end of the body of text to be cited."
(run-hooks 'sc-pre-hook)
(setq sc-gal-attributions nil)
(setq sc-gal-information nil)
(let (start end)
(let ((mark-active t))
(setq start (region-beginning)
end (region-end)))
(sc-fetch-fields start end)
(sc-mail-yank-clear-headers start end)
(if (not sc-all-but-cite-p)
(sc-cite sc-preferred-header-style))
(sc-append-current-keymap)
(sc-spoogify-docstring)
(run-hooks 'sc-post-hook)))
;; ======================================================================
;; describe this package
;;
(defun sc-describe ()
"Supercite version 2.3 is now described in a texinfo manual which
makes the documentation available both for online perusal via emacs'
info system, or for hard-copy printing using the TeX facility.
To view the online document hit \\[info], then \"mSupercite <RET>\"."
(interactive)
(describe-function 'sc-describe))
;; ======================================================================
;; load hook
(run-hooks 'sc-load-hook)
(provide 'sc)
Reference in New Issue View Git Blame Copy Permalink