*** empty log message ***
[emacs.git] / lisp / sc.el
blob03eade6cba25829d98702c89b3c67d5662aee8ca
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 should
7 ;; work with Rmail and GNUS as found in Emacs 19. It may also work with
8 ;; VM 4.40+ and MH-E 3.7.
10 ;; This package does not do any yanking of messages, but instead
11 ;; massages raw reply buffers set up by the reply/forward functions in
12 ;; the news/mail subsystems. Therefore, such useful operations as
13 ;; yanking and citing portions of the original article (instead of the
14 ;; whole article) are not within the ability or responsibility of
15 ;; supercite.
17 ;; ========== Disclaimer ==========
18 ;; This software is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY. No author or distributor, nor any
20 ;; author's past, present, or future employers accepts responsibility
21 ;; to anyone for the consequences of using it or for whether it serves
22 ;; any particular purpose or works at all, unless he says so in
23 ;; writing.
25 ;; Some of this software was written as part of the supercite author's
26 ;; official duty as an employee of the United States Government and is
27 ;; thus not subject to copyright. You are free to use that particular
28 ;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It
29 ;; would be nice, though if when you use any of this or other freely
30 ;; available code, you give due credit to the author.
32 ;; Other parts of this code were written by other people. Wherever
33 ;; possible, credit to that author, and the copy* notice supplied by
34 ;; the author are included with that code. The supercite author is no
35 ;; longer an employee of the U.S. Government so the GNU Public Licence
36 ;; should be considered in effect for all enhancements and bug fixes
37 ;; performed by the author.
39 ;; ========== Author (unless otherwise stated) ========================
40 ;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
41 ;; TELE: (301) 593-3330 1014 West Street
42 ;; INET: bwarsaw@cen.com Laurel, Md 20707
43 ;; UUCP: uunet!cen.com!bwarsaw
45 ;; Want to be on the Supercite mailing list?
47 ;; Send articles to:
48 ;; Internet: supercite@anthem.nlm.nih.gov
49 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite
50 ;;
51 ;; Send administrivia (additions/deletions to list, etc) to:
52 ;; Internet: supercite-request@anthem.nlm.nih.gov
53 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request
55 ;; ========== Credits and Thanks ==========
56 ;; This package was derived from the Superyank 1.11 package as posted
57 ;; to the net. Superyank 1.11 was inspired by code and ideas from
58 ;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved
59 ;; through the comments and suggestions of the supercite mailing list
60 ;; which consists of many authors and users of the various mail and
61 ;; news reading subsystems.
63 ;; Many folks on the supercite mailing list have contributed their
64 ;; help in debugging, making suggestions and supplying support code or
65 ;; bug fixes for the previous versions of supercite. I want to thank
66 ;; everyone who helped, especially (in no particular order):
68 ;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle
69 ;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van
70 ;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells.
72 ;; I don't mean to leave anyone out. All who have helped have been
73 ;; appreciated.
75 ;; ========== Getting Started ==========
76 ;; Here is a quick guide to getting started with supercite. The
77 ;; information contained here is mostly excerpted from the more
78 ;; detailed explanations given in the accompanying README file.
79 ;; Naturally, there are many customizations you can do to give your
80 ;; replies that personalized flair, but the instructions in this
81 ;; section should be sufficient for getting started.
83 ;; First, to connect supercite to any mail/news reading subsystem, put
84 ;; this in your .emacs file:
86 ;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents
87 ;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only
88 ;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents
90 ;; If supercite is not pre-loaded into your emacs session, you should
91 ;; add the following autoload:
93 ;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t)
95 ;; Finally, if you want to customize supercite, you should do it in a
96 ;; function called my-supercite-hook and:
98 ;; (setq sc-load-hook 'my-supercite-hook)
100 (require 'assoc)
103 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
104 ;; start of user defined variables
105 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
107 (defvar sc-nested-citation-p nil
108 "*Controls whether to use nested or non-nested citation style.
109 Non-nil uses nested citations, nil uses non-nested citations. Type
110 \\[sc-describe] for more information.")
112 (defvar sc-citation-leader " "
113 "*String comprising first part of a citation.")
115 (defvar sc-citation-delimiter ">"
116 "*String comprising third part of a citation.
117 This string is used in both nested and non-nested citations.")
119 (defvar sc-citation-separator " "
120 "*String comprising fourth and last part of a citation.")
122 (defvar sc-default-author-name "Anonymous"
123 "*String used when author's name cannot be determined.")
125 (defvar sc-default-attribution "Anon"
126 "*String used when author's attribution cannot be determined.")
128 ;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite
129 ;; mailing list:
130 ;; I use supercite in Nemacs-3.3.2. In order to handle citation using
131 ;; Kanji, [...set sc-cite-regexp to...]
132 ;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+"
134 (defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *"
135 "*Regular expression describing how a already cited line begins.
136 The regexp is only used at the beginning of a line, so it doesn't need
137 to start with a '^'.")
139 (defvar sc-titlecue-regexp "\\s +-+\\s +"
140 "*Regular expression describing the separator between names and titles.
141 Set to nil to treat entire field as a name.")
143 (defvar sc-spacify-name-chars '(?_ ?* ?+ ?=)
144 "*List of characters to convert to spaces if found in an author's name.")
146 (defvar sc-nicknames-alist
147 '(("Michael" "Mike")
148 ("Daniel" "Dan")
149 ("David" "Dave")
150 ("Jonathan" "John")
151 ("William" "Bill")
152 ("Elizabeth" "Beth")
153 ("Elizabeth" "Betsy")
154 ("Kathleen" "Kathy")
155 ("Smith" "Smitty"))
156 "*Association list of names and their common nicknames.
157 Entries are of the form (NAME NICKNAME), and NAMEs can have more than
158 one nickname. Nicknames will not be automatically used as an
159 attribution string, since I'm not sure this is really polite, but if a
160 name is glommed from the author name and presented in the attribution
161 string completion list, the matching nicknames will also be presented.
162 Set this variable to nil to defeat nickname expansions. Also note that
163 nicknames are not put in the supercite information alist.")
165 (defvar sc-confirm-always-p t
166 "*If non-nil, always confirm attribution string before citing text body.")
168 (defvar sc-preferred-attribution 'firstname
169 "*Specifies which part of the author's name becomes the attribution.
170 The value of this variable must be one of the following quoted symbols:
172 emailname -- email terminus name
173 initials -- initials of author
174 firstname -- first name of author
175 lastname -- last name of author
176 middlename1 -- first middle name of author
177 middlename2 -- second middle name of author
180 Middle name indexes can be any positive integer greater than 0, though
181 it is unlikely that many authors will supply more than one middle
182 name, if that many.")
184 (defvar sc-use-only-preference-p nil
185 "*Controls what happens when the preferred attribution cannot be found.
186 If non-nil, then sc-default-attribution will be used. If nil, then
187 some secondary scheme will be employed to find a suitable attribution
188 string.")
190 (defvar sc-downcase-p nil
191 "*Non-nil means downcase the attribution and citation strings.")
193 (defvar sc-rewrite-header-list
194 '((sc-no-header)
195 (sc-header-on-said)
196 (sc-header-inarticle-writes)
197 (sc-header-regarding-adds)
198 (sc-header-attributed-writes)
199 (sc-header-verbose)
200 (sc-no-blank-line-or-header)
202 "*List of reference header rewrite functions.
203 The variable sc-preferred-header-style controls which function in this
204 list is chosen for automatic reference header insertions. Electric
205 reference mode will cycle through this list of functions. For more
206 information, type \\[sc-describe].")
208 (defvar sc-preferred-header-style 1
209 "*Index into sc-rewrite-header-list specifying preferred header style.
210 Index zero accesses the first function in the list.")
212 (defvar sc-electric-references-p t
213 "*Use electric references if non-nil.")
215 (defvar sc-electric-circular-p t
216 "*Treat electric references as circular if non-nil.")
218 (defvar sc-mail-fields-list
219 '("date" "message-id" "subject" "newsgroups" "references"
220 "from" "return-path" "path" "reply-to" "organization"
221 "reply" )
222 "*List of mail header whose values will be saved by supercite.
223 These values can be used in header rewrite functions by accessing them
224 with the sc-field function. Mail headers in this list are case
225 insensitive and do not require a trailing colon.")
227 (defvar sc-mumble-string ""
228 "*Value returned by sc-field if chosen field cannot be found.")
230 (defvar sc-nuke-mail-headers-p t
231 "*Nuke or don't nuke mail headers.
232 If non-nil, nuke mail headers after gleaning useful information from
233 them.")
235 (defvar sc-reference-tag-string ">>>>> "
236 "*String used at the beginning of built-in reference headers.")
238 (defvar sc-fill-paragraph-hook 'sc-fill-paragraph
239 "*Hook for filling a paragraph.
240 This hook gets executed when you fill a paragraph either manually or
241 automagically. It expects point to be within the extent of the
242 paragraph that is going to be filled. This hook allows you to use a
243 different paragraph filling package than the one supplied with
244 supercite.")
246 (defvar sc-auto-fill-region-p nil
247 "*If non-nil, automatically fill each paragraph after it has been cited.")
249 (defvar sc-auto-fill-query-each-paragraph-p nil
250 "*If non-nil, query before filling each paragraph.
251 No querying and no filling will be performed if sc-auto-fill-region-p
252 is set to nil.")
254 (defvar sc-fixup-whitespace-p nil
255 "*If non-nil, delete all leading white space before citing.")
257 (defvar sc-all-but-cite-p nil
258 "*If non-nil, sc-cite-original does everything but cite the text.
259 This is useful for manually citing large messages, or portions of
260 large messages. When non-nil, sc-cite-original will still set up all
261 necessary variables and databases, but will skip the citing routine
262 which modify the reply buffer's text.")
264 (defvar sc-load-hook nil
265 "*User definable hook.
266 Runs after supercite is loaded. Set your customizations here.")
268 (defvar sc-pre-hook nil
269 "*User definable hook.
270 Runs before sc-cite-original executes.")
272 (defvar sc-post-hook nil
273 "*User definable hook.
274 Runs after sc-cite-original executes.")
276 (defvar sc-header-nuke-list
277 '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied"
278 "organization" "keywords" "distribution" "xref" "references" "expires"
279 "approved" "summary" "precedence" "subject" "newsgroup[s]?"
280 "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to"
281 "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]"
282 "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date"
283 "\\(mail-\\)?from")
284 "*List of mail headers to remove from body of reply.")
288 ;; ======================================================================
289 ;; keymaps
291 (defvar sc-default-keymap
292 '(lambda ()
293 (local-set-key "\C-c\C-r" 'sc-insert-reference)
294 (local-set-key "\C-c\C-t" 'sc-cite)
295 (local-set-key "\C-c\C-a" 'sc-recite)
296 (local-set-key "\C-c\C-u" 'sc-uncite)
297 (local-set-key "\C-c\C-i" 'sc-insert-citation)
298 (local-set-key "\C-c\C-o" 'sc-open-line)
299 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
300 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
301 (local-set-key "\C-c\C-m" 'sc-modify-information)
302 (local-set-key "\C-cf" 'sc-view-field)
303 (local-set-key "\C-cg" 'sc-glom-headers)
304 (local-set-key "\C-c\C-v" 'sc-version)
305 (local-set-key "\C-c?" 'sc-describe)
307 "*Default keymap if major-mode can't be found in `sc-local-keymaps'.")
309 (defvar sc-local-keymaps
310 '((mail-mode
311 (lambda ()
312 (local-set-key "\C-c\C-r" 'sc-insert-reference)
313 (local-set-key "\C-c\C-t" 'sc-cite)
314 (local-set-key "\C-c\C-a" 'sc-recite)
315 (local-set-key "\C-c\C-u" 'sc-uncite)
316 (local-set-key "\C-c\C-i" 'sc-insert-citation)
317 (local-set-key "\C-c\C-o" 'sc-open-line)
318 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
319 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
320 (local-set-key "\C-c\C-m" 'sc-modify-information)
321 (local-set-key "\C-cf" 'sc-view-field)
322 (local-set-key "\C-cg" 'sc-glom-headers)
323 (local-set-key "\C-c\C-v" 'sc-version)
324 (local-set-key "\C-c?" 'sc-describe)
326 (mh-letter-mode
327 (lambda ()
328 (local-set-key "\C-c\C-r" 'sc-insert-reference)
329 (local-set-key "\C-c\C-t" 'sc-cite)
330 (local-set-key "\C-c\C-a" 'sc-recite)
331 (local-set-key "\C-c\C-u" 'sc-uncite)
332 (local-set-key "\C-ci" 'sc-insert-citation)
333 (local-set-key "\C-c\C-o" 'sc-open-line)
334 (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
335 (local-set-key "\C-c\C-m" 'sc-modify-information)
336 (local-set-key "\C-cf" 'sc-view-field)
337 (local-set-key "\C-cg" 'sc-glom-headers)
338 (local-set-key "\C-c\C-v" 'sc-version)
339 (local-set-key "\C-c?" 'sc-describe)
341 (news-reply-mode mail-mode)
342 (vm-mail-mode mail-mode)
343 (e-reply-mode mail-mode)
344 (n-reply-mode mail-mode)
346 "*List of keymaps to use with the associated major-mode.")
348 (defvar sc-electric-mode-map nil
349 "*Keymap for sc-electric-mode.")
351 (if sc-electric-mode-map
353 (setq sc-electric-mode-map (make-sparse-keymap))
354 (define-key sc-electric-mode-map "p" 'sc-eref-prev)
355 (define-key sc-electric-mode-map "n" 'sc-eref-next)
356 (define-key sc-electric-mode-map "s" 'sc-eref-setn)
357 (define-key sc-electric-mode-map "j" 'sc-eref-jump)
358 (define-key sc-electric-mode-map "x" 'sc-eref-abort)
359 (define-key sc-electric-mode-map "\r" 'sc-eref-exit)
360 (define-key sc-electric-mode-map "\n" 'sc-eref-exit)
361 (define-key sc-electric-mode-map "q" 'sc-eref-exit)
362 (define-key sc-electric-mode-map "g" 'sc-eref-goto)
365 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
366 ;; end of user defined variables
367 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
370 ;; ======================================================================
371 ;; global variables, not user accessible
373 (defconst sc-version-number "2.3"
374 "Supercite's version number.")
376 ;; when rnewspost.el patch is installed (or function is overloaded)
377 ;; this should be nil since supercite now does this itself.
378 (setq news-reply-header-hook nil)
380 ;; autoload for sc-electric-mode
381 (autoload 'sc-electric-mode "sc-elec"
382 "Quasi-major mode for viewing supercite reference headers." nil)
384 ;; global alists (gals), misc variables. make new bytecompiler happy
385 (defvar sc-gal-information nil
386 "Internal global alist variable containing information.")
387 (defvar sc-gal-attributions nil
388 "Internal global alist variable containing attributions.")
389 (defvar sc-fill-arg nil
390 "Internal fill argument holder.")
391 (defvar sc-cite-context nil
392 "Internal citation context holder.")
393 (defvar sc-force-confirmation-p nil
394 "Internal variable.")
396 (make-variable-buffer-local 'sc-gal-attributions)
397 (make-variable-buffer-local 'sc-gal-information)
398 (make-variable-buffer-local 'sc-leached-keymap)
399 (make-variable-buffer-local 'sc-fill-arg)
400 (make-variable-buffer-local 'sc-cite-context)
402 (setq-default sc-gal-attributions nil)
403 (setq-default sc-gal-information nil)
404 (setq-default sc-leached-keymap (current-local-map))
405 (setq-default sc-fill-arg nil)
406 (setq-default sc-cite-context nil)
410 ;; ======================================================================
411 ;; miscellaneous support functions
413 (defun sc-mark ()
414 "Mark compatibility between emacs v18 and v19."
415 (let ((zmacs-regions nil))
416 (marker-position (mark-marker))))
418 (defun sc-update-gal (attribution)
419 "Update the information alist.
420 Add ATTRIBUTION and compose the nested and non-nested citation
421 strings."
422 (let ((attrib (if sc-downcase-p (downcase attribution) attribution)))
423 (aput 'sc-gal-information "sc-attribution" attrib)
424 (aput 'sc-gal-information "sc-nested-citation"
425 (concat attrib sc-citation-delimiter))
426 (aput 'sc-gal-information "sc-citation"
427 (concat sc-citation-leader
428 attrib
429 sc-citation-delimiter
430 sc-citation-separator))))
432 (defun sc-valid-index-p (index)
433 "Returns t if INDEX is a valid index into sc-rewrite-header-list."
434 (let ((last (1- (length sc-rewrite-header-list))))
435 (and (natnump index) ;; a number, and greater than or equal to zero
436 (<= index last) ;; less than or equal to the last index
439 (defun sc-string-car (namestring)
440 "Return the string-equivalent \"car\" of NAMESTRING.
442 example: (sc-string-car \"John Xavier Doe\")
443 => \"John\""
444 (substring namestring
445 (progn (string-match "\\s *" namestring) (match-end 0))
446 (progn (string-match "\\s *\\S +" namestring) (match-end 0))))
448 (defun sc-string-cdr (namestring)
449 "Return the string-equivalent \"cdr\" of NAMESTRING.
451 example: (sc-string-cdr \"John Xavier Doe\")
452 => \"Xavier Doe\""
453 (substring namestring
454 (progn (string-match "\\s *\\S +\\s *" namestring)
455 (match-end 0))))
457 (defun sc-linepos (&optional position col-p)
458 "Return the character position at various line positions.
459 Optional POSITION can be one of the following symbols:
460 bol == beginning of line
461 boi == beginning of indentation
462 eol == end of line [default]
464 Optional COL-P non-nil returns current-column instead of character position."
465 (let ((tpnt (point))
466 rval)
467 (cond
468 ((eq position 'bol) (beginning-of-line))
469 ((eq position 'boi) (back-to-indentation))
470 (t (end-of-line)))
471 (setq rval (if col-p (current-column) (point)))
472 (goto-char tpnt)
473 rval))
476 ;; ======================================================================
477 ;; this section snarfs mail fields and places them in the info alist
479 (defun sc-build-header-zap-regexp ()
480 "Return a regexp for sc-mail-yank-clear-headers."
481 (let ((headers sc-header-nuke-list)
482 (regexp nil))
483 (while headers
484 (setq regexp (concat regexp
485 "^" (car headers) ":"
486 (if (cdr headers) "\\|" nil)))
487 (setq headers (cdr headers)))
488 regexp))
490 (defun sc-mail-yank-clear-headers (start end)
491 "Nuke mail headers between START and END."
492 (if (and sc-nuke-mail-headers-p sc-header-nuke-list)
493 (let ((regexp (sc-build-header-zap-regexp)))
494 (save-excursion
495 (goto-char start)
496 (if (search-forward "\n\n" end t)
497 (save-restriction
498 (narrow-to-region start (point))
499 (goto-char start)
500 (while (let ((case-fold-search t))
501 (re-search-forward regexp nil t))
502 (beginning-of-line)
503 (delete-region (point)
504 (progn (re-search-forward "\n[^ \t]")
505 (forward-char -1)
506 (point)))
508 ))))
510 (defun sc-mail-fetch-field (field)
511 "Return the value of the header field FIELD.
512 The buffer is expected to be narrowed to just the headers of the
513 message."
514 (save-excursion
515 (goto-char (point-min))
516 (let ((case-fold-search t)
517 (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*")))
518 (goto-char (point-min))
519 (if (re-search-forward name nil t)
520 (let ((opoint (point)))
521 (while (progn (forward-line 1)
522 (looking-at "[ \t]")))
523 (buffer-substring opoint (1- (point))))))))
525 (defun sc-fetch-fields (start end)
526 "Fetch the mail fields in the region from START to END.
527 These fields can be accessed in header rewrite functions with sc-field."
528 (save-excursion
529 (save-restriction
530 (narrow-to-region start end)
531 (goto-char start)
532 (let ((fields sc-mail-fields-list))
533 (while fields
534 (let ((value (sc-mail-fetch-field (car fields)))
535 (next (cdr fields)))
536 (and value
537 (aput 'sc-gal-information (car fields) value))
538 (setq fields next)))
539 (if (sc-mail-fetch-field "from")
540 (aput 'sc-gal-information "from" (sc-mail-fetch-field "from")))))))
542 (defun sc-field (field)
543 "Return the alist information associated with the FIELD.
544 If FIELD is not a valid key, return sc-mumble-string."
545 (or (aget sc-gal-information field) sc-mumble-string))
548 ;; ======================================================================
549 ;; built-in reference header rewrite functions
551 (defun sc-no-header ()
552 "Does nothing. Use this instead of nil to get a blank header."
555 (defun sc-no-blank-line-or-header()
556 "Similar to sc-no-header except it removes the preceding blank line."
557 (if (not (bobp))
558 (if (and (eolp)
559 (progn (forward-line -1)
560 (or (looking-at mail-header-separator)
561 (and (eq major-mode 'mh-letter-mode)
562 (mh-in-header-p)))))
563 (progn (forward-line)
564 (let ((kill-lines-magic t)) (kill-line))))))
566 (defun sc-header-on-said ()
567 "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be
568 found, in which case nothing is inserted; or 2. the \"date\" field is
569 missing in which case only the from part is printed."
570 (let* ((sc-mumble-string "")
571 (whofrom (sc-field "from"))
572 (when (sc-field "date")))
573 (if (not (string= whofrom ""))
574 (insert sc-reference-tag-string
575 (if (not (string= when ""))
576 (concat "On " when ", ") "")
577 whofrom " said:\n"))))
579 (defun sc-header-inarticle-writes ()
580 "\"In article <message-id>, <from> writes:\"
581 Treats \"message-id\" and \"from\" fields similar to sc-header-on-said."
582 (let* ((sc-mumble-string "")
583 (whofrom (sc-field "from"))
584 (msgid (sc-field "message-id")))
585 (if (not (string= whofrom ""))
586 (insert sc-reference-tag-string
587 (if (not (string= msgid ""))
588 (concat "In article " msgid ", ") "")
589 whofrom " writes:\n"))))
591 (defun sc-header-regarding-adds ()
592 "\"Regarding <subject>; <from> adds:\"
593 Treats \"subject\" and \"from\" fields similar to sc-header-on-said."
594 (let* ((sc-mumble-string "")
595 (whofrom (sc-field "from"))
596 (subj (sc-field "subject")))
597 (if (not (string= whofrom ""))
598 (insert sc-reference-tag-string
599 (if (not (string= subj ""))
600 (concat "Regarding " subj "; ") "")
601 whofrom " adds:\n"))))
603 (defun sc-header-attributed-writes ()
604 "\"<sc-attribution>\" == <sc-author> <address> writes:
605 Treats these fields in a similar manner to sc-header-on-said."
606 (let* ((sc-mumble-string "")
607 (whofrom (sc-field "from"))
608 (reply (sc-field "sc-reply-address"))
609 (from (sc-field "sc-from-address"))
610 (attr (sc-field "sc-attribution"))
611 (auth (sc-field "sc-author")))
612 (if (not (string= whofrom ""))
613 (insert sc-reference-tag-string
614 (if (not (string= attr ""))
615 (concat "\"" attr "\" == " ) "")
616 (if (not (string= auth ""))
617 (concat auth " ") "")
618 (if (not (string= reply ""))
619 (concat "<" reply ">")
620 (if (not (string= from ""))
621 (concat "<" from ">") ""))
622 " writes:\n"))))
624 (defun sc-header-verbose ()
625 "Very verbose, some say gross."
626 (let* ((sc-mumble-string "")
627 (whofrom (sc-field "from"))
628 (reply (sc-field "sc-reply-address"))
629 (from (sc-field "sc-from-address"))
630 (author (sc-field "sc-author"))
631 (date (sc-field "date"))
632 (org (sc-field "organization"))
633 (msgid (sc-field "message-id"))
634 (ngrps (sc-field "newsgroups"))
635 (subj (sc-field "subject"))
636 (refs (sc-field "references"))
637 (cite (sc-field "sc-citation"))
638 (nl sc-reference-tag-string))
639 (if (not (string= whofrom ""))
640 (insert (if (not (string= date ""))
641 (concat nl "On " date ",\n") "")
642 (concat nl (if (not (string= author ""))
643 author
644 whofrom) "\n")
645 (if (not (string= org ""))
646 (concat nl "from the organization of " org "\n") "")
647 (if (not (string= reply ""))
648 (concat nl "who can be reached at: " reply "\n")
649 (if (not (string= from ""))
650 (concat nl "who can be reached at: " from "\n") ""))
651 (if (not (string= cite ""))
652 (concat nl "(whose comments are cited below with \""
653 cite "\"),\n") "")
654 (if (not (string= msgid ""))
655 (concat nl "had this to say in article " msgid "\n") "")
656 (if (not (string= ngrps ""))
657 (concat nl "in newsgroups " ngrps "\n") "")
658 (if (not (string= subj ""))
659 (concat nl "concerning the subject of " subj "\n") "")
660 (if (not (string= refs ""))
661 (concat nl "(see " refs " for more details)\n") "")
662 ))))
665 ;; ======================================================================
666 ;; this section queries the user for necessary information
668 (defun sc-query (&optional default)
669 "Query for an attribution string with the optional DEFAULT choice.
670 Returns the string entered by the user, if non-empty and non-nil, or
671 DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution
672 is used."
673 (if (not default) (setq default sc-default-attribution))
674 (let* ((prompt (concat "Enter attribution string: (default " default ") "))
675 (query (read-string prompt)))
676 (if (or (null query)
677 (string= query ""))
678 default
679 query)))
681 (defun sc-confirm ()
682 "Confirm the preferred attribution with the user."
683 (if (or sc-confirm-always-p
684 sc-force-confirmation-p)
685 (aput 'sc-gal-attributions
686 (let* ((default (aheadsym sc-gal-attributions))
687 chosen
688 (prompt (concat "Complete "
689 (cond
690 ((eq sc-cite-context 'citing) "cite")
691 ((eq sc-cite-context 'reciting) "recite")
692 (t ""))
693 " attribution string: (default "
694 default ") "))
695 (minibuffer-local-completion-map
696 (copy-keymap minibuffer-local-completion-map)))
697 (define-key minibuffer-local-completion-map "\C-g"
698 '(lambda () (interactive) (beep) (throw 'select-abort nil)))
699 (setq chosen (completing-read prompt sc-gal-attributions))
700 (if (or (not chosen)
701 (string= chosen ""))
702 default
703 chosen)))))
706 ;; ======================================================================
707 ;; this section contains primitive functions used in the email address
708 ;; parsing schemes. they extract name fields from various parts of
709 ;; the "from:" field.
711 (defun sc-style1-addresses (from-string &optional delim)
712 "Extract the author's email terminus from email address FROM-STRING.
713 Match addresses of the style \"name%[stuff].\" when called with DELIM
714 of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when
715 called with DELIM \"@\". If DELIM is nil or not provided, matches
716 addresses of the style \"name\"."
717 (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0)
718 (substring from-string
719 (match-beginning 0)
720 (- (match-end 0) (if (null delim) 0 1)))))
722 (defun sc-style2-addresses (from-string)
723 "Extract the author's email terminus from email address FROM-STRING.
724 Match addresses of the style \"[stuff]![stuff]...!name[stuff].\""
725 (let ((eos (length from-string))
726 (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)"
727 from-string 0))
728 (mend (match-end 0)))
729 (and mstart
730 (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1)))
733 (defun sc-get-address (from-string author)
734 "Get the full email address path from FROM-STRING.
735 AUTHOR is the author's name (which is removed from the address)."
736 (let ((eos (length from-string)))
737 (if (string-match (concat "\\(^\\|^\"\\)" author
738 "\\(\\s +\\|\"\\s +\\)") from-string 0)
739 (let ((addr (substring from-string (match-end 0) eos)))
740 (if (and (= (aref addr 0) ?<)
741 (= (aref addr (1- (length addr))) ?>))
742 (substring addr 1 (1- (length addr)))
743 addr))
744 (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0)
745 (substring from-string (match-beginning 0) (match-end 0))
749 (defun sc-get-emailname (from-string)
750 "Get the email terminus name from FROM-STRING."
751 (cond
752 ((sc-style1-addresses from-string "%"))
753 ((sc-style1-addresses from-string "@"))
754 ((sc-style2-addresses from-string))
755 ((sc-style1-addresses from-string nil))
756 (t (substring from-string 0 10))))
759 ;; ======================================================================
760 ;; this section contains functions that will extract a list of names
761 ;; from the name field string.
763 (defun sc-spacify-name-chars (name)
764 (let ((len (length name))
765 (s 0))
766 (while (< s len)
767 (if (memq (aref name s) sc-spacify-name-chars)
768 (aset name s 32))
769 (setq s (1+ s)))
770 name))
772 (defun sc-name-substring (string start end extend)
773 "Extract the specified substring of STRING from START to END.
774 EXTEND is the number of characters on each side to extend the
775 substring."
776 (and start
777 (let ((sos (+ start extend))
778 (eos (- end extend)))
779 (substring string sos
780 (or (string-match sc-titlecue-regexp string sos) eos)
781 ))))
783 (defun sc-extract-namestring (from-string)
784 "Extract the name string from FROM-STRING.
785 This should be the author's full name minus an optional title."
786 (let ((pstart (string-match "(.*)" from-string 0))
787 (pend (match-end 0))
788 (qstart (string-match "\".*\"" from-string 0))
789 (qend (match-end 0))
790 (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0))
791 (bend (match-end 0)))
792 (sc-spacify-name-chars
793 (cond
794 ((sc-name-substring from-string pstart pend 1))
795 ((sc-name-substring from-string qstart qend 1))
796 ((sc-name-substring from-string bstart bend 0))
797 ))))
799 (defun sc-chop-namestring (namestring)
800 "Convert NAMESTRING to a list of names.
802 example: (sc-namestring-to-list \"John Xavier Doe\")
803 => (\"John\" \"Xavier\" \"Doe\")"
804 (if (not (string= namestring ""))
805 (append (list (sc-string-car namestring))
806 (sc-chop-namestring (sc-string-cdr namestring)))))
808 (defun sc-strip-initials (namelist)
809 "Extract the author's initials from the NAMELIST."
810 (if (not namelist)
812 (concat (if (string= (car namelist) "")
814 (substring (car namelist) 0 1))
815 (sc-strip-initials (cdr namelist)))))
818 ;; ======================================================================
819 ;; this section handles selection of the attribution and citation strings
821 (defun sc-populate-alists (from-string)
822 "Put important and useful information in the alists using FROM-STRING.
823 Return the list of name symbols."
824 (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string)))
825 (revnames (reverse (cdr namelist)))
826 (midnames (reverse (cdr revnames)))
827 (firstname (car namelist))
828 (midnames (reverse (cdr revnames)))
829 (lastname (car revnames))
830 (initials (sc-strip-initials namelist))
831 (emailname (sc-get-emailname from-string))
832 (n 1)
833 (symlist (list 'emailname 'initials 'firstname 'lastname)))
835 ;; put basic information
836 (aput 'sc-gal-attributions 'firstname firstname)
837 (aput 'sc-gal-attributions 'lastname lastname)
838 (aput 'sc-gal-attributions 'emailname emailname)
839 (aput 'sc-gal-attributions 'initials initials)
841 (aput 'sc-gal-information "sc-firstname" firstname)
842 (aput 'sc-gal-information "sc-lastname" lastname)
843 (aput 'sc-gal-information "sc-emailname" emailname)
844 (aput 'sc-gal-information "sc-initials" initials)
846 ;; put middle names and build sc-author entry
847 (let ((author (concat firstname " ")))
848 (while midnames
849 (let ((name (car midnames))
850 (next (cdr midnames))
851 (symbol (intern (format "middlename%d" n)))
852 (string (format "sc-middlename-%d" n)))
853 ;; first put new middlename
854 (aput 'sc-gal-attributions symbol name)
855 (aput 'sc-gal-information string name)
856 (setq n (1+ n))
857 (nconc symlist (list symbol))
859 ;; now build author name
860 (setq author (concat author name " "))
862 ;; incr loop
863 (setq midnames next)
865 (setq author (concat author lastname))
867 ;; put author name and email address
868 (aput 'sc-gal-information "sc-author" author)
869 (aput 'sc-gal-information "sc-from-address"
870 (sc-get-address from-string author))
871 (aput 'sc-gal-information "sc-reply-address"
872 (sc-get-address (sc-field "reply-to") author))
874 ;; return value
875 symlist))
877 (defun sc-sort-attribution-alist ()
878 "Put preferred attribution at head of attributions alist."
879 (asort 'sc-gal-attributions sc-preferred-attribution)
881 ;; use backup scheme if preference is not legal
882 (if (or (null sc-preferred-attribution)
883 (anot-head-p sc-gal-attributions sc-preferred-attribution)
884 (let ((prefval (aget sc-gal-attributions
885 sc-preferred-attribution)))
886 (or (null prefval)
887 (string= prefval ""))))
888 ;; no legal attribution
889 (if sc-use-only-preference-p
890 (aput 'sc-gal-attributions 'sc-user-query
891 (sc-query sc-default-attribution))
892 ;; else use secondary scheme
893 (asort 'sc-gal-attributions 'firstname))))
895 (defun sc-build-attribution-alist (from-string)
896 "Extract attributions from FROM-STRING, applying preferences."
897 (let ((symlist (sc-populate-alists from-string))
898 (headval (progn (sc-sort-attribution-alist)
899 (aget sc-gal-attributions
900 (aheadsym sc-gal-attributions) t))))
902 ;; for each element in the symlist, remove the corresponding
903 ;; key-value pair in the alist, then insert just the value.
904 (while symlist
905 (let ((value (aget sc-gal-attributions (car symlist) t))
906 (next (cdr symlist)))
907 (if (not (or (null value)
908 (string= value "")))
909 (aput 'sc-gal-attributions value))
910 (adelete 'sc-gal-attributions (car symlist))
911 (setq symlist next)))
913 ;; add nicknames to the completion list
914 (let ((gal sc-gal-attributions))
915 (while gal
916 (let ((nns sc-nicknames-alist)
917 (galname (car (car gal))))
918 (while nns
919 (if (string= galname (car (car nns)))
920 (aput 'sc-gal-attributions (car (cdr (car nns)))))
921 (setq nns (cdr nns)))
922 (setq gal (cdr gal)))))
924 ;; now reinsert the head (preferred) attribution unless it is nil,
925 ;; this effectively just moves the head value to the front of the
926 ;; list.
927 (if headval
928 (aput 'sc-gal-attributions headval))
930 ;; check to be sure alist is not nil
931 (if (null sc-gal-attributions)
932 (aput 'sc-gal-attributions sc-default-attribution))))
934 (defun sc-select ()
935 "Select an attribution and create a citation string."
936 (cond
937 (sc-nested-citation-p
938 (sc-update-gal ""))
939 ((null (aget sc-gal-information "from" t))
940 (aput 'sc-gal-information "sc-author" sc-default-author-name)
941 (sc-update-gal (sc-query sc-default-attribution)))
942 ((null sc-gal-attributions)
943 (sc-build-attribution-alist (aget sc-gal-information "from" t))
944 (sc-confirm)
945 (sc-update-gal (aheadsym sc-gal-attributions)))
947 (sc-confirm)
948 (sc-update-gal (aheadsym sc-gal-attributions))))
952 ;; ======================================================================
953 ;; region citing and unciting
955 (defun sc-cite-region (start end)
956 "Cite a region delineated by START and END."
957 (save-excursion
958 ;; set real end-of-region
959 (goto-char end)
960 (forward-line 1)
961 (set-mark (point))
962 ;; goto real beginning-of-region
963 (goto-char start)
964 (beginning-of-line)
965 (let ((fstart (point))
966 (fend (point)))
967 (while (< (point) (sc-mark))
968 ;; remove leading whitespace if desired
969 (and sc-fixup-whitespace-p
970 (fixup-whitespace))
971 ;; if end of line then perhaps autofill
972 (cond ((eolp)
973 (or (= fstart fend)
974 (not sc-auto-fill-region-p)
975 (and sc-auto-fill-query-each-paragraph-p
976 (not (y-or-n-p "Fill this paragraph? ")))
977 (save-excursion (set-mark fend)
978 (goto-char (/ (+ fstart fend 1) 2))
979 (run-hooks 'sc-fill-paragraph-hook)))
980 (setq fstart (point)
981 fend (point)))
982 ;; not end of line so perhaps cite it
983 ((not (looking-at sc-cite-regexp))
984 (insert (aget sc-gal-information "sc-citation")))
985 (sc-nested-citation-p
986 (insert (aget sc-gal-information "sc-nested-citation"))))
987 (setq fend (point))
988 (forward-line 1))
989 (and sc-auto-fill-query-each-paragraph-p
990 (message " "))
993 (defun sc-uncite-region (start end cite-regexp)
994 "Uncite a previously cited region delineated by START and END.
995 CITE-REGEXP describes how a cited line of texts starts. Unciting also
996 auto-fills paragraph if sc-auto-fill-region-p is non-nil."
997 (save-excursion
998 (set-mark end)
999 (goto-char start)
1000 (beginning-of-line)
1001 (let ((fstart (point))
1002 (fend (point)))
1003 (while (< (point) (sc-mark))
1004 ;; if end of line, then perhaps autofill
1005 (cond ((eolp)
1006 (or (= fstart fend)
1007 (not sc-auto-fill-region-p)
1008 (and sc-auto-fill-query-each-paragraph-p
1009 (not (y-or-n-p "Fill this paragraph? ")))
1010 (save-excursion (set-mark fend)
1011 (goto-char (/ (+ fstart fend 1) 2))
1012 (run-hooks 'sc-fill-paragraph-hook)))
1013 (setq fstart (point)
1014 fend (point)))
1015 ;; not end of line so perhaps uncite it
1016 ((looking-at cite-regexp)
1017 (save-excursion
1018 (save-restriction
1019 (narrow-to-region (sc-linepos 'bol) (sc-linepos))
1020 (beginning-of-line)
1021 (delete-region (point-min)
1022 (progn (re-search-forward cite-regexp
1023 (point-max)
1025 (match-end 0)))))))
1026 (setq fend (point))
1027 (forward-line 1)))))
1030 ;; ======================================================================
1031 ;; this section contains paragraph filling support
1033 (defun sc-guess-fill-prefix (&optional literalp)
1034 "Guess the fill prefix used on the current line.
1035 Use various heuristics to find the fill prefix. Search begins on first
1036 non-blank line after point.
1038 1) If fill-prefix is already bound to the empty string, return
1039 nil.
1041 2) If fill-prefix is already bound, but not to the empty
1042 string, return the value of fill-prefix.
1044 3) If the current line starts with the last chosen citation
1045 string, then that string is returned.
1047 4) If the current line starts with a string matching the regular
1048 expression sc-cite-regexp, return the match. Note that if
1049 optional LITERALP is provided and non-nil, then the *string*
1050 that matches the regexp is return. Otherwise, if LITERALP is
1051 not provided or is nil, the *regexp* sc-cite-regexp is
1052 returned.
1054 5) If the current line starts with any number of characters,
1055 followed by the sc-citation-delimiter and then white space,
1056 that match is returned. See comment #4 above for handling of
1057 LITERALP.
1059 6) Nil is returned."
1060 (save-excursion
1061 ;; scan for first non-blank line in the region
1062 (beginning-of-line)
1063 (skip-chars-forward "\n\t ")
1064 (beginning-of-line)
1065 (let ((citation (aget sc-gal-information "sc-citation"))
1066 (generic-citation
1067 (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +")))
1068 (cond
1069 ((string= fill-prefix "") nil) ;; heuristic #1
1070 (fill-prefix) ;; heuristic #2
1071 ((looking-at (regexp-quote citation)) citation) ;; heuristic #3
1072 ((looking-at sc-cite-regexp) ;; heuristic #4
1073 (if literalp
1074 (buffer-substring
1075 (point)
1076 (progn (re-search-forward (concat sc-cite-regexp "\\s *")
1077 (point-max) nil)
1078 (point)))
1079 sc-cite-regexp))
1080 ((looking-at generic-citation) ;; heuristic #5
1081 (if literalp
1082 (buffer-substring
1083 (point)
1084 (progn (re-search-forward generic-citation) (point)))
1085 generic-citation))
1086 (t nil))))) ;; heuristic #6
1088 (defun sc-consistent-cite-p (prefix)
1089 "Check current paragraph for consistent citation.
1090 Scans to paragraph delineated by (forward|backward)-paragraph to see
1091 if all lines start with PREFIX. Returns t if entire paragraph is
1092 consistently cited, nil otherwise."
1093 (save-excursion
1094 (let ((end (progn (forward-paragraph)
1095 (beginning-of-line)
1096 (or (not (eolp))
1097 (forward-char -1))
1098 (point)))
1099 (start (progn (backward-paragraph)
1100 (beginning-of-line)
1101 (or (not (eolp))
1102 (forward-char 1))
1103 (point)))
1104 (badline t))
1105 (goto-char start)
1106 (beginning-of-line)
1107 (while (and (< (point) end)
1108 badline)
1109 (setq badline (looking-at prefix))
1110 (forward-line 1))
1111 badline)))
1113 (defun sc-fill-start (fill-prefix)
1114 "Find buffer position of start of region which begins with FILL-PREFIX.
1115 Restrict scan to current paragraph."
1116 (save-excursion
1117 (let ((badline nil)
1118 (top (save-excursion
1119 (backward-paragraph)
1120 (beginning-of-line)
1121 (or (not (eolp))
1122 (forward-char 1))
1123 (point))))
1124 (while (and (not badline)
1125 (> (point) top))
1126 (forward-line -1)
1127 (setq badline (not (looking-at fill-prefix)))))
1128 (forward-line 1)
1129 (point)))
1131 (defun sc-fill-end (fill-prefix)
1132 "Find the buffer position of end of region which begins with FILL-PREFIX.
1133 Restrict scan to current paragraph."
1134 (save-excursion
1135 (let ((badline nil)
1136 (bot (save-excursion
1137 (forward-paragraph)
1138 (beginning-of-line)
1139 (or (not (eolp))
1140 (forward-char -1))
1141 (point))))
1142 (while (and (not badline)
1143 (< (point) bot))
1144 (beginning-of-line)
1145 (setq badline (not (looking-at fill-prefix)))
1146 (forward-line 1)))
1147 (forward-line -1)
1148 (point)))
1150 (defun sc-fill-paragraph ()
1151 "Supercite's paragraph fill function.
1152 Fill the paragraph containing or following point. Use
1153 sc-guess-fill-prefix to find the fill-prefix for the paragraph.
1155 If the paragraph is inconsistently cited (mixed fill-prefix), then the
1156 user is queried to restrict the the fill to only those lines around
1157 point which begin with the fill prefix.
1159 The variable sc-fill-arg is passed to fill-paragraph and
1160 fill-region-as-paragraph which controls justification of the
1161 paragraph. sc-fill-arg is set by sc-fill-paragraph-manually."
1162 (save-excursion
1163 (let ((pnt (point))
1164 (fill-prefix (sc-guess-fill-prefix t)))
1165 (cond
1166 ((not fill-prefix)
1167 (fill-paragraph sc-fill-arg))
1168 ((sc-consistent-cite-p fill-prefix)
1169 (fill-paragraph sc-fill-arg))
1170 ((y-or-n-p "Inconsistent citation found. Restrict? ")
1171 (message "")
1172 (fill-region-as-paragraph (progn (goto-char pnt)
1173 (sc-fill-start fill-prefix))
1174 (progn (goto-char pnt)
1175 (sc-fill-end fill-prefix))
1176 sc-fill-arg))
1178 (message "")
1179 (progn
1180 (setq fill-prefix (aget sc-gal-information "sc-citation"))
1181 (fill-paragraph sc-fill-arg)))))))
1184 ;; ======================================================================
1185 ;; the following functions are the top level, interactive commands that
1186 ;; can be bound to key strokes
1188 (defun sc-insert-reference (arg)
1189 "Insert, at point, a reference header in the body of the reply.
1190 Numeric ARG indicates which header style from sc-rewrite-header-list
1191 to use when rewriting the header. No supplied ARG indicates use of
1192 sc-preferred-header-style.
1194 With just \\[universal-argument], electric reference insert mode is
1195 entered, regardless of the value of sc-electric-references-p. See
1196 sc-electric-mode for more information."
1197 (interactive "P")
1198 (if (consp arg)
1199 (sc-electric-mode)
1200 (let ((pref (cond ((sc-valid-index-p arg) arg)
1201 ((sc-valid-index-p sc-preferred-header-style)
1202 sc-preferred-header-style)
1203 (t 0))))
1204 (if sc-electric-references-p (sc-electric-mode pref)
1205 (condition-case err
1206 (eval (nth pref sc-rewrite-header-list))
1207 (void-function
1208 (progn (message
1209 "Symbol's function definition is void: %s. (Header %d)."
1210 (symbol-name (car (cdr err)))
1211 pref)
1212 (beep)))
1213 (error
1214 (progn (message "Error evaluating rewrite header function %d."
1215 pref)
1216 (beep)))
1217 )))))
1219 (defun sc-cite (arg)
1220 "Cite the region of text between point and mark.
1221 Numeric ARG, if supplied, is passed unaltered to sc-insert-reference."
1222 (interactive "P")
1223 (if (not (sc-mark))
1224 (error "Please designate a region to cite (i.e. set the mark)."))
1225 (catch 'select-abort
1226 (let ((sc-cite-context 'citing)
1227 (sc-force-confirmation-p (interactive-p)))
1228 (sc-select)
1229 (undo-boundary)
1230 (let ((xchange (if (> (sc-mark) (point)) nil
1231 (exchange-point-and-mark)
1232 t)))
1233 (sc-insert-reference arg)
1234 (sc-cite-region (point) (sc-mark))
1235 ;; leave point on first cited line
1236 (while (and (< (point) (sc-mark))
1237 (not (looking-at (aget sc-gal-information
1238 (if sc-nested-citation-p
1239 "sc-nested-citation"
1240 "sc-citation")))))
1241 (forward-line 1))
1242 (and xchange
1243 (exchange-point-and-mark))
1244 ))))
1246 (defun sc-uncite ()
1247 "Uncite the region between point and mark."
1248 (interactive)
1249 (if (not (sc-mark))
1250 (error "Please designate a region to uncite (i.e. set the mark)."))
1251 (undo-boundary)
1252 (let ((xchange (if (> (sc-mark) (point)) nil
1253 (exchange-point-and-mark)
1255 (fp (or (sc-guess-fill-prefix)
1256 "")))
1257 (sc-uncite-region (point) (sc-mark) fp)
1258 (and xchange
1259 (exchange-point-and-mark))))
1261 (defun sc-recite ()
1262 "Recite the region by first unciting then citing the text."
1263 (interactive)
1264 (if (not (sc-mark))
1265 (error "Please designate a region to recite (i.e. set the mark)."))
1266 (catch 'select-abort
1267 (let ((sc-cite-context 'reciting)
1268 (sc-force-confirmation-p t))
1269 (sc-select)
1270 (undo-boundary)
1271 (let ((xchange (if (> (sc-mark) (point)) nil
1272 (exchange-point-and-mark)
1274 (fp (or (sc-guess-fill-prefix)
1275 "")))
1276 (sc-uncite-region (point) (sc-mark) fp)
1277 (sc-cite-region (point) (sc-mark))
1278 (and xchange
1279 (exchange-point-and-mark))
1280 ))))
1282 (defun sc-insert-citation ()
1283 "Insert citation string at beginning of current line."
1284 (interactive)
1285 (save-excursion
1286 (beginning-of-line)
1287 (insert (aget sc-gal-information "sc-citation"))))
1289 (defun sc-open-line (arg)
1290 "Insert a newline and leave point before it.
1291 Also inserts the guessed prefix at the beginning of the new line. With
1292 numeric ARG, inserts that many new lines."
1293 (interactive "p")
1294 (save-excursion
1295 (let ((start (point))
1296 (string (or (sc-guess-fill-prefix t)
1297 "")))
1298 (open-line arg)
1299 (goto-char start)
1300 (forward-line 1)
1301 (while (< 0 arg)
1302 (insert string)
1303 (forward-line 1)
1304 (setq arg (- arg 1))))))
1306 (defun sc-fill-paragraph-manually (arg)
1307 "Fill current cited paragraph.
1308 Really just runs the hook sc-fill-paragraph-hook, however it does set
1309 the global variable sc-fill-arg to the value of ARG. This is
1310 currently the only way to pass an argument to a hookified function."
1311 (interactive "P")
1312 (setq sc-fill-arg arg)
1313 (run-hooks 'sc-fill-paragraph-hook))
1315 (defun sc-modify-information (arg)
1316 "Interactively modify information in the information alist.
1317 \\[universal-argument] if supplied, deletes the entry from the alist.
1318 You can add an entry by supplying a key instead of completing."
1319 (interactive "P")
1320 (let* ((delete-p (consp arg))
1321 (action (if delete-p "delete" "modify"))
1322 (defaultkey (aheadsym sc-gal-information))
1323 (prompt (concat "Select information key to "
1324 action ": (default "
1325 defaultkey ") "))
1326 (key (completing-read prompt sc-gal-information))
1328 (if (or (string= key "")
1329 (null key))
1330 (setq key defaultkey))
1331 (if delete-p (adelete 'sc-gal-information key)
1332 (let* ((oldval (aget sc-gal-information key t))
1333 (prompt (concat "Enter new value for key \""
1334 key "\" (default \"" oldval "\") "))
1335 (newval (read-input prompt)))
1336 (if (or (string= newval "")
1337 (null newval))
1339 (aput 'sc-gal-information key newval)
1340 )))))
1342 (defun sc-view-field (arg)
1343 "View field values in the information alist.
1344 This is essentially an interactive version of sc-field, and is similar
1345 to sc-modify-information, except that the field values can't be
1346 modified. With \\[universal-argument], if supplied, inserts the value
1347 into the current buffer as well."
1348 (interactive "P")
1349 (let* ((defaultkey (aheadsym sc-gal-information))
1350 (prompt (concat "View information key: (default "
1351 defaultkey ") "))
1352 (key (completing-read prompt sc-gal-information)))
1353 (if (or (string= key "")
1354 (null key))
1355 (setq key defaultkey))
1356 (let* ((val (aget sc-gal-information key t))
1357 (pval (if val (concat "\"" val "\"") "nil")))
1358 (message "value of key %s: %s" key pval)
1359 (if (and key (consp arg)) (insert val)))))
1361 (defun sc-glom-headers ()
1362 "Glom information from mail headers in region between point and mark.
1363 Any old information is lost, unless an error occurs."
1364 (interactive)
1365 (let ((attr (copy-sequence sc-gal-attributions))
1366 (info (copy-sequence sc-gal-information)))
1367 (setq sc-gal-attributions nil
1368 sc-gal-information nil)
1369 (let (start end
1370 (sc-force-confirmation-p t)
1371 (sc-cite-context nil))
1372 (let ((mark-active t))
1373 (setq start (region-beginning)
1374 end (region-end)))
1375 (sc-fetch-fields start end)
1376 (if (null sc-gal-information)
1377 (progn
1378 (message "No mail headers found! Restoring old information.")
1379 (setq sc-gal-attributions attr
1380 sc-gal-information info))
1381 (sc-mail-yank-clear-headers start end)
1382 (if (not (catch 'select-abort
1383 (condition-case foo
1384 (sc-select)
1385 (quit (beep) (throw 'select-abort nil)))
1387 (setq sc-gal-attributions attr
1388 sc-gal-information info))
1389 ))))
1391 (defun sc-version (arg)
1392 "Show supercite version.
1393 Universal argument (\\[universal-argument]) ARG inserts version
1394 information in the current buffer instead of printing the message in
1395 the echo area."
1396 (interactive "P")
1397 (if (consp arg)
1398 (insert "Using Supercite version " sc-version-number)
1399 (message "Using Supercite version %s" sc-version-number)))
1402 ;; ======================================================================
1403 ;; leach onto current mode
1405 (defun sc-append-current-keymap ()
1406 "Append some useful key bindings to the current local key map.
1407 This searches sc-local-keymap for the keymap to install based on the
1408 major-mode of the current buffer."
1409 (let ((hook (car (cdr (assq major-mode sc-local-keymaps)))))
1410 (cond
1411 ((not hook)
1412 (run-hooks 'sc-default-keymap))
1413 ((not (listp hook))
1414 (setq hook (car (cdr (assq hook sc-local-keymaps))))
1415 (run-hooks 'hook))
1417 (run-hooks 'hook))))
1418 (setq sc-leached-keymap (current-local-map)))
1420 (defun sc-snag-all-keybindings ()
1421 "Snag all keybindings in major-mode's current keymap."
1422 (let* ((curkeymap (current-local-map))
1423 (symregexp ".*sc-.*\n")
1424 (docstring (substitute-command-keys "\\{curkeymap}"))
1425 (start 0)
1426 (maxend (length docstring))
1427 (spooge ""))
1428 (while (and (< start maxend)
1429 (string-match symregexp docstring start))
1430 (setq spooge (concat spooge (substring docstring
1431 (match-beginning 0)
1432 (match-end 0))))
1433 (setq start (match-end 0)))
1434 spooge))
1436 (defun sc-spoogify-docstring ()
1437 "Modifies (makes into spooge) the docstring for the current major mode.
1438 This will leach the keybinding descriptions for supercite onto the end
1439 of the current major mode's docstring. If major mode is preloaded,
1440 this function will first make a copy of the list associated with the
1441 mode, then modify this copy."
1442 (let* ((symfunc (symbol-function major-mode))
1443 (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc)))
1444 (doc-str (documentation major-mode)))
1445 (cond
1446 ;; is a docstring even provided?
1447 ((not (stringp doc-str)))
1448 ;; have we already leached on?
1449 ((string-match "Supercite" doc-str))
1450 ;; lets build the new doc string
1452 (let* ((described (sc-snag-all-keybindings))
1453 (commonstr "
1455 The major mode for this buffer has been modified to include the
1456 Supercite 2.3 package for handling attributions and citations of
1457 original messages in email replies. For more information on this
1458 package, type \"\\[sc-describe]\".")
1459 (newdoc-str
1460 (concat doc-str commonstr
1461 (if (not (string= described ""))
1462 (concat "\n\nThe following keys are bound "
1463 "to Supercite commands:\n\n"
1464 described)))
1466 (cond
1467 (doc-cdr
1468 (condition-case nil
1469 (setcar doc-cdr newdoc-str)
1470 (error
1471 ;; the major mode must be preloaded, make a copy first
1472 (setq symfunc (copy-sequence (symbol-function major-mode))
1473 doc-cdr (nthcdr 2 symfunc))
1474 (setcar doc-cdr newdoc-str)
1475 (fset major-mode symfunc))))
1476 ;; lemacs 19 byte-code.
1477 ;; Set function to a new byte-code vector with the
1478 ;; new documentation in the documentation slot (element 4).
1479 ;; We can't use aset because aset won't allow you to modify
1480 ;; a byte-code vector.
1481 ;; Include element 5 if the vector has one.
1483 (fset major-mode
1484 (apply 'make-byte-code
1485 (aref symfunc 0) (aref symfunc 1)
1486 (aref symfunc 2) (aref symfunc 3)
1487 newdoc-str
1488 (if (> (length symfunc) 5)
1489 (list (aref symfunc 5)))))
1490 )))))))
1493 ;; ======================================================================
1494 ;; this section contains default hooks and hook support for execution
1496 ;;;###autoload
1497 (defun sc-cite-original ()
1498 "Hook version of sc-cite.
1499 This is callable from the various mail and news readers' reply
1500 function according to the agreed upon standard. See \\[sc-describe]
1501 for more details. Sc-cite-original does not do any yanking of the
1502 original message but it does require a few things:
1504 1) The reply buffer is the current buffer.
1506 2) The original message has been yanked and inserted into the
1507 reply buffer.
1509 3) Verbose mail headers from the original message have been
1510 inserted into the reply buffer directly before the text of the
1511 original message.
1513 4) Point is at the beginning of the verbose headers.
1515 5) Mark is at the end of the body of text to be cited."
1516 (run-hooks 'sc-pre-hook)
1517 (setq sc-gal-attributions nil)
1518 (setq sc-gal-information nil)
1519 (let (start end)
1520 (let ((mark-active t))
1521 (setq start (region-beginning)
1522 end (region-end)))
1523 (sc-fetch-fields start end)
1524 (sc-mail-yank-clear-headers start end)
1525 (if (not sc-all-but-cite-p)
1526 (sc-cite sc-preferred-header-style))
1527 (sc-append-current-keymap)
1528 (sc-spoogify-docstring)
1529 (run-hooks 'sc-post-hook)))
1532 ;; ======================================================================
1533 ;; describe this package
1535 (defun sc-describe ()
1536 "Supercite version 2.3 is now described in a texinfo manual which
1537 makes the documentation available both for online perusal via emacs'
1538 info system, or for hard-copy printing using the TeX facility.
1540 To view the online document hit \\[info], then \"mSupercite <RET>\"."
1541 (interactive)
1542 (describe-function 'sc-describe))
1544 ;; ======================================================================
1545 ;; load hook
1546 (run-hooks 'sc-load-hook)
1547 (provide 'sc)