Explan when boundaries are made automatically.
[bpt/emacs.git] / lisp / mail / supercite.el
CommitLineData
30b7c745
RS
1;;; supercite.el --- minor mode for citing mail and news replies
2
3;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
4;; Maintainer: supercite-help@anthem.nlm.nih.gov
5;; Created: February 1993
6;; Version: 3.1
7;; Last Modified: 1993/09/22 18:58:46
b7f66977 8;; Keywords: mail, news
30b7c745
RS
9
10;; supercite.el revision: 3.54
11
12;; Copyright (C) 1993 Barry A. Warsaw
13
14;; This file is part of GNU Emacs.
15
16;; GNU Emacs is free software; you can redistribute it and/or modify
17;; it under the terms of the GNU General Public License as published by
18;; the Free Software Foundation; either version 2, or (at your option)
19;; any later version.
20
21;; GNU Emacs is distributed in the hope that it will be useful,
22;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24;; GNU General Public License for more details.
25
26;; You should have received a copy of the GNU General Public License
27;; along with GNU Emacs; see the file COPYING. If not, write to
28;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
29
30;; LCD Archive Entry
31;; supercite|Barry A. Warsaw|supercite-help@anthem.nlm.nih.gov
32;; |Mail and news reply citation package
33;; |1993/09/22 18:58:46|3.1|
34
35;; Code:
36
37\f
38(require 'regi)
39
40;; start user configuration variables
41;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
42
43(defvar sc-auto-fill-region-p t
44 "*If non-nil, automatically fill each paragraph after it has been cited.")
45
46(defvar sc-blank-lines-after-headers 1
47 "*Number of blank lines to leave after mail headers have been nuked.
48Set to nil, to use whatever blank lines happen to occur naturally.")
49
50(defvar sc-citation-leader " "
51 "*String comprising first part of a citation.")
52(defvar sc-citation-delimiter ">"
53 "*String comprising third part of a citation.
54This string is used in both nested and non-nested citations.")
55(defvar sc-citation-separator " "
56 "*String comprising fourth and last part of a citation.")
57
58(defvar sc-citation-leader-regexp "[ \t]*"
59 "*Regexp describing citation leader for a cited line.
60This should NOT have a leading `^' character.")
61
62;; Nemacs and Mule users note: please see the texinfo manual for
63;; suggestions on setting these variables.
64(defvar sc-citation-root-regexp "[-._a-zA-Z0-9]*"
65 "*Regexp describing variable root part of a citation for a cited line.
66This should NOT have a leading `^' character. See also
67`sc-citation-nonnested-root-regexp'.")
68(defvar sc-citation-nonnested-root-regexp "[-._a-zA-Z0-9]+"
69 "*Regexp describing the variable root part of a nested citation.
70This should NOT have a leading `^' character. This variable is
71related to `sc-citation-root-regexp' but where as that varariable
72describes both nested and non-nested citation roots, this variable
73describes only nested citation roots.")
74(defvar sc-citation-delimiter-regexp "[>]+"
75 "*Regexp describing citation delimiter for a cited line.
76This should NOT have a leading `^' character.")
77(defvar sc-citation-separator-regexp "[ \t]*"
78 "*Regexp describing citation separator for a cited line.
79This should NOT have a leading `^' character.")
80
81(defvar sc-cite-blank-lines-p nil
82 "*If non-nil, put a citation on blank lines.")
83
84(defvar sc-cite-frame-alist '()
85 "*Alist for frame selection during citing.
86Each element of this list has the following form:
87
88 (INFOKEY ((REGEXP . FRAME)
89 (REGEXP . FRAME)
90 (...)))
91
92Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular
93expression to match against the INFOKEY's value. FRAME is a citation
94frame, or a variable containing a citation frame.")
95(defvar sc-uncite-frame-alist '()
96 "*Alist for frame selection during unciting.
97See the variable `sc-cite-frame-alist' for details.")
98(defvar sc-recite-frame-alist '()
99 "*Alist for frame selection during reciting.
100See the variable `sc-cite-frame-alist' for details.")
101
102(defvar sc-default-cite-frame
103 '(;; initialize fill state and temporary variables when entering
104 ;; frame. this makes things run much faster
105 (begin (progn
106 (sc-fill-if-different)
107 (setq sc-tmp-nested-regexp (sc-cite-regexp "")
108 sc-tmp-nonnested-regexp (sc-cite-regexp)
109 sc-tmp-dumb-regexp
110 (concat "\\("
111 (sc-cite-regexp "")
112 "\\)"
113 (sc-cite-regexp sc-citation-nonnested-root-regexp))
114 )))
115 ;; blank lines mean paragraph separators, so fill the last cited
116 ;; paragraph, unless sc-cite-blank-lines-p is non-nil, in which
117 ;; case we treat blank lines just like any other line.
118 ("^[ \t]*$" (if sc-cite-blank-lines-p
119 (sc-cite-line)
120 (sc-fill-if-different "")))
121 ;; do nothing if looking at a reference tag. make sure that the
122 ;; tag string isn't the empty string since this will match every
123 ;; line. it cannot be nil.
124 (sc-reference-tag-string (if (string= sc-reference-tag-string "")
125 (list 'continue)
126 nil))
127 ;; this regexp catches nested citations in which the author cited
128 ;; a non-nested citation with a dumb citer.
129 (sc-tmp-dumb-regexp (sc-cite-coerce-dumb-citer))
130 ;; if we are looking at a nested citation then add a citation level
131 (sc-tmp-nested-regexp (sc-add-citation-level))
132 ;; if we're looking at a non-nested citation, coerce it to our style
133 (sc-tmp-nonnested-regexp (sc-cite-coerce-cited-line))
134 ;; we must be looking at an uncited line. if we are in nested
135 ;; citations, just add a citation level
136 (sc-nested-citation-p (sc-add-citation-level))
137 ;; we're looking at an uncited line and we are in non-nested
138 ;; citations, so cite it with a non-nested citation
139 (t (sc-cite-line))
140 ;; be sure when we're done that we fill the last cited paragraph.
141 (end (sc-fill-if-different ""))
142 )
143 "*Default REGI frame for citing a region.")
144
145(defvar sc-default-uncite-frame
146 '(;; do nothing on a blank line
147 ("^[ \t]*$" nil)
148 ;; if the line is cited, uncite it
149 ((sc-cite-regexp) (sc-uncite-line))
150 )
151 "*Default REGI frame for unciting a region.")
152
153(defvar sc-default-recite-frame
154 '(;; initialize fill state when entering frame
155 (begin (sc-fill-if-different))
156 ;; do nothing on a blank line
157 ("^[ \t]*$" nil)
158 ;; if we're looking at a cited line, recite it
159 ((sc-cite-regexp) (sc-recite-line (sc-cite-regexp)))
160 ;; otherwise, the line is uncited, so just cite it
161 (t (sc-cite-line))
162 ;; be sure when we're done that we fill the last cited paragraph.
163 (end (sc-fill-if-different ""))
164 )
165 "*Default REGI frame for reciting a region.")
166
167(defvar sc-cite-region-limit t
168 "*This variable controls automatic citation of yanked text.
169Legal values are:
170
171non-nil -- cite the entire region, regardless of its size
172nil -- do not cite the region at all
173<integer> -- a number indicating the threshold for citation. When
174 the number of lines in the region is greater than this
175 value, a warning message will be printed and the region
176 will not be cited. Lines in region are counted with
177 `count-lines'.
178
179The gathering of attribution information is not affected by the value
180of this variable. The number of lines in the region is calculated
181*after* all mail headers are removed. This variable is only consulted
182during the initial citing via `sc-cite-original'.")
183
184(defvar sc-confirm-always-p t
185 "*If non-nil, always confirm attribution string before citing text body.")
186
187(defvar sc-default-attribution "Anon"
188 "*String used when author's attribution cannot be determined.")
189(defvar sc-default-author-name "Anonymous"
190 "*String used when author's name cannot be determined.")
191
192(defvar sc-downcase-p nil
193 "*Non-nil means downcase the attribution and citation strings.")
194
195(defvar sc-electric-circular-p t
196 "*If non-nil, treat electric references as circular.")
197(defvar sc-electric-mode-hook nil
198 "*Hook for `sc-electric-mode' electric references mode.")
199(defvar sc-electric-references-p nil
200 "*Use electric references if non-nil.")
201
202(defvar sc-fixup-whitespace-p nil
203 "*If non-nil, delete all leading white space before citing.")
204
205(defvar sc-load-hook nil
206 "*Hook which gets run once after Supercite loads.")
207(defvar sc-pre-hook nil
208 "*Hook which gets run before each invocation of `sc-cite-original'.")
209(defvar sc-post-hook nil
210 "*Hook which gets run after each invocation of `sc-cite-original'.")
211
212(defvar sc-mail-warn-if-non-rfc822-p t
213 "*Warn if mail headers don't conform to RFC822.")
214(defvar sc-mumble ""
215 "*Value returned by `sc-mail-field' if field isn't in mail headers.")
216
217(defvar sc-name-filter-alist
218 '(("^\\(Mr\\|Mrs\\|Ms\\|Dr\\)[.]?$" . 0)
219 ("^\\(Jr\\|Sr\\)[.]?$" . last)
220 ("^ASTS$" . 0)
221 ("^[I]+$" . last))
222 "*Name list components which are filtered out as noise.
223This variable contains an association list where each element is of
224the form: (REGEXP . POSITION).
225
226REGEXP is a regular expression which matches the name list component.
227Match is performed using `string-match'. POSITION is the position in
228the name list which can match the regular expression, starting at zero
229for the first element. Use `last' to match the last element in the
230list and `any' to match all elements.")
231
232(defvar sc-nested-citation-p nil
233 "*Controls whether to use nested or non-nested citation style.
234Non-nil uses nested citations, nil uses non-nested citations.")
235
236(defvar sc-nuke-mail-headers 'all
237 "*Controls mail header nuking.
238Used in conjunction with `sc-nuke-mail-header-list'. Legal values are:
239
240`all' -- nuke all mail headers
241`none' -- don't nuke any mail headers
242`specified' -- nuke headers specified in `sc-nuke-mail-header-list'
243`keep' -- keep headers specified in `sc-nuke-mail-header-list'")
244
245(defvar sc-nuke-mail-header-list nil
246 "*List of mail header regexps to remove or keep in body of reply.
247This list contains regular expressions describing the mail headers to
248keep or nuke, depending on the value of `sc-nuke-mail-headers'.")
249
250(defvar sc-preferred-attribution-list
251 '("sc-lastchoice" "x-attribution" "firstname" "initials" "lastname")
252 "*Specifies what to use as the attribution string.
253Supercite creates a list of possible attributions when it scans the
254mail headers from the original message. Each attribution choice is
255associated with a key in an attribution alist. Supercite tries to
256pick a \"preferred\" attribution by matching the attribution alist
257keys against the elements in `sc-preferred-attribution-list' in order.
258The first non-empty string value found is used as the preferred
259attribution.
260
261Note that Supercite now honors the X-Attribution: mail field. If
262present in the original message, the value of this field should always
263be used to select the most preferred attribution since it reflects how
264the original author would like to be distinguished. It should be
265considered bad taste to put any attribution preference key before
266\"x-attribution\" in this list, except perhaps for \"sc-lastchoice\"
a4e104bf 267\(see below).
30b7c745
RS
268
269Supercite remembers the last attribution used when reciting an already
270cited paragraph. This attribution will always be saved with the
271\"sc-lastchoice\" key, which can be used in this list. Note that the
272last choice is always reset after every call of `sc-cite-original'.
273
274Barring error conditions, the following preferences are always present
275in the attribution alist:
276
277\"emailname\" -- email terminus name
278\"initials\" -- initials of author
279\"firstname\" -- first name of author
280\"lastname\" -- last name of author
281\"middlename-1\" -- first middle name of author
282\"middlename-2\" -- second middle name of author
283...
284
285Middle name indexes can be any positive integer greater than 0,
286although it is unlikely that many authors will supply more than one
287middle name, if that many. The string of all middle names is
288associated with the key \"middlenames\".")
289
290(defvar sc-attrib-selection-list nil
291 "*An alist for selecting preferred attribution based on mail headers.
292Each element of this list has the following form:
293
294 (INFOKEY ((REGEXP . ATTRIBUTION)
295 (REGEXP . ATTRIBUTION)
296 (...)))
297
298Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular
299expression to match against the INFOKEY's value. ATTRIBUTION can be a
300string or a list. If its a string, then it is the attribution that is
301selected by `sc-select-attribution'. If it is a list, it is `eval'd
302and the return value must be a string, which is used as the selected
303attribution. Note that the variable `sc-preferred-attribution-list'
304must contain an element of the string \"sc-consult\" for this variable
305to be consulted during attribution selection.")
306
307(defvar sc-attribs-preselect-hook nil
308 "*Hook to run before selecting an attribution.")
309(defvar sc-attribs-postselect-hook nil
310 "*Hook to run after selecting an attribution, but before confirmation.")
311
312(defvar sc-pre-cite-hook nil
313 "*Hook to run before citing a region of text.")
314(defvar sc-pre-uncite-hook nil
315 "*Hook to run before unciting a region of text.")
316(defvar sc-pre-recite-hook nil
317 "*Hook to run before reciting a region of text.")
318
319(defvar sc-preferred-header-style 4
320 "*Index into `sc-rewrite-header-list' specifying preferred header style.
321Index zero accesses the first function in the list.")
322
323(defvar sc-reference-tag-string ">>>>> "
324 "*String used at the beginning of built-in reference headers.")
325
326(defvar sc-rewrite-header-list
327 '((sc-no-header)
328 (sc-header-on-said)
329 (sc-header-inarticle-writes)
330 (sc-header-regarding-adds)
331 (sc-header-attributed-writes)
332 (sc-header-author-writes)
333 (sc-header-verbose)
334 (sc-no-blank-line-or-header)
335 )
336 "*List of reference header rewrite functions.
337The variable `sc-preferred-header-style' controls which function in
338this list is chosen for automatic reference header insertions.
339Electric reference mode will cycle through this list of functions.")
340
341(defvar sc-titlecue-regexp "\\s +-+\\s +"
342 "*Regular expression describing the separator between names and titles.
343Set to nil to treat entire field as a name.")
344
345(defvar sc-use-only-preference-p nil
346 "*Controls what happens when the preferred attribution cannot be found.
347If non-nil, then `sc-default-attribution' will be used. If nil, then
348some secondary scheme will be employed to find a suitable attribution
349string.")
350
351;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
352;; end user configuration variables
353\f
354(defconst sc-version "3.1"
355 "Supercite version number.")
356(defconst sc-help-address "supercite-help@anthem.nlm.nih.gov"
357 "Address accepting submissions of bug reports.")
358
359(defvar sc-mail-info nil
360 "Alist of mail header information gleaned from reply buffer.")
361(defvar sc-attributions nil
362 "Alist of attributions for use when citing.")
363
364(defconst sc-emacs-features
365 (let ((version 'v18)
366 (flavor 'GNU))
367 (if (string= (substring emacs-version 0 2) "19")
368 (setq version 'v19))
369 (if (string-match "Lucid" emacs-version)
370 (setq flavor 'Lucid))
371 ;; cobble up list
372 (list version flavor))
373 "A list describing what version of Emacs we're running on.
374Known flavors are:
375
376All GNU18's: (v18 GNU)
377FSF19.x : (v19 GNU)
378Lucid19.x : (v19 Lucid)")
379
380
381(defvar sc-tmp-nested-regexp nil
382 "Temporary regepx describing nested citations.")
383(defvar sc-tmp-nonnested-regexp nil
384 "Temporary regexp describing non-nested citations.")
385(defvar sc-tmp-dumb-regexp nil
386 "Temp regexp describing non-nested citation cited with a nesting citer.")
387
388(defvar sc-minor-mode nil
389 "Supercite minor mode on flag.")
390(defvar sc-mode-string " SC"
391 "Supercite minor mode string.")
392
393(make-variable-buffer-local 'sc-mail-info)
394(make-variable-buffer-local 'sc-attributions)
395(make-variable-buffer-local 'sc-minor-mode)
396
397\f
398;; ======================================================================
399;; supercite keymaps
400
401(defvar sc-mode-map-prefix "\C-c\C-p"
402 "*Key binding to install Supercite keymap.
403If this is nil, Supercite keymap is not installed.")
404
405(defvar sc-T-keymap ()
406 "Keymap for sub-keymap of setting and toggling functions.")
407(if sc-T-keymap
408 ()
409 (setq sc-T-keymap (make-sparse-keymap))
410 (define-key sc-T-keymap "a" 'sc-S-preferred-attribution-list)
411 (define-key sc-T-keymap "b" 'sc-T-mail-nuke-blank-lines)
412 (define-key sc-T-keymap "c" 'sc-T-confirm-always)
413 (define-key sc-T-keymap "d" 'sc-T-downcase)
414 (define-key sc-T-keymap "e" 'sc-T-electric-references)
415 (define-key sc-T-keymap "f" 'sc-T-auto-fill-region)
416 (define-key sc-T-keymap "h" 'sc-T-describe)
417 (define-key sc-T-keymap "l" 'sc-S-cite-region-limit)
418 (define-key sc-T-keymap "n" 'sc-S-mail-nuke-mail-headers)
419 (define-key sc-T-keymap "N" 'sc-S-mail-header-nuke-list)
420 (define-key sc-T-keymap "o" 'sc-T-electric-circular)
421 (define-key sc-T-keymap "p" 'sc-S-preferred-header-style)
422 (define-key sc-T-keymap "s" 'sc-T-nested-citation)
423 (define-key sc-T-keymap "u" 'sc-T-use-only-preferences)
424 (define-key sc-T-keymap "w" 'sc-T-fixup-whitespace)
425 (define-key sc-T-keymap "?" 'sc-T-describe)
426 )
427
428(defvar sc-mode-map ()
429 "Keymap for Supercite quasi-mode.")
430(if sc-mode-map
431 ()
432 (setq sc-mode-map (make-sparse-keymap))
433 (define-key sc-mode-map "c" 'sc-cite-region)
434 (define-key sc-mode-map "f" 'sc-mail-field-query)
435 (define-key sc-mode-map "g" 'sc-mail-process-headers)
436 (define-key sc-mode-map "h" 'sc-describe)
437 (define-key sc-mode-map "i" 'sc-insert-citation)
438 (define-key sc-mode-map "o" 'sc-open-line)
439 (define-key sc-mode-map "r" 'sc-recite-region)
440 (define-key sc-mode-map "\C-p" 'sc-raw-mode-toggle)
441 (define-key sc-mode-map "u" 'sc-uncite-region)
442 (define-key sc-mode-map "v" 'sc-version)
443 (define-key sc-mode-map "w" 'sc-insert-reference)
444 (define-key sc-mode-map "\C-t" sc-T-keymap)
445 (define-key sc-mode-map "\C-b" 'sc-submit-bug-report)
446 (define-key sc-mode-map "?" 'sc-describe)
447 )
448
449(defvar sc-electric-mode-map ()
450 "Keymap for `sc-electric-mode' electric references mode.")
451(if sc-electric-mode-map
452 nil
453 (setq sc-electric-mode-map (make-sparse-keymap))
454 (define-key sc-electric-mode-map "p" 'sc-eref-prev)
455 (define-key sc-electric-mode-map "n" 'sc-eref-next)
456 (define-key sc-electric-mode-map "s" 'sc-eref-setn)
457 (define-key sc-electric-mode-map "j" 'sc-eref-jump)
458 (define-key sc-electric-mode-map "x" 'sc-eref-abort)
459 (define-key sc-electric-mode-map "q" 'sc-eref-abort)
460 (define-key sc-electric-mode-map "\r" 'sc-eref-exit)
461 (define-key sc-electric-mode-map "\n" 'sc-eref-exit)
462 (define-key sc-electric-mode-map "g" 'sc-eref-goto)
463 (define-key sc-electric-mode-map "?" 'describe-mode)
464 (define-key sc-electric-mode-map "\C-h" 'describe-mode)
465 )
466
467(defvar sc-minibuffer-local-completion-map nil
468 "Keymap for minibuffer confirmation of attribution strings.")
469(if sc-minibuffer-local-completion-map
470 ()
471 (setq sc-minibuffer-local-completion-map
472 (copy-keymap minibuffer-local-completion-map))
473 (define-key sc-minibuffer-local-completion-map "\C-t" 'sc-toggle-fn)
474 (define-key sc-minibuffer-local-completion-map " " 'self-insert-command))
475
476(defvar sc-minibuffer-local-map nil
477 "Keymap for minibuffer confirmation of attribution strings.")
478(if sc-minibuffer-local-map
479 ()
480 (setq sc-minibuffer-local-map (copy-keymap minibuffer-local-map))
481 (define-key sc-minibuffer-local-map "\C-t" 'sc-toggle-fn))
482
483\f
484;; ======================================================================
485;; utility functions
486
487(defun sc-completing-read (prompt table &optional predicate require-match
488 initial-contents history)
489 "Compatibility between Emacs 18 and 19 `completing-read'.
490In version 18, the HISTORY argument is ignored."
491 (if (memq 'v19 sc-emacs-features)
492 (funcall 'completing-read prompt table predicate require-match
493 initial-contents history)
494 (funcall 'completing-read prompt table predicate require-match
495 (or (car-safe initial-contents)
496 initial-contents))))
497
498(defun sc-read-string (prompt &optional initial-contents history)
499 "Compatibility between Emacs 18 and 19 `read-string'.
500In version 18, the HISTORY argument is ignored."
501 (if (memq 'v19 sc-emacs-features)
08ffcab3
RS
502 ;; maybe future versions will take a `history' argument:
503 (read-string prompt initial-contents)
504 (read-string prompt initial-contents)))
30b7c745
RS
505
506(defun sc-submatch (matchnum &optional string)
507 "Returns `match-beginning' and `match-end' sub-expression for MATCHNUM.
508If optional STRING is provided, take sub-expression using `substring'
509of argument, otherwise use `buffer-substring' on current buffer. Note
510that `match-data' must have already been generated and no error
511checking is performed by this function."
512 (if string
513 (substring string (match-beginning matchnum) (match-end matchnum))
514 (buffer-substring (match-beginning matchnum) (match-end matchnum))))
515
516(defun sc-member (elt list)
517 "Like `memq', but uses `equal' instead of `eq'.
518Emacs19 has a builtin function `member' which does exactly this."
519 (catch 'elt-is-member
520 (while list
521 (if (equal elt (car list))
522 (throw 'elt-is-member list))
523 (setq list (cdr list)))))
524(and (memq 'v19 sc-emacs-features)
525 (fset 'sc-member 'member))
526
527(defun sc-ask (alist)
528 "Ask a question in the minibuffer requiring a single character answer.
529This function is kind of an extension of `y-or-n-p' where a single
530letter is used to answer a question. Question is formed from ALIST
531which has members of the form: (WORD . LETTER). WORD is the long
532word form, while LETTER is the letter for selecting that answer. The
533selected letter is returned, or nil if the question was not answered.
534Note that WORD is a string and LETTER is a character. All LETTERs in
535the list should be unique."
536 (let* ((prompt (concat
537 (mapconcat (function (lambda (elt) (car elt))) alist ", ")
538 "? ("
539 (mapconcat
540 (function
541 (lambda (elt) (char-to-string (cdr elt)))) alist "/")
542 ") "))
543 (p prompt)
544 (event
545 (if (memq 'Lucid sc-emacs-features)
546 (allocate-event)
547 nil)))
548 (while (stringp p)
549 (if (let ((cursor-in-echo-area t)
550 (inhibit-quit t))
551 (message "%s" p)
552 ;; lets be good neighbors and be compatible with all emacsen
553 (cond
554 ((memq 'v18 sc-emacs-features)
555 (setq event (read-char)))
556 ((memq 'Lucid sc-emacs-features)
557 (next-command-event event))
558 (t ; must be FSF19
559 (setq event (read-event))))
560 (prog1 quit-flag (setq quit-flag nil)))
561 (progn
562 (message "%s%s" p (single-key-description event))
563 (and (memq 'Lucid sc-emacs-features)
564 (deallocate-event event))
565 (setq quit-flag nil)
566 (signal 'quit '())))
567 (let ((char
568 (if (memq 'Lucid sc-emacs-features)
569 (let* ((key (and (key-press-event-p event) (event-key event)))
570 (char (and key (event-to-character event))))
571 char)
572 event))
573 elt)
574 (if char (setq char (downcase char)))
575 (cond
576 ((setq elt (rassq char alist))
577 (message "%s%s" p (car elt))
578 (setq p (cdr elt)))
579 ((and (memq 'Lucid sc-emacs-features)
580 (button-release-event-p event)) ; ignore them
581 nil)
582 (t
583 (message "%s%s" p (single-key-description event))
584 (if (memq 'Lucid sc-emacs-features)
585 (ding nil 'y-or-n-p)
586 (ding))
587 (discard-input)
588 (if (eq p prompt)
589 (setq p (concat "Try again. " prompt)))))))
590 (and (memq 'Lucid sc-emacs-features)
591 (deallocate-event event))
592 p))
593
594(defun sc-scan-info-alist (alist)
595 "Find a match in the info alist that matches a regexp in ALIST."
596 (let ((sc-mumble "")
597 rtnvalue)
598 (while alist
599 (let* ((elem (car alist))
600 (infokey (car elem))
601 (infoval (sc-mail-field infokey))
602 (mlist (car (cdr elem))))
603 (while mlist
604 (let* ((ml-elem (car mlist))
605 (regexp (car ml-elem))
606 (thing (cdr ml-elem)))
607 (if (string-match regexp infoval)
608 ;; we found a match, time to return
609 (setq rtnvalue thing
610 mlist nil
611 alist nil)
612 ;; else we didn't find a match
613 (setq mlist (cdr mlist))
614 ))) ;end of mlist loop
615 (setq alist (cdr alist))
616 )) ;end of alist loop
617 rtnvalue))
618
619\f
620;; ======================================================================
621;; extract mail field information from headers in reply buffer
622
623;; holder variables for bc happiness
624(defvar sc-mail-headers-start nil
625 "Start of header fields.")
626(defvar sc-mail-headers-end nil
627 "End of header fields.")
628(defvar sc-mail-field-history nil
629 "For minibuffer completion on mail field queries.")
630(defvar sc-mail-field-modification-history nil
631 "For minibuffer completion on mail field modifications.")
632(defvar sc-mail-glom-frame
633 '((begin (setq sc-mail-headers-start (point)))
634 ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
635 ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
636 ("^$" (list 'abort '(step . 0)))
637 ("^[ \t]+" (sc-mail-append-field))
638 (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
639 (end (setq sc-mail-headers-end (point))))
640 "Regi frame for glomming mail header information.")
641
642;; regi functions
643(defun sc-mail-fetch-field (&optional attribs-p)
644 "Insert a key and value into `sc-mail-info' alist.
645If optional ATTRIBS-P is non-nil, the key/value pair is placed in
646`sc-attributions' too."
647 (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline)
648 (let* ((key (downcase (sc-submatch 1 curline)))
649 (val (sc-submatch 2 curline))
650 (keyval (cons key val)))
651 (setq sc-mail-info (cons keyval sc-mail-info))
652 (if attribs-p
653 (setq sc-attributions (cons keyval sc-attributions)))
654 ))
655 nil)
656
657(defun sc-mail-append-field ()
658 "Append a continuation line onto the last fetched mail field's info."
659 (let ((keyval (car sc-mail-info)))
660 (if (and keyval (string-match "^\\s *\\(.*\\)$" curline))
661 (setcdr keyval (concat (cdr keyval) " " (sc-submatch 1 curline)))))
662 nil)
663
664(defun sc-mail-error-in-mail-field ()
665 "Issue warning that mail headers don't conform to RFC 822."
666 (let* ((len (min (length curline) 10))
667 (ellipsis (if (< len (length curline)) "..." ""))
668 (msg "Mail header \"%s%s\" doesn't conform to RFC 822. skipping..."))
669 (message msg (substring curline 0 len) ellipsis))
670 (beep)
671 (sit-for 2)
672 nil)
673
674;; mail header nuking
675(defvar sc-mail-last-header-nuked-p nil
676 "True if the last header was nuked.")
677
678(defun sc-mail-nuke-line ()
679 "Nuke the current mail header line."
680 (delete-region (regi-pos 'bol) (regi-pos 'bonl))
681 '((step . -1)))
682
683(defun sc-mail-nuke-header-line ()
684 "Delete current-line and set up for possible continuation."
685 (setq sc-mail-last-header-nuked-p t)
686 (sc-mail-nuke-line))
687
688(defun sc-mail-nuke-continuation-line ()
689 "Delete a continuation line if the last header line was deleted."
690 (if sc-mail-last-header-nuked-p
691 (sc-mail-nuke-line)))
692
693(defun sc-mail-cleanup-blank-lines ()
694 "Leave some blank lines after original mail headers are nuked.
695The number of lines left is specified by `sc-blank-lines-after-headers'."
696 (if sc-blank-lines-after-headers
697 (save-restriction
698 (widen)
699 (skip-chars-backward " \t\n")
700 (forward-line 1)
701 (delete-blank-lines)
702 (beginning-of-line)
703 (if (looking-at "[ \t]*$")
704 (delete-region (regi-pos 'bol) (regi-pos 'bonl)))
705 (insert-char ?\n sc-blank-lines-after-headers)))
706 nil)
707
708(defun sc-mail-build-nuke-frame ()
709 "Build the regiframe for nuking mail headers."
710 (let (every-func entry-func nonentry-func)
711 (cond
712 ((eq sc-nuke-mail-headers 'all)
713 (setq every-func '(progn (forward-line -1) (sc-mail-nuke-line))))
714 ((eq sc-nuke-mail-headers 'specified)
715 (setq entry-func '(sc-mail-nuke-header-line)
716 nonentry-func '(setq sc-mail-last-header-nuked-p nil)))
717 ((eq sc-nuke-mail-headers 'keep)
718 (setq entry-func '(setq sc-mail-last-header-nuked-p nil)
719 nonentry-func '(sc-mail-nuke-header-line)))
720 ;; we never get far enough to interpret a frame if s-n-m-h == 'none
721 ((eq sc-nuke-mail-headers 'none))
722 (t (error "Illegal value for sc-nuke-mail-headers: %s"
723 sc-nuke-mail-headers))
724 ) ; end-cond
725 (append
726 (and entry-func
727 (regi-mapcar sc-nuke-mail-header-list entry-func nil t))
728 (and nonentry-func (list (list "^\\S +:.*$" nonentry-func)))
729 (and (not every-func)
730 '(("^[ \t]+" (sc-mail-nuke-continuation-line))))
731 '((begin (setq sc-mail-last-header-zapped-p nil)))
732 '((end (sc-mail-cleanup-blank-lines)))
733 (and every-func (list (list 'every every-func)))
734 )))
735
736;; mail processing and zapping. this is the top level entry defun to
737;; all header processing.
738(defun sc-mail-process-headers (start end)
739 "Process original mail message's mail headers.
740After processing, mail headers may be nuked. Header information is
741stored in `sc-mail-info', and any old information is lost unless an
742error occurs."
743 (interactive "r")
744 (let ((info (copy-alist sc-mail-info))
745 (attribs (copy-alist sc-attributions)))
746 (setq sc-mail-info nil
747 sc-attributions nil)
748 (regi-interpret sc-mail-glom-frame start end)
749 (if (null sc-mail-info)
750 (progn
751 (message "No mail headers found! Restoring old information.")
752 (setq sc-mail-info info
753 sc-attributions attribs))
754 (regi-interpret (sc-mail-build-nuke-frame)
755 sc-mail-headers-start sc-mail-headers-end)
756 )))
757
758\f
759;; let the user change mail field information
760(defun sc-mail-field (field)
761 "Return the mail header field value associated with FIELD.
762If there was no mail header with FIELD as its key, return the value of
763`sc-mumble'. FIELD is case insensitive."
764 (or (cdr (assoc (downcase field) sc-mail-info)) sc-mumble))
765
766(defun sc-mail-field-query (arg)
767 "View the value of a mail field.
768With `\\[universal-argument]', prompts for action on mail field.
769Action can be one of: View, Modify, Add, or Delete."
770 (interactive "P")
771 (let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d)))
772 (action (if (not arg) ?v (sc-ask alist)))
773 key)
774 (if (not action)
775 ()
776 (setq key (sc-completing-read
777 (concat (car (rassq action alist))
778 " information key: ")
779 sc-mail-info nil
780 (if (eq action ?a) nil 'noexit)
781 nil 'sc-mail-field-history))
782 (cond
783 ((eq action ?v)
784 (message "%s: %s" key (cdr (assoc key sc-mail-info))))
785 ((eq action ?d)
786 (setq sc-mail-info (delq (assoc key sc-mail-info) sc-mail-info)))
787 ((eq action ?m)
788 (let ((keyval (assoc key sc-mail-info)))
789 ;; first put initial value onto list if not already there
790 (if (not (sc-member (cdr keyval)
791 sc-mail-field-modification-history))
792 (setq sc-mail-field-modification-history
793 (cons (cdr keyval) sc-mail-field-modification-history)))
794 (setcdr keyval (sc-read-string
795 (concat key ": ") (cdr keyval)
796 'sc-mail-field-modification-history))))
797 ((eq action ?a)
798 (setq sc-mail-info
799 (cons (cons key
800 (sc-read-string (concat key ": "))) sc-mail-info)))
801 ))))
802
803\f
804;; ======================================================================
805;; attributions
806
807(defvar sc-attribution-confirmation-history nil
808 "History for confirmation of attribution strings.")
809(defvar sc-citation-confirmation-history nil
810 "History for confirmation of attribution prefixes.")
811
812(defun sc-attribs-%@-addresses (from &optional delim)
813 "Extract the author's email terminus from email address FROM.
814Match addresses of the style ``name%[stuff].'' when called with DELIM
815of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when
816called with DELIM \"@\". If DELIM is nil or not provided, matches
817addresses of the style ``name''."
818 (and (string-match (concat "[-a-zA-Z0-9_.]+" delim) from 0)
819 (substring from
820 (match-beginning 0)
821 (- (match-end 0) (if (null delim) 0 1)))))
822
823(defun sc-attribs-!-addresses (from)
824 "Extract the author's email terminus from email address FROM.
825Match addresses of the style ``[stuff]![stuff]...!name[stuff].''"
826 (let ((eos (length from))
827 (mstart (string-match "![-a-zA-Z0-9_.]+\\([^-!a-zA-Z0-9_.]\\|$\\)"
828 from 0))
829 (mend (match-end 0)))
830 (and mstart
831 (substring from (1+ mstart) (- mend (if (= mend eos) 0 1)))
832 )))
833
834(defun sc-attribs-<>-addresses (from)
835 "Extract the author's email terminus from email address FROM.
836Match addresses of the style ``<name[stuff]>.''"
837 (and (string-match "<\\(.*\\)>" from)
838 (sc-submatch 1 from)))
839
840(defun sc-get-address (from author)
841 "Get the full email address path from FROM.
842AUTHOR is the author's name (which is removed from the address)."
843 (let ((eos (length from)))
844 (if (string-match (concat "\\(^\\|^\"\\)" author
845 "\\(\\s +\\|\"\\s +\\)") from 0)
846 (let ((address (substring from (match-end 0) eos)))
847 (if (and (= (aref address 0) ?<)
848 (= (aref address (1- (length address))) ?>))
849 (substring address 1 (1- (length address)))
850 address))
851 (if (string-match "[-a-zA-Z0-9!@%._]+" from 0)
852 (sc-submatch 0 from)
853 "")
854 )))
855
856(defun sc-attribs-emailname (from)
857 "Get the email terminus name from FROM."
858 (or
859 (sc-attribs-%@-addresses from "%")
860 (sc-attribs-%@-addresses from "@")
861 (sc-attribs-!-addresses from)
862 (sc-attribs-<>-addresses from)
863 (sc-attribs-%@-addresses from)
864 (substring from 0 10)))
865
866(defun sc-name-substring (string start end extend)
867 "Extract the specified substring of STRING from START to END.
868EXTEND is the number of characters on each side to extend the
869substring."
870 (and start
871 (let ((sos (+ start extend))
872 (eos (- end extend)))
873 (substring string sos
874 (or (string-match sc-titlecue-regexp string sos) eos)
875 ))))
876
877(defun sc-attribs-extract-namestring (from)
878 "Extract the name string from FROM.
879This should be the author's full name minus an optional title."
880 (let ((namestring
881 (or
882 (sc-name-substring
883 from (string-match "(.*)" from 0) (match-end 0) 1)
884 (sc-name-substring
885 from (string-match "\".*\"" from 0) (match-end 0) 1)
886 (sc-name-substring
887 from (string-match "\\([-.a-zA-Z0-9_]+\\s +\\)+<" from 0)
888 (match-end 1) 0)
889 (sc-attribs-emailname from))))
890 ;; strip off any leading or trailing whitespace
891 (if namestring
892 (let ((bos 0)
893 (eos (1- (length namestring))))
894 (while (and (<= bos eos)
895 (memq (aref namestring bos) '(32 ?\t)))
896 (setq bos (1+ bos)))
897 (while (and (> eos bos)
898 (memq (aref namestring eos) '(32 ?\t)))
899 (setq eos (1- eos)))
900 (substring namestring bos (1+ eos))))))
901
902(defun sc-attribs-chop-namestring (namestring)
903 "Convert NAMESTRING to a list of names.
904example: (sc-namestring-to-list \"John Xavier Doe\")
905 => (\"John\" \"Xavier\" \"Doe\")"
906 (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring)
907 (cons (sc-submatch 2 namestring)
908 (sc-attribs-chop-namestring (substring namestring (match-end 3)))
909 )))
910
911(defun sc-attribs-strip-initials (namelist)
912 "Extract the author's initials from the NAMELIST."
913 (mapconcat
914 (function
915 (lambda (name)
916 (if (< 0 (length name))
917 (substring name 0 1))))
918 namelist ""))
919
920(defun sc-guess-attribution (&optional string)
921 "Guess attribution string on current line.
922If attribution cannot be guessed, nil is returned. Optional STRING if
923supplied, is used instead of the line point is on in the current buffer."
924 (let ((start 0)
925 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol))))
926 attribution)
927 (and
928 (= start (or (string-match sc-citation-leader-regexp string start) -1))
929 (setq start (match-end 0))
930 (= start (or (string-match sc-citation-root-regexp string start) 1))
931 (setq attribution (sc-submatch 0 string)
932 start (match-end 0))
933 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
934 (setq start (match-end 0))
935 (= start (or (string-match sc-citation-separator-regexp string start) -1))
936 attribution)))
937
938(defun sc-attribs-filter-namelist (namelist)
939 "Filter out noise in NAMELIST according to `sc-name-filter-alist'."
940 (let ((elements (length namelist))
941 (position -1)
942 keepers filtered-list)
943 (mapcar
944 (function
945 (lambda (name)
946 (setq position (1+ position))
947 (let ((keep-p t))
948 (mapcar
949 (function
950 (lambda (filter)
951 (let ((regexp (car filter))
952 (pos (cdr filter)))
953 (if (and (string-match regexp name)
954 (or (and (numberp pos)
955 (= pos position))
956 (and (eq pos 'last)
957 (= position (1- elements)))
958 (eq pos 'any)))
959 (setq keep-p nil))
960 )))
961 sc-name-filter-alist)
962 (if keep-p
963 (setq keepers (cons position keepers)))
964 )))
965 namelist)
966 (mapcar
967 (function
968 (lambda (position)
969 (setq filtered-list (cons (nth position namelist) filtered-list))
970 ))
971 keepers)
972 filtered-list))
973
974(defun sc-attribs-chop-address (from)
975 "Extract attribution information from FROM.
976This populates the `sc-attributions' with the list of possible attributions."
977 (if (and (stringp from)
978 (< 0 (length from)))
979 (let* ((sc-mumble "")
980 (namestring (sc-attribs-extract-namestring from))
981 (namelist (sc-attribs-filter-namelist
982 (sc-attribs-chop-namestring namestring)))
983 (revnames (reverse (cdr namelist)))
984 (firstname (car namelist))
985 (midnames (reverse (cdr revnames)))
986 (lastname (car revnames))
987 (initials (sc-attribs-strip-initials namelist))
988 (emailname (sc-attribs-emailname from))
989 (n 1)
990 author middlenames)
991
992 ;; put basic information
993 (setq
994 ;; put middle names and build sc-author entry
995 middlenames (mapconcat
996 (function
997 (lambda (midname)
998 (let ((key-attribs (format "middlename-%d" n))
999 (key-mail (format "sc-middlename-%d" n)))
1000 (setq
1001 sc-attributions (cons (cons key-attribs midname)
1002 sc-attributions)
1003 sc-mail-info (cons (cons key-mail midname)
1004 sc-mail-info)
1005 n (1+ n))
1006 midname)))
1007 midnames " ")
1008
1009 author (concat firstname " " middlenames (and midnames " ") lastname)
1010
1011 sc-attributions (append
1012 (list
1013 (cons "firstname" firstname)
1014 (cons "lastname" lastname)
1015 (cons "emailname" emailname)
1016 (cons "initials" initials))
1017 sc-attributions)
1018 sc-mail-info (append
1019 (list
1020 (cons "sc-firstname" firstname)
1021 (cons "sc-middlenames" middlenames)
1022 (cons "sc-lastname" lastname)
1023 (cons "sc-emailname" emailname)
1024 (cons "sc-initials" initials)
1025 (cons "sc-author" author)
1026 (cons "sc-from-address" (sc-get-address
1027 (sc-mail-field "from")
1028 namestring))
1029 (cons "sc-reply-address" (sc-get-address
1030 (sc-mail-field "reply-to")
1031 namestring))
1032 (cons "sc-sender-address" (sc-get-address
1033 (sc-mail-field "sender")
1034 namestring))
1035 )
1036 sc-mail-info)
1037 ))
1038 ;; from string is empty
1039 (setq sc-mail-info (cons (cons "sc-author" sc-default-author-name)
1040 sc-mail-info))))
1041
1042(defvar sc-attrib-or-cite nil
1043 "Used to toggle between attribution input or citation input.")
1044
1045(defun sc-toggle-fn ()
1046 "Toggle between attribution selection and citation selection.
1047Only used during confirmation."
1048 (interactive)
1049 (setq sc-attrib-or-cite (not sc-attrib-or-cite))
1050 (throw 'sc-reconfirm t))
1051
1052(defun sc-select-attribution ()
1053 "Select an attribution from `sc-attributions'.
1054
1055Variables involved in selection process include:
1056 `sc-preferred-attribution-list'
1057 `sc-use-only-preference-p'
1058 `sc-confirm-always-p'
1059 `sc-default-attribution'
1060 `sc-attrib-selection-list'.
1061
1062Runs the hook `sc-attribs-preselect-hook' before selecting an
1063attribution and the hook `sc-attribs-postselect-hook' after making the
1064selection but before querying is performed. During
1065`sc-attribs-postselect-hook' the variable `citation' is bound to the
1066auto-selected citation string and the variable `attribution' is bound
1067to the auto-selected attribution string."
1068 (run-hooks 'sc-attribs-preselect-hook)
1069 (let ((query-p sc-confirm-always-p)
1070 attribution citation
1071 (attriblist sc-preferred-attribution-list))
1072
1073 ;; first cruise through sc-preferred-attribution-list looking for
1074 ;; a match in either sc-attributions or sc-mail-info. if the
1075 ;; element is "sc-consult", then we have to do the alist
1076 ;; consultation phase
1077 (while attriblist
1078 (let* ((preferred (car attriblist)))
1079 (cond
1080 ((string= preferred "sc-consult")
1081 ;; we've been told to consult the attribution vs. mail
1082 ;; header key alist. we do this until we find a match in
1083 ;; the sc-attrib-selection-list. if we do not find a match,
1084 ;; we continue scanning attriblist
1085 (let ((attrib (sc-scan-info-alist sc-attrib-selection-list)))
1086 (cond
1087 ((not attrib)
1088 (setq attriblist (cdr attriblist)))
1089 ((stringp attrib)
1090 (setq attribution attrib
1091 attriblist nil))
1092 ((listp attrib)
1093 (setq attribution (eval attrib)
1094 attriblist nil))
1095 (t (error "%s did not evaluate to a string or list!"
1096 "sc-attrib-selection-list"))
1097 )))
1098 ((setq attribution (cdr (assoc preferred sc-attributions)))
1099 (setq attriblist nil))
1100 (t
1101 (setq attriblist (cdr attriblist)))
1102 )))
1103
1104 ;; if preference was not found, we may use a secondary method to
1105 ;; find a valid attribution
1106 (if (and (not attribution)
1107 (not sc-use-only-preference-p))
1108 ;; secondary method tries to find a preference in this order
1109 ;; 1. sc-lastchoice
1110 ;; 2. x-attribution
1111 ;; 3. firstname
1112 ;; 4. lastname
1113 ;; 5. initials
1114 ;; 6. first non-empty attribution in alist
1115 (setq attribution
1116 (or (cdr (assoc "sc-lastchoice" sc-attributions))
1117 (cdr (assoc "x-attribution" sc-attributions))
1118 (cdr (assoc "firstname" sc-attributions))
1119 (cdr (assoc "lastname" sc-attributions))
1120 (cdr (assoc "initials" sc-attributions))
1121 (cdr (car sc-attributions)))))
1122
1123 ;; still couldn't find an attribution. we're now limited to using
1124 ;; the default attribution, but we'll force a query when this happens
1125 (if (not attribution)
1126 (setq attribution sc-default-attribution
1127 query-p t))
1128
1129 ;; create the attribution prefix
1130 (setq citation (sc-make-citation attribution))
1131
1132 ;; run the post selection hook before querying the user
1133 (run-hooks 'sc-attribs-postselect-hook)
1134
1135 ;; query for confirmation
1136 (if query-p
1137 (let* ((query-alist (mapcar (function (lambda (entry)
1138 (list (cdr entry))))
1139 sc-attributions))
1140 (minibuffer-local-completion-map
1141 sc-minibuffer-local-completion-map)
1142 (minibuffer-local-map sc-minibuffer-local-map)
1143 (initial attribution)
1144 (completer-disable t) ; in case completer.el is used
1145 choice)
1146 (setq sc-attrib-or-cite nil) ; nil==attribution, t==citation
1147 (while
1148 (catch 'sc-reconfirm
1149 (string= "" (setq choice
1150 (if sc-attrib-or-cite
1151 (sc-read-string
1152 "Enter citation prefix: "
1153 citation
1154 'sc-citation-confirmation-history)
1155 (sc-completing-read
1156 "Complete attribution name: "
1157 query-alist nil nil
1158 (cons initial 0)
1159 'sc-attribution-confirmation-history)
1160 )))))
1161 (if sc-attrib-or-cite
1162 ;; since the citation was chosen, we have to guess at
1163 ;; the attribution
1164 (setq citation choice
1165 attribution (or (sc-guess-attribution citation)
1166 citation))
1167
1168 (setq citation (sc-make-citation choice)
1169 attribution choice))
1170 ))
1171
1172 ;; its possible that the user wants to downcase the citation and
1173 ;; attribution
1174 (if sc-downcase-p
1175 (setq citation (downcase citation)
1176 attribution (downcase attribution)))
1177
1178 ;; set up mail info alist
1179 (let* ((ckey "sc-citation")
1180 (akey "sc-attribution")
1181 (ckeyval (assoc ckey sc-mail-info))
1182 (akeyval (assoc akey sc-mail-info)))
1183 (if ckeyval
1184 (setcdr ckeyval citation)
1185 (setq sc-mail-info
1186 (append (list (cons ckey citation)) sc-mail-info)))
1187 (if akeyval
1188 (setcdr akeyval attribution)
1189 (setq sc-mail-info
1190 (append (list (cons akey attribution)) sc-mail-info))))
1191
1192 ;; set the sc-lastchoice attribution
1193 (let* ((lkey "sc-lastchoice")
1194 (lastchoice (assoc lkey sc-attributions)))
1195 (if lastchoice
1196 (setcdr lastchoice attribution)
1197 (setq sc-attributions
1198 (cons (cons lkey attribution) sc-attributions))))
1199 ))
1200
1201\f
1202;; ======================================================================
1203;; filladapt hooks for supercite 3.1. you shouldn't need anything
1204;; extra to make gin-mode understand supercited lines. Even this
1205;; stuff might not be entirely necessary...
1206
1207(defun sc-cite-regexp (&optional root-regexp)
1208 "Return a regexp describing a Supercited line.
1209The regexp is the concatenation of `sc-citation-leader-regexp',
1210`sc-citation-root-regexp', `sc-citation-delimiter-regexp', and
1211`sc-citation-separator-regexp'. If optional ROOT-REGEXP is supplied,
1212use it instead of `sc-citation-root-regexp'."
1213 (concat sc-citation-leader-regexp
1214 (or root-regexp sc-citation-root-regexp)
1215 sc-citation-delimiter-regexp
1216 sc-citation-separator-regexp))
1217
1218(defun sc-make-citation (attribution)
1219 "Make a non-nested citation from ATTRIBUTION."
1220 (concat sc-citation-leader
1221 attribution
1222 sc-citation-delimiter
1223 sc-citation-separator))
1224
1225(defun sc-setup-filladapt ()
1226 "Setup `filladapt-prefix-table' to handle Supercited paragraphs."
1227 (let* ((fa-sc-elt 'filladapt-supercite-included-text)
1228 (elt (rassq fa-sc-elt filladapt-prefix-table)))
1229 (if elt (setcar elt (sc-cite-regexp))
1230 (message "Filladapt doesn't seem to know about Supercite.")
1231 (beep))))
1232
1233\f
1234;; ======================================================================
1235;; citing and unciting regions of text
1236
1237(defvar sc-fill-begin 1
1238 "Buffer position to begin filling.")
1239(defvar sc-fill-line-prefix ""
1240 "Fill prefix of previous line")
1241
1242;; filling
1243(defun sc-fill-if-different (&optional prefix)
1244 "Fill the region bounded by `sc-fill-begin' and point.
1245Only fill if optional PREFIX is different than `sc-fill-line-prefix'.
1246If `sc-auto-fill-region-p' is nil, do not fill region. If PREFIX is
1247not supplied, initialize fill variables. This is useful for a regi
1248`begin' frame-entry."
1249 (if (not prefix)
1250 (setq sc-fill-line-prefix ""
1251 sc-fill-begin (regi-pos 'bol))
1252 (if (and sc-auto-fill-region-p
1253 (not (string= prefix sc-fill-line-prefix)))
1254 (let ((fill-prefix sc-fill-line-prefix))
1255 (if (not (string= fill-prefix ""))
1256 (fill-region sc-fill-begin (regi-pos 'bol)))
1257 (setq sc-fill-line-prefix prefix
1258 sc-fill-begin (regi-pos 'bol))))
1259 )
1260 nil)
1261
1262(defun sc-cite-coerce-cited-line ()
1263 "Coerce a Supercited line to look like our style."
1264 (let* ((attribution (sc-guess-attribution))
1265 (regexp (sc-cite-regexp attribution))
1266 (prefix (sc-make-citation attribution)))
1267 (if (and attribution
1268 (looking-at regexp))
1269 (progn
1270 (delete-region
1271 (match-beginning 0)
1272 (save-excursion
1273 (goto-char (match-end 0))
1274 (if (bolp) (forward-char -1))
1275 (point)))
1276 (insert prefix)
1277 (sc-fill-if-different prefix)))
1278 nil))
1279
1280(defun sc-cite-coerce-dumb-citer ()
1281 "Coerce a non-nested citation that's been cited with a dumb nesting citer."
1282 (delete-region (match-beginning 1) (match-end 1))
1283 (beginning-of-line)
1284 (sc-cite-coerce-cited-line))
1285
1286(defun sc-guess-nesting (&optional string)
1287 "Guess the citation nesting on the current line.
1288If nesting cannot be guessed, nil is returned. Optional STRING if
1289supplied, is used instead of the line point is on in the current
1290buffer."
1291 (let ((start 0)
1292 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol))))
1293 nesting)
1294 (and
1295 (= start (or (string-match sc-citation-leader-regexp string start) -1))
1296 (setq start (match-end 0))
1297 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
1298 (setq nesting (sc-submatch 0 string)
1299 start (match-end 0))
1300 (= start (or (string-match sc-citation-separator-regexp string start) -1))
1301 nesting)))
1302
1303(defun sc-add-citation-level ()
1304 "Add a citation level for nested citation style w/ coersion."
1305 (let* ((nesting (sc-guess-nesting))
1306 (citation (make-string (1+ (length nesting))
1307 (string-to-char sc-citation-delimiter)))
1308 (prefix (concat sc-citation-leader citation sc-citation-separator)))
1309 (if (looking-at (sc-cite-regexp ""))
1310 (delete-region (match-beginning 0) (match-end 0)))
1311 (insert prefix)
1312 (sc-fill-if-different prefix)))
1313
1314(defun sc-cite-line (&optional citation)
1315 "Cite a single line of uncited text.
1316Optional CITATION overrides any citation automatically selected."
1317 (if sc-fixup-whitespace-p
1318 (fixup-whitespace))
1319 (let ((prefix (or citation
1320 (cdr (assoc "sc-citation" sc-mail-info))
1321 sc-default-attribution)))
1322 (insert prefix)
1323 (sc-fill-if-different prefix))
1324 nil)
1325
1326(defun sc-uncite-line ()
1327 "Remove citation from current line."
1328 (let ((cited (looking-at (sc-cite-regexp))))
1329 (if cited
1330 (delete-region (match-beginning 0) (match-end 0))))
1331 nil)
1332
1333(defun sc-recite-line (regexp)
1334 "Remove citation matching REGEXP from current line and recite line."
1335 (let ((cited (looking-at (concat "^" regexp)))
1336 (prefix (cdr (assoc "sc-citation" sc-mail-info))))
1337 (if cited
1338 (delete-region (match-beginning 0) (match-end 0)))
1339 (insert (or prefix sc-default-attribution))
1340 (sc-fill-if-different prefix))
1341 nil)
1342
1343;; interactive functions
1344(defun sc-cite-region (start end &optional confirm-p)
1345 "Cite a region delineated by START and END.
1346If optional CONFIRM-P is non-nil, the attribution is confirmed before
1347its use in the citation string. This function first runs
1348`sc-pre-cite-hook'."
1349 (interactive "r\nP")
1350 (undo-boundary)
1351 (let ((frame (or (sc-scan-info-alist sc-cite-frame-alist)
1352 sc-default-cite-frame))
1353 (sc-confirm-always-p (if confirm-p t sc-confirm-always-p)))
1354 (run-hooks 'sc-pre-cite-hook)
1355 (if (interactive-p)
1356 (sc-select-attribution))
1357 (regi-interpret frame start end)))
1358
1359(defun sc-uncite-region (start end)
1360 "Uncite a region delineated by START and END.
1361First runs `sc-pre-uncite-hook'."
1362 (interactive "r")
1363 (undo-boundary)
1364 (let ((frame (or (sc-scan-info-alist sc-uncite-frame-alist)
1365 sc-default-uncite-frame)))
1366 (run-hooks 'sc-pre-uncite-hook)
1367 (regi-interpret frame start end)))
1368
1369(defun sc-recite-region (start end)
1370 "Recite a region delineated by START and END.
1371First runs `sc-pre-recite-hook'."
1372 (interactive "r")
1373 (let ((sc-confirm-always-p t))
1374 (sc-select-attribution))
1375 (undo-boundary)
1376 (let ((frame (or (sc-scan-info-alist sc-recite-frame-alist)
1377 sc-default-recite-frame)))
1378 (run-hooks 'sc-pre-recite-hook)
1379 (regi-interpret frame start end)))
1380
1381\f
1382;; ======================================================================
1383;; building headers
1384
1385(defun sc-hdr (prefix field &optional sep return-nil-p)
1386 "Returns a concatenation of PREFIX and FIELD.
1387If FIELD is not a string or is the empty string, the empty string will
1388be returned. Optional third argument SEP is concatenated on the end if
1389it is a string. Returns empty string, unless optional RETURN-NIL-P is
1390non-nil."
1391 (if (and (stringp field)
1392 (not (string= field "")))
1393 (concat prefix field (or sep ""))
1394 (and (not return-nil-p) "")))
1395
1396(defun sc-whofrom ()
1397 "Return the value of (sc-mail-field \"from\") or nil."
1398 (let ((sc-mumble nil))
1399 (sc-mail-field "from")))
1400
1401(defun sc-no-header ()
1402 "Does nothing. Use this instead of nil to get a blank header."
1403 ())
1404
1405(defun sc-no-blank-line-or-header()
1406 "Similar to `sc-no-header' except it removes the preceeding blank line."
1407 (if (not (bobp))
1408 (if (and (eolp)
1409 (progn (forward-line -1)
1410 (or (looking-at mail-header-separator)
1411 (and (eq major-mode 'mh-letter-mode)
1412 (mh-in-header-p)))))
1413 (progn (forward-line)
1414 (let ((kill-lines-magic t))
1415 (kill-line))))))
1416
1417(defun sc-header-on-said ()
1418 "\"On <date>, <from> said:\" unless:
14191. the \"from\" field cannot be found, in which case nothing is inserted;
14202. the \"date\" field is missing in which case only the from part is printed."
1421 (let ((sc-mumble "")
1422 (whofrom (sc-whofrom)))
1423 (if whofrom
1424 (insert sc-reference-tag-string
1425 (sc-hdr "On " (sc-mail-field "date") ", ")
1426 whofrom " said:\n"))))
1427
1428(defun sc-header-inarticle-writes ()
1429 "\"In article <message-id>, <from> writes:\"
1430Treats \"message-id\" and \"from\" fields similar to `sc-header-on-said'."
1431 (let ((sc-mumble "")
1432 (whofrom (sc-mail-field "from")))
1433 (if whofrom
1434 (insert sc-reference-tag-string
1435 (sc-hdr "In article " (sc-mail-field "message-id") ", ")
1436 whofrom " writes:\n"))))
1437
1438(defun sc-header-regarding-adds ()
1439 "\"Regarding <subject>; <from> adds:\"
1440Treats \"subject\" and \"from\" fields similar to `sc-header-on-said'."
1441 (let ((sc-mumble "")
1442 (whofrom (sc-whofrom)))
1443 (if whofrom
1444 (insert sc-reference-tag-string
1445 (sc-hdr "Regarding " (sc-mail-field "subject") "; ")
1446 whofrom " adds:\n"))))
1447
1448(defun sc-header-attributed-writes ()
1449 "\"<sc-attribution>\" == <sc-author> <address> writes:
1450Treats these fields in a similar manner to `sc-header-on-said'."
1451 (let ((sc-mumble "")
1452 (whofrom (sc-whofrom)))
1453 (if whofrom
1454 (insert sc-reference-tag-string
1455 (sc-hdr "\"" (sc-mail-field "sc-attribution") "\" == ")
1456 (sc-hdr "" (sc-mail-field "sc-author") " ")
1457 (or (sc-hdr "<" (sc-mail-field "sc-from-address") ">" t)
1458 (sc-hdr "<" (sc-mail-field "sc-reply-address") ">" t)
1459 "")
1460 " writes:\n"))))
1461
1462(defun sc-header-author-writes ()
1463 "<sc-author> writes:"
1464 (let ((sc-mumble "")
1465 (whofrom (sc-whofrom)))
1466 (if whofrom
1467 (insert sc-reference-tag-string
1468 (sc-hdr "" (sc-mail-field "sc-author"))
1469 " writes:\n"))))
1470
1471(defun sc-header-verbose ()
1472 "Very verbose, some say gross."
1473 (let ((sc-mumble "")
1474 (whofrom (sc-whofrom))
1475 (tag sc-reference-tag-string))
1476 (if whofrom
1477 (insert (sc-hdr (concat tag "On ") (sc-mail-field "date") ",\n")
1478 (or (sc-hdr tag (sc-mail-field "sc-author") "\n" t)
1479 (concat tag whofrom "\n"))
1480 (sc-hdr (concat tag "from the organization of ")
1481 (sc-mail-field "organization") "\n")
1482 (let ((rtag (concat tag "who can be reached at: ")))
1483 (or (sc-hdr rtag (sc-mail-field "sc-from-address") "\n" t)
1484 (sc-hdr rtag (sc-mail-field "sc-reply-address") "\n" t)
1485 ""))
1486 (sc-hdr
1487 (concat tag "(whose comments are cited below with \"")
1488 (sc-mail-field "sc-citation") "\"),\n")
1489 (sc-hdr (concat tag "had this to say in article ")
1490 (sc-mail-field "message-id") "\n")
1491 (sc-hdr (concat tag "in newsgroups ")
1492 (sc-mail-field "newsgroups") "\n")
1493 (sc-hdr (concat tag "concerning the subject of ")
1494 (sc-mail-field "subject") "\n")
1495 (sc-hdr (concat tag "(see ")
1496 (sc-mail-field "references")
1497 " for more details)\n")
1498 ))))
1499
1500\f
1501;; ======================================================================
1502;; header rewrites
1503
1504(defconst sc-electric-bufname " *sc-erefs* "
1505 "Supercite electric reference mode's buffer name.")
1506(defvar sc-eref-style 0
1507 "Current electric reference style.")
1508
1509(defun sc-valid-index-p (index)
1510 "Returns INDEX if it is a valid index into `sc-rewrite-header-list'.
1511Otherwise returns nil."
1512 ;; a number, and greater than or equal to zero
1513 ;; less than or equal to the last index
1514 (and (natnump index)
1515 (< index (length sc-rewrite-header-list))
1516 index))
1517
1518(defun sc-eref-insert-selected (&optional nomsg)
1519 "Insert the selected reference header in the current buffer.
1520Optional NOMSG, if non-nil, inhibits printing messages, unless an
1521error occurs."
1522 (let ((ref (nth sc-eref-style sc-rewrite-header-list)))
1523 (condition-case err
1524 (progn
1525 (eval ref)
1526 (let ((lines (count-lines (point-min) (point-max))))
1527 (or nomsg (message "Ref header %d [%d line%s]: %s"
1528 sc-eref-style lines
1529 (if (= lines 1) "" "s")
1530 ref))))
1531 (void-function
1532 (progn (message
1533 "Symbol's function definition is void: %s (Header %d)"
1534 (car (cdr err)) sc-eref-style)
1535 (beep)
1536 ))
1537 )))
1538
1539(defun sc-electric-mode (&optional arg)
1540 "
1541Mode for viewing Supercite reference headers. Commands are:
1542\n\\{sc-electric-mode-map}
1543
1544`sc-electric-mode' is not intended to be run interactively, but rather
1545accessed through Supercite's electric reference feature. See
1546`sc-insert-reference' for more details. Optional ARG is the initial
1547header style to use, unless not supplied or invalid, in which case
1548`sc-preferred-header-style' is used."
1549
1550 (let ((info sc-mail-info))
1551
1552 (setq sc-eref-style
1553 (or (sc-valid-index-p arg)
1554 (sc-valid-index-p sc-preferred-header-style)
1555 0))
1556
1557 (get-buffer-create sc-electric-bufname)
1558 ;; set up buffer and enter command loop
1559 (save-excursion
1560 (save-window-excursion
1561 (pop-to-buffer sc-electric-bufname)
1562 (kill-all-local-variables)
1563 (let ((sc-mail-info info)
1564 (buffer-read-only t)
1565 (mode-name "SC Electric Refs")
1566 (major-mode 'sc-electric-mode))
1567 (use-local-map sc-electric-mode-map)
1568 (sc-eref-show sc-eref-style)
1569 (run-hooks 'sc-electric-mode-hook)
1570 (recursive-edit)
1571 )))
1572
1573 (and sc-eref-style
1574 (sc-eref-insert-selected))
1575 (kill-buffer sc-electric-bufname)
1576 ))
1577
1578;; functions for electric reference mode
1579(defun sc-eref-show (index)
1580 "Show reference INDEX in `sc-rewrite-header-list'."
1581 (let ((msg "No %ing reference headers in list.")
1582 (last (length sc-rewrite-header-list)))
1583 (setq sc-eref-style
1584 (cond
1585 ((sc-valid-index-p index) index)
1586 ((< index 0)
1587 (if sc-electric-circular-p
1588 (1- last)
1589 (progn (error msg "preced") 0)))
1590 ((>= index last)
1591 (if sc-electric-circular-p
1592 0
1593 (progn (error msg "follow") (1- last))))
1594 ))
1595 (save-excursion
1596 (set-buffer sc-electric-bufname)
1597 (let ((buffer-read-only nil))
1598 (erase-buffer)
1599 (goto-char (point-min))
1600 (sc-eref-insert-selected)
1601 ;; now shrink the window to just contain the electric reference
1602 ;; header.
1603 (let ((hdrlines (count-lines (point-min) (point-max)))
1604 (winlines (1- (window-height))))
1605 (if (/= hdrlines winlines)
1606 (if (> hdrlines winlines)
1607 ;; we have to enlarge the window
1608 (enlarge-window (- hdrlines winlines))
1609 ;; we have to shrink the window
1610 (shrink-window (- winlines (max hdrlines window-min-height)))
1611 )))
1612 ))))
1613
1614(defun sc-eref-next ()
1615 "Display next reference in other buffer."
1616 (interactive)
1617 (sc-eref-show (1+ sc-eref-style)))
1618
1619(defun sc-eref-prev ()
1620 "Display previous reference in other buffer."
1621 (interactive)
1622 (sc-eref-show (1- sc-eref-style)))
1623
1624(defun sc-eref-setn ()
1625 "Set reference header selected as preferred."
1626 (interactive)
1627 (setq sc-preferred-header-style sc-eref-style)
1628 (message "Preferred reference style set to header %d." sc-eref-style))
1629
1630(defun sc-eref-goto (refnum)
1631 "Show reference style indexed by REFNUM.
1632If REFNUM is an invalid index, don't go to that reference and return
1633nil."
1634 (interactive "NGoto Reference: ")
1635 (if (sc-valid-index-p refnum)
1636 (sc-eref-show refnum)
1637 (error "Invalid reference: %d. (Range: [%d .. %d])"
1638 refnum 0 (1- (length sc-rewrite-header-list)))
1639 ))
1640
1641(defun sc-eref-jump ()
1642 "Set reference header to preferred header."
1643 (interactive)
1644 (sc-eref-show sc-preferred-header-style))
1645
1646(defun sc-eref-abort ()
1647 "Exit from electric reference mode without inserting reference."
1648 (interactive)
1649 (setq sc-eref-style nil)
1650 (exit-recursive-edit))
1651
1652(defun sc-eref-exit ()
1653 "Exit from electric reference mode and insert selected reference."
1654 (interactive)
1655 (exit-recursive-edit))
1656
1657(defun sc-insert-reference (arg)
1658 "Insert, at point, a reference header in the body of the reply.
1659Numeric ARG indicates which header style from `sc-rewrite-header-list'
1660to use when rewriting the header. No supplied ARG indicates use of
1661`sc-preferred-header-style'.
1662
1663With just `\\[universal-argument]', electric reference insert mode is
1664entered, regardless of the value of `sc-electric-references-p'. See
1665`sc-electric-mode' for more information."
1666 (interactive "P")
1667 (if (consp arg)
1668 (sc-electric-mode)
1669 (let ((preference (or (sc-valid-index-p arg)
1670 (sc-valid-index-p sc-preferred-header-style)
1671 sc-preferred-header-style
1672 0)))
1673 (if sc-electric-references-p
1674 (sc-electric-mode preference)
1675 (sc-eref-insert-selected t)
1676 ))))
1677
1678\f
1679;; ======================================================================
1680;; variable toggling
1681
1682(defun sc-raw-mode-toggle ()
1683 "Toggle, in one fell swoop, two important SC variables:
1684`sc-fixup-whitespace-p' and `sc-auto-fill-region-p'"
1685 (interactive)
1686 (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p)
1687 sc-auto-fill-region-p (not sc-auto-fill-region-p))
1688 (sc-set-mode-string)
1689 (set-buffer-modified-p (buffer-modified-p)))
1690
1691(defun sc-toggle-var (variable)
1692 "Boolean toggle VARIABLE's value.
1693VARIABLE must be a bound symbol. Nil values change to t, non-nil
1694values are changed to nil."
1695 (message "%s changed from %s to %s"
1696 variable (symbol-value variable)
1697 (set-variable variable (not (eval-expression variable))))
1698 (sc-set-mode-string))
1699
1700(defun sc-set-variable (var)
1701 "Set the Supercite VARIABLE.
1702This function mimics `set-variable', except that the variable to set
1703is determined non-interactively. The value is queried for in the
1704minibuffer exactly the same way that `set-variable' does it.
1705
1706You can see the current value of the variable when the minibuffer is
1707querying you by typing `C-h'. Note that the format is changed
1708slightly from that used by `set-variable' -- the current value is
1709printed just after the variable's name instead of at the bottom of the
1710help window."
1711 (let* ((minibuffer-help-form
1712 '(funcall myhelp))
1713 (myhelp
1714 (function
1715 (lambda ()
1716 (with-output-to-temp-buffer "*Help*"
1717 (prin1 var)
1718 (if (boundp var)
1719 (let ((print-length 20))
1720 (princ "\t(Current value: ")
1721 (prin1 (symbol-value var))
1722 (princ ")")))
1723 (princ "\n\nDocumentation:\n")
1724 (princ (substring (documentation-property
1725 var
1726 'variable-documentation)
1727 1))
5312cce7
KH
1728 (save-excursion
1729 (set-buffer standard-output)
1730 (help-mode))
30b7c745
RS
1731 nil)))))
1732 (set var (eval-minibuffer (format "Set %s to value: " var))))
1733 (sc-set-mode-string))
1734
1735(defmacro sc-toggle-symbol (rootname)
1736 (list 'defun (intern (concat "sc-T-" rootname)) '()
1737 (list 'interactive)
1738 (list 'sc-toggle-var
1739 (list 'quote (intern (concat "sc-" rootname "-p"))))))
1740
1741(defmacro sc-setvar-symbol (rootname)
1742 (list 'defun (intern (concat "sc-S-" rootname)) '()
1743 (list 'interactive)
1744 (list 'sc-set-variable
1745 (list 'quote (intern (concat "sc-" rootname))))))
1746
1747(sc-toggle-symbol "confirm-always")
1748(sc-toggle-symbol "downcase")
1749(sc-toggle-symbol "electric-references")
1750(sc-toggle-symbol "auto-fill-region")
1751(sc-toggle-symbol "mail-nuke-blank-lines")
1752(sc-toggle-symbol "nested-citation")
1753(sc-toggle-symbol "electric-circular")
1754(sc-toggle-symbol "use-only-preferences")
1755(sc-toggle-symbol "fixup-whitespace")
1756
1757(sc-setvar-symbol "preferred-attribution-list")
1758(sc-setvar-symbol "preferred-header-style")
1759(sc-setvar-symbol "mail-nuke-mail-headers")
1760(sc-setvar-symbol "mail-header-nuke-list")
1761(sc-setvar-symbol "cite-region-limit")
1762
1763(defun sc-T-describe ()
1764 "
1765
1766Supercite provides a number of key bindings which simplify the process
1767of setting or toggling certain variables controlling its operation.
1768
1769Note on function names in this list: all functions of the form
1770`sc-S-<name>' actually call `sc-set-variable' on the corresponding
1771`sc-<name>' variable. All functions of the form `sc-T-<name>' call
1772`sc-toggle-var' on the corresponding `sc-<name>-p' variable.
1773
1774\\{sc-T-keymap}"
1775 (interactive)
1776 (describe-function 'sc-T-describe))
1777
1778(defun sc-set-mode-string ()
1779 "Update the minor mode string to show state of Supercite."
1780 (setq sc-mode-string
1781 (concat " SC"
1782 (if (or sc-auto-fill-region-p
1783 sc-fixup-whitespace-p)
1784 ":" "")
1785 (if sc-auto-fill-region-p "f" "")
1786 (if sc-fixup-whitespace-p "w" "")
1787 )))
1788
1789\f
1790;; ======================================================================
1791;; published interface to mail and news readers
1792
80056f3d 1793;;;###autoload
30b7c745
RS
1794(defun sc-cite-original ()
1795 "Workhorse citing function which performs the initial citation.
1796This is callable from the various mail and news readers' reply
1797function according to the agreed upon standard. See `\\[sc-describe]'
1798for more details. `sc-cite-original' does not do any yanking of the
1799original message but it does require a few things:
1800
1801 1) The reply buffer is the current buffer.
1802
1803 2) The original message has been yanked and inserted into the
1804 reply buffer.
1805
1806 3) Verbose mail headers from the original message have been
1807 inserted into the reply buffer directly before the text of the
1808 original message.
1809
1810 4) Point is at the beginning of the verbose headers.
1811
1812 5) Mark is at the end of the body of text to be cited.
1813
1814For Emacs 19's, the region need not be active (and typically isn't
1815when this function is called. Also, the hook `sc-pre-hook' is run
1816before, and `sc-post-hook' is run after the guts of this function."
1817 (run-hooks 'sc-pre-hook)
1818
1819 ;; before we do anything, we want to insert the supercite keymap so
1820 ;; we can proceed from here
1821 (and sc-mode-map-prefix
1822 (local-set-key sc-mode-map-prefix sc-mode-map))
1823
1824 ;; hack onto the minor mode alist, if it hasn't been done before,
1825 ;; then turn on the minor mode. also, set the minor mode string with
1826 ;; the values of fill and fixup whitespace variables
1827 (if (not (get 'minor-mode-alist 'sc-minor-mode))
1828 (progn
1829 (put 'minor-mode-alist 'sc-minor-mode 'sc-minor-mode)
1830 (setq minor-mode-alist
1831 (cons '(sc-minor-mode sc-mode-string) minor-mode-alist))
1832 ))
1833 (setq sc-minor-mode t)
1834 (sc-set-mode-string)
1835
1836 (undo-boundary)
1837
1838 ;; grab point and mark since the region is probably not active when
1839 ;; this function gets automatically called. we want point to be a
1840 ;; mark so any deleting before point works properly
1841 (let* ((zmacs-regions nil) ; for Lemacs
1842 (mark-active t) ; for FSFmacs
1843 (point (point-marker))
1844 (mark (copy-marker (mark-marker))))
1845
1846 ;; make sure point comes before mark, not all functions are
1847 ;; interactive "r"
1848 (if (< mark point)
1849 (let ((tmp point))
1850 (setq point mark
1851 mark tmp)))
1852
1853 ;; first process mail headers, and populate sc-mail-info
1854 (sc-mail-process-headers point mark)
1855
1856 ;; now get possible attributions
1857 (sc-attribs-chop-address (or (sc-mail-field "from")
1858 (sc-mail-field "reply")
1859 (sc-mail-field "reply-to")
1860 (sc-mail-field "sender")))
1861 ;; select the attribution
1862 (sc-select-attribution)
1863
1864 ;; cite the region, but first check the value of sc-cite-region-limit
1865 (let ((linecnt (count-lines point mark)))
1866 (and sc-cite-region-limit
1867 (if (or (not (numberp sc-cite-region-limit))
1868 (<= linecnt sc-cite-region-limit))
1869 (progn
1870 ;; cite the region and insert the header rewrite
1871 (sc-cite-region point mark)
1872 (goto-char point)
1873 (let ((sc-eref-style (or sc-preferred-header-style 0)))
1874 (if sc-electric-references-p
1875 (sc-electric-mode sc-eref-style)
1876 (sc-eref-insert-selected t))))
1877 (beep)
1878 (message
1879 "Region not cited. %d lines exceeds sc-cite-region-limit: %d"
1880 linecnt sc-cite-region-limit))))
1881
1882 ;; finally, free the point-marker
1883 (set-marker point nil)
1884 (set-marker mark nil)
1885 )
1886 (run-hooks 'sc-post-hook)
1887 ;; post hook could have changed the variables
1888 (sc-set-mode-string))
1889
1890\f
1891;; ======================================================================
1892;; bug reporting and miscellaneous commands
1893
1894(defun sc-open-line (arg)
1895 "Like `open-line', but insert the citation prefix at the front of the line.
1896With numeric ARG, inserts that many new lines."
1897 (interactive "p")
1898 (save-excursion
1899 (let ((start (point))
1900 (prefix (or (progn (beginning-of-line)
1901 (if (looking-at (sc-cite-regexp))
1902 (sc-submatch 0)))
1903 "")))
1904 (goto-char start)
1905 (open-line arg)
1906 (forward-line 1)
1907 (while (< 0 arg)
1908 (insert prefix)
1909 (forward-line 1)
1910 (setq arg (1- arg))
1911 ))))
1912
1913(defun sc-insert-citation (arg)
1914 "Insert citation string at beginning of current line if not already cited.
1915With `\\[universal-argument]' insert citation even if line is already
1916cited."
1917 (interactive "P")
1918 (save-excursion
1919 (beginning-of-line)
1920 (if (or (not (looking-at (sc-cite-regexp)))
1921 (looking-at "^[ \t]*$")
1922 (consp arg))
1923 (insert (sc-mail-field "sc-citation"))
1924 (error "Line is already cited."))))
1925
1926(defun sc-version (arg)
1927 "Echo the current version of Supercite in the minibuffer.
1928With \\[universal-argument] (universal-argument), or if run non-interactively,
1929inserts the version string in the current buffer instead."
1930 (interactive "P")
1931 (let ((verstr (format "Using Supercite.el %s" sc-version)))
1932 (if (or (consp arg)
1933 (not (interactive-p)))
1934 (insert "`sc-version' says: " verstr)
1935 (message verstr))))
1936
1937(defun sc-describe ()
1938 "
1939Supercite is a package which provides a flexible mechanism for citing
1940email and news replies. Please see the associated texinfo file for
1941more information."
1942 (interactive)
1943 (describe-function 'sc-describe))
1944
1945(defun sc-submit-bug-report ()
1946 "Submit a bug report on Supercite via mail."
1947 (interactive)
1948 (require 'reporter)
1949 (and
1950 (y-or-n-p "Do you want to submit a report on Supercite? ")
1951 (reporter-submit-bug-report
1952 sc-help-address
1953 (concat "Supercite version " sc-version)
1954 (list
1955 'sc-attrib-selection-list
1956 'sc-auto-fill-region-p
1957 'sc-blank-lines-after-headers
1958 'sc-citation-leader
1959 'sc-citation-delimiter
1960 'sc-citation-separator
1961 'sc-citation-leader-regexp
1962 'sc-citation-root-regexp
1963 'sc-citation-nonnested-root-regexp
1964 'sc-citation-delimiter-regexp
1965 'sc-citation-separator-regexp
1966 'sc-cite-region-limit
1967 'sc-confirm-always-p
1968 'sc-default-attribution
1969 'sc-default-author-name
1970 'sc-downcase-p
1971 'sc-electric-circular-p
1972 'sc-electric-references-p
1973 'sc-fixup-whitespace-p
1974 'sc-mail-warn-if-non-rfc822-p
1975 'sc-mumble
1976 'sc-name-filter-alist
1977 'sc-nested-citation-p
1978 'sc-nuke-mail-headers
1979 'sc-nuke-mail-header-list
1980 'sc-preferred-attribution-list
1981 'sc-preferred-header-style
1982 'sc-reference-tag-string
1983 'sc-rewrite-header-list
1984 'sc-titlecue-regexp
1985 'sc-use-only-preference-p
1986 ))))
1987
1988\f
1989;; useful stuff
1990(provide 'supercite)
1991(run-hooks 'sc-load-hook)
1992
1993;;; supercite.el ends here