1 ;; -*- Mode: Emacs-Lisp -*-
2 ;; sc.el -- Version 2.3 (used to be supercite.el)
4 ;; ========== Introduction ==========
5 ;; Citation and attribution package for various GNU emacs news and
6 ;; electronic mail reading subsystems. This version of supercite will
7 ;; interface to VM 4.40+ and MH-E 3.7 (shipped w/ emacs 18.57) as is.
8 ;; It will also interface with GNUS 3.12+, RMAIL 18.55+, GNEWS, and
9 ;; probably most other news/mail subsystems by using the overloading
10 ;; functions provided in sc-oloads.el (see that file or the README for
11 ;; more information on interfacing supercite with your reader subsystem).
12 ;; This version should now be compatible with Lucid Emacs 19.x emacses.
14 ;; This package does not do any yanking of messages, but instead
15 ;; massages raw reply buffers set up by the reply/forward functions in
16 ;; the news/mail subsystems. Therefore, such useful operations as
17 ;; yanking and citing portions of the original article (instead of the
18 ;; whole article) are not within the ability or responsibility of
21 ;; ========== Disclaimer ==========
22 ;; This software is distributed in the hope that it will be useful,
23 ;; but WITHOUT ANY WARRANTY. No author or distributor, nor any
24 ;; author's past, present, or future employers accepts responsibility
25 ;; to anyone for the consequences of using it or for whether it serves
26 ;; any particular purpose or works at all, unless he says so in
29 ;; Some of this software was written as part of the supercite author's
30 ;; official duty as an employee of the United States Government and is
31 ;; thus not subject to copyright. You are free to use that particular
32 ;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It
33 ;; would be nice, though if when you use any of this or other freely
34 ;; available code, you give due credit to the author.
36 ;; Other parts of this code were written by other people. Wherever
37 ;; possible, credit to that author, and the copy* notice supplied by
38 ;; the author are included with that code. The supercite author is no
39 ;; longer an employee of the U.S. Government so the GNU Public Licence
40 ;; should be considered in effect for all enhancements and bug fixes
41 ;; performed by the author.
43 ;; ========== Author (unless otherwise stated) ========================
44 ;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
45 ;; TELE: (301) 593-3330 1014 West Street
46 ;; INET: bwarsaw@cen.com Laurel, Md 20707
47 ;; UUCP: uunet!cen.com!bwarsaw
49 ;; Want to be on the Supercite mailing list?
52 ;; Internet: supercite@anthem.nlm.nih.gov
53 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite
55 ;; Send administrivia (additions/deletions to list, etc) to:
56 ;; Internet: supercite-request@anthem.nlm.nih.gov
57 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request
59 ;; ========== Credits and Thanks ==========
60 ;; This package was derived from the Superyank 1.11 package as posted
61 ;; to the net. Superyank 1.11 was inspired by code and ideas from
62 ;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved
63 ;; through the comments and suggestions of the supercite mailing list
64 ;; which consists of many authors and users of the various mail and
65 ;; news reading subsystems.
67 ;; Many folks on the supercite mailing list have contributed their
68 ;; help in debugging, making suggestions and supplying support code or
69 ;; bug fixes for the previous versions of supercite. I want to thank
70 ;; everyone who helped, especially (in no particular order):
72 ;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle
73 ;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van
74 ;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells.
76 ;; I don't mean to leave anyone out. All who have helped have been
79 ;; ========== Getting Started ==========
80 ;; Here is a quick guide to getting started with supercite. The
81 ;; information contained here is mostly excerpted from the more
82 ;; detailed explanations given in the accompanying README file.
83 ;; Naturally, there are many customizations you can do to give your
84 ;; replies that personalized flair, but the instructions in this
85 ;; section should be sufficient for getting started.
87 ;; With this release of supercite overloading is the only supported
88 ;; way to get supercite hooked into your favorite news/mail reading
89 ;; subsystems. Overloading will be necessary for RMAIL, GNUS, GNEWS,
90 ;; RNEWS and PCMAIL. Overloading will not be needed for VM 4.37+ or
91 ;; MH-E 3.7+. MH-E comes with emacs 18.57 but if you have an earlier
92 ;; version of emacs, you should be able to ftp MH-E 3.7 separately. Or
93 ;; you can extract the MH-E overloading stuff from version 2.1's
96 ;; First, to connect supercite to any mail/news reading subsystem, put
97 ;; this in your .emacs file:
99 ;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents
100 ;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only
101 ;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents
103 ;; If supercite is not pre-loaded into your emacs session, you should
104 ;; add the following autoload:
106 ;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t)
108 ;; Then, if you need to overload, put the following in your .emacs file:
110 ;; (defun my-sc-overload-hook ()
111 ;; (require 'sc-oloads) ; be sure this file is on your load-path
112 ;; (sc-overload-functions))
114 ;; (setq news-reply-mode-hook 'my-sc-overload-hook) ; for RNEWS,GNUS,GNEWS
115 ;; (setq mail-setup-hook 'my-sc-overload-hook) ; for RMAIL, PCMAIL
117 ;; Finally, if you want to customize supercite, you should do it in a
118 ;; function called my-supercite-hook and:
120 ;; (setq sc-load-hook 'my-supercite-hook)
125 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
126 ;; start of user defined variables
127 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
129 (defvar sc-nested-citation-p nil
130 "*Controls whether to use nested or non-nested citation style.
131 Non-nil uses nested citations, nil uses non-nested citations. Type
132 \\[sc-describe] for more information.")
134 (defvar sc-citation-leader " "
135 "*String comprising first part of a citation.")
137 (defvar sc-citation-delimiter ">"
138 "*String comprising third part of a citation.
139 This string is used in both nested and non-nested citations.")
141 (defvar sc-citation-separator " "
142 "*String comprising fourth and last part of a citation.")
144 (defvar sc-default-author-name "Anonymous"
145 "*String used when author's name cannot be determined.")
147 (defvar sc-default-attribution "Anon"
148 "*String used when author's attribution cannot be determined.")
150 ;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite
152 ;; I use supercite in Nemacs-3.3.2. In order to handle citation using
153 ;; Kanji, [...set sc-cite-regexp to...]
154 ;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+"
156 (defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *"
157 "*Regular expression describing how a already cited line begins.
158 The regexp is only used at the beginning of a line, so it doesn't need
159 to start with a '^'.")
161 (defvar sc-titlecue-regexp "\\s +-+\\s +"
162 "*Regular expression describing the separator between names and titles.
163 Set to nil to treat entire field as a name.")
165 (defvar sc-spacify-name-chars '(?_ ?* ?+ ?=)
166 "*List of characters to convert to spaces if found in an author's name.")
168 (defvar sc-nicknames-alist
175 ("Elizabeth" "Betsy")
178 "*Association list of names and their common nicknames.
179 Entries are of the form (NAME NICKNAME), and NAMEs can have more than
180 one nickname. Nicknames will not be automatically used as an
181 attribution string, since I'm not sure this is really polite, but if a
182 name is glommed from the author name and presented in the attribution
183 string completion list, the matching nicknames will also be presented.
184 Set this variable to nil to defeat nickname expansions. Also note that
185 nicknames are not put in the supercite information alist.")
187 (defvar sc-confirm-always-p t
188 "*If non-nil, always confirm attribution string before citing text body.")
190 (defvar sc-preferred-attribution 'firstname
191 "*Specifies which part of the author's name becomes the attribution.
192 The value of this variable must be one of the following quoted symbols:
194 emailname -- email terminus name
195 initials -- initials of author
196 firstname -- first name of author
197 lastname -- last name of author
198 middlename1 -- first middle name of author
199 middlename2 -- second middle name of author
202 Middle name indexes can be any positive integer greater than 0, though
203 it is unlikely that many authors will supply more than one middle
204 name, if that many.")
206 (defvar sc-use-only-preference-p nil
207 "*Controls what happens when the preferred attribution cannot be found.
208 If non-nil, then sc-default-attribution will be used. If nil, then
209 some secondary scheme will be employed to find a suitable attribution
212 (defvar sc-downcase-p nil
213 "*Non-nil means downcase the attribution and citation strings.")
215 (defvar sc-rewrite-header-list
218 (sc-header-inarticle-writes)
219 (sc-header-regarding-adds)
220 (sc-header-attributed-writes)
222 (sc-no-blank-line-or-header)
224 "*List of reference header rewrite functions.
225 The variable sc-preferred-header-style controls which function in this
226 list is chosen for automatic reference header insertions. Electric
227 reference mode will cycle through this list of functions. For more
228 information, type \\[sc-describe].")
230 (defvar sc-preferred-header-style 1
231 "*Index into sc-rewrite-header-list specifying preferred header style.
232 Index zero accesses the first function in the list.")
234 (defvar sc-electric-references-p t
235 "*Use electric references if non-nil.")
237 (defvar sc-electric-circular-p t
238 "*Treat electric references as circular if non-nil.")
240 (defvar sc-mail-fields-list
241 '("date" "message-id" "subject" "newsgroups" "references"
242 "from" "return-path" "path" "reply-to" "organization"
244 "*List of mail header whose values will be saved by supercite.
245 These values can be used in header rewrite functions by accessing them
246 with the sc-field function. Mail headers in this list are case
247 insensitive and do not require a trailing colon.")
249 (defvar sc-mumble-string ""
250 "*Value returned by sc-field if chosen field cannot be found.")
252 (defvar sc-nuke-mail-headers-p t
253 "*Nuke or don't nuke mail headers.
254 If non-nil, nuke mail headers after gleaning useful information from
257 (defvar sc-reference-tag-string ">>>>> "
258 "*String used at the beginning of built-in reference headers.")
260 (defvar sc-fill-paragraph-hook 'sc-fill-paragraph
261 "*Hook for filling a paragraph.
262 This hook gets executed when you fill a paragraph either manually or
263 automagically. It expects point to be within the extent of the
264 paragraph that is going to be filled. This hook allows you to use a
265 different paragraph filling package than the one supplied with
268 (defvar sc-auto-fill-region-p nil
269 "*If non-nil, automatically fill each paragraph after it has been cited.")
271 (defvar sc-auto-fill-query-each-paragraph-p nil
272 "*If non-nil, query before filling each paragraph.
273 No querying and no filling will be performed if sc-auto-fill-region-p
276 (defvar sc-fixup-whitespace-p nil
277 "*If non-nil, delete all leading white space before citing.")
279 (defvar sc-all-but-cite-p nil
280 "*If non-nil, sc-cite-original does everything but cite the text.
281 This is useful for manually citing large messages, or portions of
282 large messages. When non-nil, sc-cite-original will still set up all
283 necessary variables and databases, but will skip the citing routine
284 which modify the reply buffer's text.")
286 (defvar sc-load-hook nil
287 "*User definable hook.
288 Runs after supercite is loaded. Set your customizations here.")
290 (defvar sc-pre-hook nil
291 "*User definable hook.
292 Runs before sc-cite-original executes.")
294 (defvar sc-post-hook nil
295 "*User definable hook.
296 Runs after sc-cite-original executes.")
298 (defvar sc-header-nuke-list
299 '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied"
300 "organization" "keywords" "distribution" "xref" "references" "expires"
301 "approved" "summary" "precedence" "subject" "newsgroup[s]?"
302 "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to"
303 "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]"
304 "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date"
306 "*List of mail headers to remove from body of reply.")
310 ;; ======================================================================
313 (defvar sc-default-keymap
315 (local-set-key "\C-c\C-r" 'sc-insert-reference)
316 (local-set-key "\C-c\C-t" 'sc-cite)
317 (local-set-key "\C-c\C-a" 'sc-recite)
318 (local-set-key "\C-c\C-u" 'sc-uncite)
319 (local-set-key "\C-c\C-i" 'sc-insert-citation)
320 (local-set-key "\C-c\C-o" 'sc-open-line)
321 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
322 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
323 (local-set-key "\C-c\C-m" 'sc-modify-information)
324 (local-set-key "\C-cf" 'sc-view-field)
325 (local-set-key "\C-cg" 'sc-glom-headers)
326 (local-set-key "\C-c\C-v" 'sc-version)
327 (local-set-key "\C-c?" 'sc-describe)
329 "*Default keymap if major-mode can't be found in `sc-local-keymaps'.")
331 (defvar sc-local-keymaps
334 (local-set-key "\C-c\C-r" 'sc-insert-reference)
335 (local-set-key "\C-c\C-t" 'sc-cite)
336 (local-set-key "\C-c\C-a" 'sc-recite)
337 (local-set-key "\C-c\C-u" 'sc-uncite)
338 (local-set-key "\C-c\C-i" 'sc-insert-citation)
339 (local-set-key "\C-c\C-o" 'sc-open-line)
340 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
341 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
342 (local-set-key "\C-c\C-m" 'sc-modify-information)
343 (local-set-key "\C-cf" 'sc-view-field)
344 (local-set-key "\C-cg" 'sc-glom-headers)
345 (local-set-key "\C-c\C-v" 'sc-version)
346 (local-set-key "\C-c?" 'sc-describe)
350 (local-set-key "\C-c\C-r" 'sc-insert-reference)
351 (local-set-key "\C-c\C-t" 'sc-cite)
352 (local-set-key "\C-c\C-a" 'sc-recite)
353 (local-set-key "\C-c\C-u" 'sc-uncite)
354 (local-set-key "\C-ci" 'sc-insert-citation)
355 (local-set-key "\C-c\C-o" 'sc-open-line)
356 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
357 (local-set-key "\C-c\C-m" 'sc-modify-information)
358 (local-set-key "\C-cf" 'sc-view-field)
359 (local-set-key "\C-cg" 'sc-glom-headers)
360 (local-set-key "\C-c\C-v" 'sc-version)
361 (local-set-key "\C-c?" 'sc-describe)
363 (news-reply-mode mail-mode)
364 (vm-mail-mode mail-mode)
365 (e-reply-mode mail-mode)
366 (n-reply-mode mail-mode)
368 "*List of keymaps to use with the associated major-mode.")
370 (defvar sc-electric-mode-map nil
371 "*Keymap for sc-electric-mode.")
373 (if sc-electric-mode-map
375 (setq sc-electric-mode-map (make-sparse-keymap))
376 (define-key sc-electric-mode-map "p" 'sc-eref-prev)
377 (define-key sc-electric-mode-map "n" 'sc-eref-next)
378 (define-key sc-electric-mode-map "s" 'sc-eref-setn)
379 (define-key sc-electric-mode-map "j" 'sc-eref-jump)
380 (define-key sc-electric-mode-map "x" 'sc-eref-abort)
381 (define-key sc-electric-mode-map "\r" 'sc-eref-exit)
382 (define-key sc-electric-mode-map "\n" 'sc-eref-exit)
383 (define-key sc-electric-mode-map "q" 'sc-eref-exit)
384 (define-key sc-electric-mode-map "g" 'sc-eref-goto)
387 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
388 ;; end of user defined variables
389 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
392 ;; ======================================================================
393 ;; global variables, not user accessible
395 (defconst sc-version-number "2.3"
396 "Supercite's version number.")
398 ;; when rnewspost.el patch is installed (or function is overloaded)
399 ;; this should be nil since supercite now does this itself.
400 (setq news-reply-header-hook nil)
402 ;; autoload for sc-electric-mode
403 (autoload 'sc-electric-mode "sc-elec"
404 "Quasi-major mode for viewing supercite reference headers." nil)
406 ;; global alists (gals), misc variables. make new bytecompiler happy
407 (defvar sc-gal-information nil
408 "Internal global alist variable containing information.")
409 (defvar sc-gal-attributions nil
410 "Internal global alist variable containing attributions.")
411 (defvar sc-fill-arg nil
412 "Internal fill argument holder.")
413 (defvar sc-cite-context nil
414 "Internal citation context holder.")
415 (defvar sc-force-confirmation-p nil
416 "Internal variable.")
418 (make-variable-buffer-local 'sc-gal-attributions)
419 (make-variable-buffer-local 'sc-gal-information)
420 (make-variable-buffer-local 'sc-leached-keymap)
421 (make-variable-buffer-local 'sc-fill-arg)
422 (make-variable-buffer-local 'sc-cite-context)
424 (setq-default sc-gal-attributions nil)
425 (setq-default sc-gal-information nil)
426 (setq-default sc-leached-keymap (current-local-map))
427 (setq-default sc-fill-arg nil)
428 (setq-default sc-cite-context nil)
432 ;; ======================================================================
433 ;; miscellaneous support functions
436 "Mark compatibility between emacs v18 and v19."
437 (let ((zmacs-regions nil))
438 (marker-position (mark-marker))))
440 (defun sc-update-gal (attribution)
441 "Update the information alist.
442 Add ATTRIBUTION and compose the nested and non-nested citation
444 (let ((attrib (if sc-downcase-p (downcase attribution) attribution)))
445 (aput 'sc-gal-information "sc-attribution" attrib)
446 (aput 'sc-gal-information "sc-nested-citation"
447 (concat attrib sc-citation-delimiter))
448 (aput 'sc-gal-information "sc-citation"
449 (concat sc-citation-leader
451 sc-citation-delimiter
452 sc-citation-separator))))
454 (defun sc-valid-index-p (index)
455 "Returns t if INDEX is a valid index into sc-rewrite-header-list."
456 (let ((last (1- (length sc-rewrite-header-list))))
457 (and (natnump index) ;; a number, and greater than or equal to zero
458 (<= index last) ;; less than or equal to the last index
461 (defun sc-string-car (namestring)
462 "Return the string-equivalent \"car\" of NAMESTRING.
464 example: (sc-string-car \"John Xavier Doe\")
466 (substring namestring
467 (progn (string-match "\\s *" namestring) (match-end 0))
468 (progn (string-match "\\s *\\S +" namestring) (match-end 0))))
470 (defun sc-string-cdr (namestring)
471 "Return the string-equivalent \"cdr\" of NAMESTRING.
473 example: (sc-string-cdr \"John Xavier Doe\")
475 (substring namestring
476 (progn (string-match "\\s *\\S +\\s *" namestring)
479 (defun sc-linepos (&optional position col-p)
480 "Return the character position at various line positions.
481 Optional POSITION can be one of the following symbols:
482 bol == beginning of line
483 boi == beginning of indentation
484 eol == end of line [default]
486 Optional COL-P non-nil returns current-column instead of character position."
490 ((eq position 'bol) (beginning-of-line))
491 ((eq position 'boi) (back-to-indentation))
493 (setq rval (if col-p (current-column) (point)))
498 ;; ======================================================================
499 ;; this section snarfs mail fields and places them in the info alist
501 (defun sc-build-header-zap-regexp ()
502 "Return a regexp for sc-mail-yank-clear-headers."
503 (let ((headers sc-header-nuke-list)
506 (setq regexp (concat regexp
507 "^" (car headers) ":"
508 (if (cdr headers) "\\|" nil)))
509 (setq headers (cdr headers)))
512 (defun sc-mail-yank-clear-headers (start end)
513 "Nuke mail headers between START and END."
514 (if (and sc-nuke-mail-headers-p sc-header-nuke-list)
515 (let ((regexp (sc-build-header-zap-regexp)))
518 (if (search-forward "\n\n" end t)
520 (narrow-to-region start (point))
522 (while (let ((case-fold-search t))
523 (re-search-forward regexp nil t))
525 (delete-region (point)
526 (progn (re-search-forward "\n[^ \t]")
532 (defun sc-mail-fetch-field (field)
533 "Return the value of the header field FIELD.
534 The buffer is expected to be narrowed to just the headers of the
537 (goto-char (point-min))
538 (let ((case-fold-search t)
539 (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*")))
540 (goto-char (point-min))
541 (if (re-search-forward name nil t)
542 (let ((opoint (point)))
543 (while (progn (forward-line 1)
544 (looking-at "[ \t]")))
545 (buffer-substring opoint (1- (point))))))))
547 (defun sc-fetch-fields (start end)
548 "Fetch the mail fields in the region from START to END.
549 These fields can be accessed in header rewrite functions with sc-field."
552 (narrow-to-region start end)
554 (let ((fields sc-mail-fields-list))
556 (let ((value (sc-mail-fetch-field (car fields)))
559 (aput 'sc-gal-information (car fields) value))
561 (if (sc-mail-fetch-field "from")
562 (aput 'sc-gal-information "from" (sc-mail-fetch-field "from")))))))
564 (defun sc-field (field)
565 "Return the alist information associated with the FIELD.
566 If FIELD is not a valid key, return sc-mumble-string."
567 (or (aget sc-gal-information field) sc-mumble-string))
570 ;; ======================================================================
571 ;; built-in reference header rewrite functions
573 (defun sc-no-header ()
574 "Does nothing. Use this instead of nil to get a blank header."
577 (defun sc-no-blank-line-or-header()
578 "Similar to sc-no-header except it removes the preceding blank line."
581 (progn (forward-line -1)
582 (or (looking-at mail-header-separator)
583 (and (eq major-mode 'mh-letter-mode)
585 (progn (forward-line)
586 (let ((kill-lines-magic t)) (kill-line))))))
588 (defun sc-header-on-said ()
589 "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be
590 found, in which case nothing is inserted; or 2. the \"date\" field is
591 missing in which case only the from part is printed."
592 (let* ((sc-mumble-string "")
593 (whofrom (sc-field "from"))
594 (when (sc-field "date")))
595 (if (not (string= whofrom ""))
596 (insert sc-reference-tag-string
597 (if (not (string= when ""))
598 (concat "On " when ", ") "")
599 whofrom " said:\n"))))
601 (defun sc-header-inarticle-writes ()
602 "\"In article <message-id>, <from> writes:\"
603 Treats \"message-id\" and \"from\" fields similar to sc-header-on-said."
604 (let* ((sc-mumble-string "")
605 (whofrom (sc-field "from"))
606 (msgid (sc-field "message-id")))
607 (if (not (string= whofrom ""))
608 (insert sc-reference-tag-string
609 (if (not (string= msgid ""))
610 (concat "In article " msgid ", ") "")
611 whofrom " writes:\n"))))
613 (defun sc-header-regarding-adds ()
614 "\"Regarding <subject>; <from> adds:\"
615 Treats \"subject\" and \"from\" fields similar to sc-header-on-said."
616 (let* ((sc-mumble-string "")
617 (whofrom (sc-field "from"))
618 (subj (sc-field "subject")))
619 (if (not (string= whofrom ""))
620 (insert sc-reference-tag-string
621 (if (not (string= subj ""))
622 (concat "Regarding " subj "; ") "")
623 whofrom " adds:\n"))))
625 (defun sc-header-attributed-writes ()
626 "\"<sc-attribution>\" == <sc-author> <address> writes:
627 Treats these fields in a similar manner to sc-header-on-said."
628 (let* ((sc-mumble-string "")
629 (whofrom (sc-field "from"))
630 (reply (sc-field "sc-reply-address"))
631 (from (sc-field "sc-from-address"))
632 (attr (sc-field "sc-attribution"))
633 (auth (sc-field "sc-author")))
634 (if (not (string= whofrom ""))
635 (insert sc-reference-tag-string
636 (if (not (string= attr ""))
637 (concat "\"" attr "\" == " ) "")
638 (if (not (string= auth ""))
639 (concat auth " ") "")
640 (if (not (string= reply ""))
641 (concat "<" reply ">")
642 (if (not (string= from ""))
643 (concat "<" from ">") ""))
646 (defun sc-header-verbose ()
647 "Very verbose, some say gross."
648 (let* ((sc-mumble-string "")
649 (whofrom (sc-field "from"))
650 (reply (sc-field "sc-reply-address"))
651 (from (sc-field "sc-from-address"))
652 (author (sc-field "sc-author"))
653 (date (sc-field "date"))
654 (org (sc-field "organization"))
655 (msgid (sc-field "message-id"))
656 (ngrps (sc-field "newsgroups"))
657 (subj (sc-field "subject"))
658 (refs (sc-field "references"))
659 (cite (sc-field "sc-citation"))
660 (nl sc-reference-tag-string))
661 (if (not (string= whofrom ""))
662 (insert (if (not (string= date ""))
663 (concat nl "On " date ",\n") "")
664 (concat nl (if (not (string= author ""))
667 (if (not (string= org ""))
668 (concat nl "from the organization of " org "\n") "")
669 (if (not (string= reply ""))
670 (concat nl "who can be reached at: " reply "\n")
671 (if (not (string= from ""))
672 (concat nl "who can be reached at: " from "\n") ""))
673 (if (not (string= cite ""))
674 (concat nl "(whose comments are cited below with \""
676 (if (not (string= msgid ""))
677 (concat nl "had this to say in article " msgid "\n") "")
678 (if (not (string= ngrps ""))
679 (concat nl "in newsgroups " ngrps "\n") "")
680 (if (not (string= subj ""))
681 (concat nl "concerning the subject of " subj "\n") "")
682 (if (not (string= refs ""))
683 (concat nl "(see " refs " for more details)\n") "")
687 ;; ======================================================================
688 ;; this section queries the user for necessary information
690 (defun sc-query (&optional default)
691 "Query for an attribution string with the optional DEFAULT choice.
692 Returns the string entered by the user, if non-empty and non-nil, or
693 DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution
695 (if (not default) (setq default sc-default-attribution))
696 (let* ((prompt (concat "Enter attribution string: (default " default ") "))
697 (query (read-string prompt)))
704 "Confirm the preferred attribution with the user."
705 (if (or sc-confirm-always-p
706 sc-force-confirmation-p)
707 (aput 'sc-gal-attributions
708 (let* ((default (aheadsym sc-gal-attributions))
710 (prompt (concat "Complete "
712 ((eq sc-cite-context 'citing) "cite")
713 ((eq sc-cite-context 'reciting) "recite")
715 " attribution string: (default "
717 (minibuffer-local-completion-map
718 (copy-keymap minibuffer-local-completion-map)))
719 (define-key minibuffer-local-completion-map "\C-g"
720 '(lambda () (interactive) (beep) (throw 'select-abort nil)))
721 (setq chosen (completing-read prompt sc-gal-attributions))
728 ;; ======================================================================
729 ;; this section contains primitive functions used in the email address
730 ;; parsing schemes. they extract name fields from various parts of
731 ;; the "from:" field.
733 (defun sc-style1-addresses (from-string &optional delim)
734 "Extract the author's email terminus from email address FROM-STRING.
735 Match addresses of the style \"name%[stuff].\" when called with DELIM
736 of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when
737 called with DELIM \"@\". If DELIM is nil or not provided, matches
738 addresses of the style \"name\"."
739 (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0)
740 (substring from-string
742 (- (match-end 0) (if (null delim) 0 1)))))
744 (defun sc-style2-addresses (from-string)
745 "Extract the author's email terminus from email address FROM-STRING.
746 Match addresses of the style \"[stuff]![stuff]...!name[stuff].\""
747 (let ((eos (length from-string))
748 (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)"
750 (mend (match-end 0)))
752 (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1)))
755 (defun sc-get-address (from-string author)
756 "Get the full email address path from FROM-STRING.
757 AUTHOR is the author's name (which is removed from the address)."
758 (let ((eos (length from-string)))
759 (if (string-match (concat "\\(^\\|^\"\\)" author
760 "\\(\\s +\\|\"\\s +\\)") from-string 0)
761 (let ((addr (substring from-string (match-end 0) eos)))
762 (if (and (= (aref addr 0) ?<)
763 (= (aref addr (1- (length addr))) ?>))
764 (substring addr 1 (1- (length addr)))
766 (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0)
767 (substring from-string (match-beginning 0) (match-end 0))
771 (defun sc-get-emailname (from-string)
772 "Get the email terminus name from FROM-STRING."
774 ((sc-style1-addresses from-string "%"))
775 ((sc-style1-addresses from-string "@"))
776 ((sc-style2-addresses from-string))
777 ((sc-style1-addresses from-string nil))
778 (t (substring from-string 0 10))))
781 ;; ======================================================================
782 ;; this section contains functions that will extract a list of names
783 ;; from the name field string.
785 (defun sc-spacify-name-chars (name)
786 (let ((len (length name))
789 (if (memq (aref name s) sc-spacify-name-chars)
794 (defun sc-name-substring (string start end extend)
795 "Extract the specified substring of STRING from START to END.
796 EXTEND is the number of characters on each side to extend the
799 (let ((sos (+ start extend))
800 (eos (- end extend)))
801 (substring string sos
802 (or (string-match sc-titlecue-regexp string sos) eos)
805 (defun sc-extract-namestring (from-string)
806 "Extract the name string from FROM-STRING.
807 This should be the author's full name minus an optional title."
808 (let ((pstart (string-match "(.*)" from-string 0))
810 (qstart (string-match "\".*\"" from-string 0))
812 (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0))
813 (bend (match-end 0)))
814 (sc-spacify-name-chars
816 ((sc-name-substring from-string pstart pend 1))
817 ((sc-name-substring from-string qstart qend 1))
818 ((sc-name-substring from-string bstart bend 0))
821 (defun sc-chop-namestring (namestring)
822 "Convert NAMESTRING to a list of names.
824 example: (sc-namestring-to-list \"John Xavier Doe\")
825 => (\"John\" \"Xavier\" \"Doe\")"
826 (if (not (string= namestring ""))
827 (append (list (sc-string-car namestring))
828 (sc-chop-namestring (sc-string-cdr namestring)))))
830 (defun sc-strip-initials (namelist)
831 "Extract the author's initials from the NAMELIST."
834 (concat (if (string= (car namelist) "")
836 (substring (car namelist) 0 1))
837 (sc-strip-initials (cdr namelist)))))
840 ;; ======================================================================
841 ;; this section handles selection of the attribution and citation strings
843 (defun sc-populate-alists (from-string)
844 "Put important and useful information in the alists using FROM-STRING.
845 Return the list of name symbols."
846 (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string)))
847 (revnames (reverse (cdr namelist)))
848 (midnames (reverse (cdr revnames)))
849 (firstname (car namelist))
850 (midnames (reverse (cdr revnames)))
851 (lastname (car revnames))
852 (initials (sc-strip-initials namelist))
853 (emailname (sc-get-emailname from-string))
855 (symlist (list 'emailname 'initials 'firstname 'lastname)))
857 ;; put basic information
858 (aput 'sc-gal-attributions 'firstname firstname)
859 (aput 'sc-gal-attributions 'lastname lastname)
860 (aput 'sc-gal-attributions 'emailname emailname)
861 (aput 'sc-gal-attributions 'initials initials)
863 (aput 'sc-gal-information "sc-firstname" firstname)
864 (aput 'sc-gal-information "sc-lastname" lastname)
865 (aput 'sc-gal-information "sc-emailname" emailname)
866 (aput 'sc-gal-information "sc-initials" initials)
868 ;; put middle names and build sc-author entry
869 (let ((author (concat firstname " ")))
871 (let ((name (car midnames))
872 (next (cdr midnames))
873 (symbol (intern (format "middlename%d" n)))
874 (string (format "sc-middlename-%d" n)))
875 ;; first put new middlename
876 (aput 'sc-gal-attributions symbol name)
877 (aput 'sc-gal-information string name)
879 (nconc symlist (list symbol))
881 ;; now build author name
882 (setq author (concat author name " "))
887 (setq author (concat author lastname))
889 ;; put author name and email address
890 (aput 'sc-gal-information "sc-author" author)
891 (aput 'sc-gal-information "sc-from-address"
892 (sc-get-address from-string author))
893 (aput 'sc-gal-information "sc-reply-address"
894 (sc-get-address (sc-field "reply-to") author))
899 (defun sc-sort-attribution-alist ()
900 "Put preferred attribution at head of attributions alist."
901 (asort 'sc-gal-attributions sc-preferred-attribution)
903 ;; use backup scheme if preference is not legal
904 (if (or (null sc-preferred-attribution)
905 (anot-head-p sc-gal-attributions sc-preferred-attribution)
906 (let ((prefval (aget sc-gal-attributions
907 sc-preferred-attribution)))
909 (string= prefval ""))))
910 ;; no legal attribution
911 (if sc-use-only-preference-p
912 (aput 'sc-gal-attributions 'sc-user-query
913 (sc-query sc-default-attribution))
914 ;; else use secondary scheme
915 (asort 'sc-gal-attributions 'firstname))))
917 (defun sc-build-attribution-alist (from-string)
918 "Extract attributions from FROM-STRING, applying preferences."
919 (let ((symlist (sc-populate-alists from-string))
920 (headval (progn (sc-sort-attribution-alist)
921 (aget sc-gal-attributions
922 (aheadsym sc-gal-attributions) t))))
924 ;; for each element in the symlist, remove the corresponding
925 ;; key-value pair in the alist, then insert just the value.
927 (let ((value (aget sc-gal-attributions (car symlist) t))
928 (next (cdr symlist)))
929 (if (not (or (null value)
931 (aput 'sc-gal-attributions value))
932 (adelete 'sc-gal-attributions (car symlist))
933 (setq symlist next)))
935 ;; add nicknames to the completion list
936 (let ((gal sc-gal-attributions))
938 (let ((nns sc-nicknames-alist)
939 (galname (car (car gal))))
941 (if (string= galname (car (car nns)))
942 (aput 'sc-gal-attributions (car (cdr (car nns)))))
943 (setq nns (cdr nns)))
944 (setq gal (cdr gal)))))
946 ;; now reinsert the head (preferred) attribution unless it is nil,
947 ;; this effectively just moves the head value to the front of the
950 (aput 'sc-gal-attributions headval))
952 ;; check to be sure alist is not nil
953 (if (null sc-gal-attributions)
954 (aput 'sc-gal-attributions sc-default-attribution))))
957 "Select an attribution and create a citation string."
959 (sc-nested-citation-p
961 ((null (aget sc-gal-information "from" t))
962 (aput 'sc-gal-information "sc-author" sc-default-author-name)
963 (sc-update-gal (sc-query sc-default-attribution)))
964 ((null sc-gal-attributions)
965 (sc-build-attribution-alist (aget sc-gal-information "from" t))
967 (sc-update-gal (aheadsym sc-gal-attributions)))
970 (sc-update-gal (aheadsym sc-gal-attributions))))
974 ;; ======================================================================
975 ;; region citing and unciting
977 (defun sc-cite-region (start end)
978 "Cite a region delineated by START and END."
980 ;; set real end-of-region
984 ;; goto real beginning-of-region
987 (let ((fstart (point))
989 (while (< (point) (sc-mark))
990 ;; remove leading whitespace if desired
991 (and sc-fixup-whitespace-p
993 ;; if end of line then perhaps autofill
996 (not sc-auto-fill-region-p)
997 (and sc-auto-fill-query-each-paragraph-p
998 (not (y-or-n-p "Fill this paragraph? ")))
999 (save-excursion (set-mark fend)
1000 (goto-char (/ (+ fstart fend 1) 2))
1001 (run-hooks 'sc-fill-paragraph-hook)))
1002 (setq fstart (point)
1004 ;; not end of line so perhaps cite it
1005 ((not (looking-at sc-cite-regexp))
1006 (insert (aget sc-gal-information "sc-citation")))
1007 (sc-nested-citation-p
1008 (insert (aget sc-gal-information "sc-nested-citation"))))
1011 (and sc-auto-fill-query-each-paragraph-p
1015 (defun sc-uncite-region (start end cite-regexp)
1016 "Uncite a previously cited region delineated by START and END.
1017 CITE-REGEXP describes how a cited line of texts starts. Unciting also
1018 auto-fills paragraph if sc-auto-fill-region-p is non-nil."
1023 (let ((fstart (point))
1025 (while (< (point) (sc-mark))
1026 ;; if end of line, then perhaps autofill
1029 (not sc-auto-fill-region-p)
1030 (and sc-auto-fill-query-each-paragraph-p
1031 (not (y-or-n-p "Fill this paragraph? ")))
1032 (save-excursion (set-mark fend)
1033 (goto-char (/ (+ fstart fend 1) 2))
1034 (run-hooks 'sc-fill-paragraph-hook)))
1035 (setq fstart (point)
1037 ;; not end of line so perhaps uncite it
1038 ((looking-at cite-regexp)
1041 (narrow-to-region (sc-linepos 'bol) (sc-linepos))
1043 (delete-region (point-min)
1044 (progn (re-search-forward cite-regexp
1049 (forward-line 1)))))
1052 ;; ======================================================================
1053 ;; this section contains paragraph filling support
1055 (defun sc-guess-fill-prefix (&optional literalp)
1056 "Guess the fill prefix used on the current line.
1057 Use various heuristics to find the fill prefix. Search begins on first
1058 non-blank line after point.
1060 1) If fill-prefix is already bound to the empty string, return
1063 2) If fill-prefix is already bound, but not to the empty
1064 string, return the value of fill-prefix.
1066 3) If the current line starts with the last chosen citation
1067 string, then that string is returned.
1069 4) If the current line starts with a string matching the regular
1070 expression sc-cite-regexp, return the match. Note that if
1071 optional LITERALP is provided and non-nil, then the *string*
1072 that matches the regexp is return. Otherwise, if LITERALP is
1073 not provided or is nil, the *regexp* sc-cite-regexp is
1076 5) If the current line starts with any number of characters,
1077 followed by the sc-citation-delimiter and then white space,
1078 that match is returned. See comment #4 above for handling of
1081 6) Nil is returned."
1083 ;; scan for first non-blank line in the region
1085 (skip-chars-forward "\n\t ")
1087 (let ((citation (aget sc-gal-information "sc-citation"))
1089 (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +")))
1091 ((string= fill-prefix "") nil) ;; heuristic #1
1092 (fill-prefix) ;; heuristic #2
1093 ((looking-at (regexp-quote citation)) citation) ;; heuristic #3
1094 ((looking-at sc-cite-regexp) ;; heuristic #4
1098 (progn (re-search-forward (concat sc-cite-regexp "\\s *")
1102 ((looking-at generic-citation) ;; heuristic #5
1106 (progn (re-search-forward generic-citation) (point)))
1108 (t nil))))) ;; heuristic #6
1110 (defun sc-consistent-cite-p (prefix)
1111 "Check current paragraph for consistent citation.
1112 Scans to paragraph delineated by (forward|backward)-paragraph to see
1113 if all lines start with PREFIX. Returns t if entire paragraph is
1114 consistently cited, nil otherwise."
1116 (let ((end (progn (forward-paragraph)
1121 (start (progn (backward-paragraph)
1129 (while (and (< (point) end)
1131 (setq badline (looking-at prefix))
1135 (defun sc-fill-start (fill-prefix)
1136 "Find buffer position of start of region which begins with FILL-PREFIX.
1137 Restrict scan to current paragraph."
1140 (top (save-excursion
1141 (backward-paragraph)
1146 (while (and (not badline)
1149 (setq badline (not (looking-at fill-prefix)))))
1153 (defun sc-fill-end (fill-prefix)
1154 "Find the buffer position of end of region which begins with FILL-PREFIX.
1155 Restrict scan to current paragraph."
1158 (bot (save-excursion
1164 (while (and (not badline)
1167 (setq badline (not (looking-at fill-prefix)))
1172 (defun sc-fill-paragraph ()
1173 "Supercite's paragraph fill function.
1174 Fill the paragraph containing or following point. Use
1175 sc-guess-fill-prefix to find the fill-prefix for the paragraph.
1177 If the paragraph is inconsistently cited (mixed fill-prefix), then the
1178 user is queried to restrict the the fill to only those lines around
1179 point which begin with the fill prefix.
1181 The variable sc-fill-arg is passed to fill-paragraph and
1182 fill-region-as-paragraph which controls justification of the
1183 paragraph. sc-fill-arg is set by sc-fill-paragraph-manually."
1186 (fill-prefix (sc-guess-fill-prefix t)))
1189 (fill-paragraph sc-fill-arg))
1190 ((sc-consistent-cite-p fill-prefix)
1191 (fill-paragraph sc-fill-arg))
1192 ((y-or-n-p "Inconsistent citation found. Restrict? ")
1194 (fill-region-as-paragraph (progn (goto-char pnt)
1195 (sc-fill-start fill-prefix))
1196 (progn (goto-char pnt)
1197 (sc-fill-end fill-prefix))
1202 (setq fill-prefix (aget sc-gal-information "sc-citation"))
1203 (fill-paragraph sc-fill-arg)))))))
1206 ;; ======================================================================
1207 ;; the following functions are the top level, interactive commands that
1208 ;; can be bound to key strokes
1210 (defun sc-insert-reference (arg)
1211 "Insert, at point, a reference header in the body of the reply.
1212 Numeric ARG indicates which header style from sc-rewrite-header-list
1213 to use when rewriting the header. No supplied ARG indicates use of
1214 sc-preferred-header-style.
1216 With just \\[universal-argument], electric reference insert mode is
1217 entered, regardless of the value of sc-electric-references-p. See
1218 sc-electric-mode for more information."
1222 (let ((pref (cond ((sc-valid-index-p arg) arg)
1223 ((sc-valid-index-p sc-preferred-header-style)
1224 sc-preferred-header-style)
1226 (if sc-electric-references-p (sc-electric-mode pref)
1228 (eval (nth pref sc-rewrite-header-list))
1231 "Symbol's function definition is void: %s. (Header %d)."
1232 (symbol-name (car (cdr err)))
1236 (progn (message "Error evaluating rewrite header function %d."
1241 (defun sc-cite (arg)
1242 "Cite the region of text between point and mark.
1243 Numeric ARG, if supplied, is passed unaltered to sc-insert-reference."
1246 (error "Please designate a region to cite (i.e. set the mark)."))
1247 (catch 'select-abort
1248 (let ((sc-cite-context 'citing)
1249 (sc-force-confirmation-p (interactive-p)))
1252 (let ((xchange (if (> (sc-mark) (point)) nil
1253 (exchange-point-and-mark)
1255 (sc-insert-reference arg)
1256 (sc-cite-region (point) (sc-mark))
1257 ;; leave point on first cited line
1258 (while (and (< (point) (sc-mark))
1259 (not (looking-at (aget sc-gal-information
1260 (if sc-nested-citation-p
1261 "sc-nested-citation"
1265 (exchange-point-and-mark))
1269 "Uncite the region between point and mark."
1272 (error "Please designate a region to uncite (i.e. set the mark)."))
1274 (let ((xchange (if (> (sc-mark) (point)) nil
1275 (exchange-point-and-mark)
1277 (fp (or (sc-guess-fill-prefix)
1279 (sc-uncite-region (point) (sc-mark) fp)
1281 (exchange-point-and-mark))))
1284 "Recite the region by first unciting then citing the text."
1287 (error "Please designate a region to recite (i.e. set the mark)."))
1288 (catch 'select-abort
1289 (let ((sc-cite-context 'reciting)
1290 (sc-force-confirmation-p t))
1293 (let ((xchange (if (> (sc-mark) (point)) nil
1294 (exchange-point-and-mark)
1296 (fp (or (sc-guess-fill-prefix)
1298 (sc-uncite-region (point) (sc-mark) fp)
1299 (sc-cite-region (point) (sc-mark))
1301 (exchange-point-and-mark))
1304 (defun sc-insert-citation ()
1305 "Insert citation string at beginning of current line."
1309 (insert (aget sc-gal-information "sc-citation"))))
1311 (defun sc-open-line (arg)
1312 "Insert a newline and leave point before it.
1313 Also inserts the guessed prefix at the beginning of the new line. With
1314 numeric ARG, inserts that many new lines."
1317 (let ((start (point))
1318 (string (or (sc-guess-fill-prefix t)
1326 (setq arg (- arg 1))))))
1328 (defun sc-fill-paragraph-manually (arg)
1329 "Fill current cited paragraph.
1330 Really just runs the hook sc-fill-paragraph-hook, however it does set
1331 the global variable sc-fill-arg to the value of ARG. This is
1332 currently the only way to pass an argument to a hookified function."
1334 (setq sc-fill-arg arg)
1335 (run-hooks 'sc-fill-paragraph-hook))
1337 (defun sc-modify-information (arg)
1338 "Interactively modify information in the information alist.
1339 \\[universal-argument] if supplied, deletes the entry from the alist.
1340 You can add an entry by supplying a key instead of completing."
1342 (let* ((delete-p (consp arg))
1343 (action (if delete-p "delete" "modify"))
1344 (defaultkey (aheadsym sc-gal-information))
1345 (prompt (concat "Select information key to "
1346 action ": (default "
1348 (key (completing-read prompt sc-gal-information))
1350 (if (or (string= key "")
1352 (setq key defaultkey))
1353 (if delete-p (adelete 'sc-gal-information key)
1354 (let* ((oldval (aget sc-gal-information key t))
1355 (prompt (concat "Enter new value for key \""
1356 key "\" (default \"" oldval "\") "))
1357 (newval (read-input prompt)))
1358 (if (or (string= newval "")
1361 (aput 'sc-gal-information key newval)
1364 (defun sc-view-field (arg)
1365 "View field values in the information alist.
1366 This is essentially an interactive version of sc-field, and is similar
1367 to sc-modify-information, except that the field values can't be
1368 modified. With \\[universal-argument], if supplied, inserts the value
1369 into the current buffer as well."
1371 (let* ((defaultkey (aheadsym sc-gal-information))
1372 (prompt (concat "View information key: (default "
1374 (key (completing-read prompt sc-gal-information)))
1375 (if (or (string= key "")
1377 (setq key defaultkey))
1378 (let* ((val (aget sc-gal-information key t))
1379 (pval (if val (concat "\"" val "\"") "nil")))
1380 (message "value of key %s: %s" key pval)
1381 (if (and key (consp arg)) (insert val)))))
1383 (defun sc-glom-headers ()
1384 "Glom information from mail headers in region between point and mark.
1385 Any old information is lost, unless an error occurs."
1387 (let ((attr (copy-sequence sc-gal-attributions))
1388 (info (copy-sequence sc-gal-information)))
1389 (setq sc-gal-attributions nil
1390 sc-gal-information nil)
1391 (let ((start (region-beginning))
1393 (sc-force-confirmation-p t)
1394 (sc-cite-context nil))
1395 (sc-fetch-fields start end)
1396 (if (null sc-gal-information)
1398 (message "No mail headers found! Restoring old information.")
1399 (setq sc-gal-attributions attr
1400 sc-gal-information info))
1401 (sc-mail-yank-clear-headers start end)
1402 (if (not (catch 'select-abort
1405 (quit (beep) (throw 'select-abort nil)))
1407 (setq sc-gal-attributions attr
1408 sc-gal-information info))
1411 (defun sc-version (arg)
1412 "Show supercite version.
1413 Universal argument (\\[universal-argument]) ARG inserts version
1414 information in the current buffer instead of printing the message in
1418 (insert "Using Supercite version " sc-version-number)
1419 (message "Using Supercite version %s" sc-version-number)))
1422 ;; ======================================================================
1423 ;; leach onto current mode
1425 (defun sc-append-current-keymap ()
1426 "Append some useful key bindings to the current local key map.
1427 This searches sc-local-keymap for the keymap to install based on the
1428 major-mode of the current buffer."
1429 (let ((hook (car (cdr (assq major-mode sc-local-keymaps)))))
1432 (run-hooks 'sc-default-keymap))
1434 (setq hook (car (cdr (assq hook sc-local-keymaps))))
1437 (run-hooks 'hook))))
1438 (setq sc-leached-keymap (current-local-map)))
1440 (defun sc-snag-all-keybindings ()
1441 "Snag all keybindings in major-mode's current keymap."
1442 (let* ((curkeymap (current-local-map))
1443 (symregexp ".*sc-.*\n")
1444 (docstring (substitute-command-keys "\\{curkeymap}"))
1446 (maxend (length docstring))
1448 (while (and (< start maxend)
1449 (string-match symregexp docstring start))
1450 (setq spooge (concat spooge (substring docstring
1453 (setq start (match-end 0)))
1456 (defun sc-spoogify-docstring ()
1457 "Modifies (makes into spooge) the docstring for the current major mode.
1458 This will leach the keybinding descriptions for supercite onto the end
1459 of the current major mode's docstring. If major mode is preloaded,
1460 this function will first make a copy of the list associated with the
1461 mode, then modify this copy."
1462 (let* ((symfunc (symbol-function major-mode))
1463 (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc)))
1464 (doc-str (documentation major-mode)))
1466 ;; is a docstring even provided?
1467 ((not (stringp doc-str)))
1468 ;; have we already leached on?
1469 ((string-match "Supercite" doc-str))
1470 ;; lets build the new doc string
1472 (let* ((described (sc-snag-all-keybindings))
1475 The major mode for this buffer has been modified to include the
1476 Supercite 2.3 package for handling attributions and citations of
1477 original messages in email replies. For more information on this
1478 package, type \"\\[sc-describe]\".")
1480 (concat doc-str commonstr
1481 (if (not (string= described ""))
1482 (concat "\n\nThe following keys are bound "
1483 "to Supercite commands:\n\n"
1489 (setcar doc-cdr newdoc-str)
1491 ;; the major mode must be preloaded, make a copy first
1492 (setq symfunc (copy-sequence (symbol-function major-mode))
1493 doc-cdr (nthcdr 2 symfunc))
1494 (setcar doc-cdr newdoc-str)
1495 (fset major-mode symfunc))))
1496 ;; lemacs 19 byte-code.
1497 ;; Set function to a new byte-code vector with the
1498 ;; new documentation in the documentation slot (element 4).
1499 ;; We can't use aset because aset won't allow you to modify
1500 ;; a byte-code vector.
1501 ;; Include element 5 if the vector has one.
1504 (apply 'make-byte-code
1505 (aref symfunc 0) (aref symfunc 1)
1506 (aref symfunc 2) (aref symfunc 3)
1508 (if (> (length symfunc) 5)
1509 (list (aref symfunc 5)))))
1513 ;; ======================================================================
1514 ;; this section contains default hooks and hook support for execution
1517 (defun sc-cite-original ()
1518 "Hook version of sc-cite.
1519 This is callable from the various mail and news readers' reply
1520 function according to the agreed upon standard. See \\[sc-describe]
1521 for more details. Sc-cite-original does not do any yanking of the
1522 original message but it does require a few things:
1524 1) The reply buffer is the current buffer.
1526 2) The original message has been yanked and inserted into the
1529 3) Verbose mail headers from the original message have been
1530 inserted into the reply buffer directly before the text of the
1533 4) Point is at the beginning of the verbose headers.
1535 5) Mark is at the end of the body of text to be cited."
1536 (run-hooks 'sc-pre-hook)
1537 (setq sc-gal-attributions nil)
1538 (setq sc-gal-information nil)
1539 (let ((start (region-beginning))
1541 (sc-fetch-fields start end)
1542 (sc-mail-yank-clear-headers start end)
1543 (if (not sc-all-but-cite-p)
1544 (sc-cite sc-preferred-header-style))
1545 (sc-append-current-keymap)
1546 (sc-spoogify-docstring)
1547 (run-hooks 'sc-post-hook)))
1550 ;; ======================================================================
1551 ;; describe this package
1553 (defun sc-describe ()
1554 "Supercite version 2.3 is now described in a texinfo manual which
1555 makes the documentation available both for online perusal via emacs'
1556 info system, or for hard-copy printing using the TeX facility.
1558 To view the online document hit \\[info], then \"mSupercite <RET>\"."
1560 (describe-function 'sc-describe))
1562 ;; ======================================================================
1564 (run-hooks 'sc-load-hook)