(term-update-mode-line, term-process-pager): Use force-mode-line-update.
[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 505
4a3393e4
SM
506(if (fboundp 'match-string)
507 (defalias 'sc-submatch 'match-string)
508 (defun sc-submatch (matchnum &optional string)
509 "Returns `match-beginning' and `match-end' sub-expression for MATCHNUM.
30b7c745
RS
510If optional STRING is provided, take sub-expression using `substring'
511of argument, otherwise use `buffer-substring' on current buffer. Note
512that `match-data' must have already been generated and no error
513checking is performed by this function."
4a3393e4
SM
514 (if string
515 (substring string (match-beginning matchnum) (match-end matchnum))
516 (buffer-substring (match-beginning matchnum) (match-end matchnum)))))
517
518(if (fboundp 'member)
519 (defalias 'sc-member 'member)
520 (defun sc-member (elt list)
521 "Like `memq', but uses `equal' instead of `eq'.
30b7c745 522Emacs19 has a builtin function `member' which does exactly this."
4a3393e4
SM
523 (catch 'elt-is-member
524 (while list
525 (if (equal elt (car list))
526 (throw 'elt-is-member list))
527 (setq list (cdr list))))))
528
529;; One day maybe Emacs will have this...
530(if (fboundp 'string-text)
531 (defalias 'sc-string-text 'string-text)
532 (defun sc-string-text (string)
533 "Return STRING with all text properties removed."
534 (let ((string (copy-sequence string)))
535 (set-text-properties 0 (length string) nil string)
536 string)))
30b7c745
RS
537
538(defun sc-ask (alist)
539 "Ask a question in the minibuffer requiring a single character answer.
540This function is kind of an extension of `y-or-n-p' where a single
541letter is used to answer a question. Question is formed from ALIST
542which has members of the form: (WORD . LETTER). WORD is the long
543word form, while LETTER is the letter for selecting that answer. The
544selected letter is returned, or nil if the question was not answered.
545Note that WORD is a string and LETTER is a character. All LETTERs in
546the list should be unique."
547 (let* ((prompt (concat
548 (mapconcat (function (lambda (elt) (car elt))) alist ", ")
549 "? ("
550 (mapconcat
551 (function
552 (lambda (elt) (char-to-string (cdr elt)))) alist "/")
553 ") "))
554 (p prompt)
555 (event
556 (if (memq 'Lucid sc-emacs-features)
557 (allocate-event)
558 nil)))
559 (while (stringp p)
560 (if (let ((cursor-in-echo-area t)
561 (inhibit-quit t))
562 (message "%s" p)
563 ;; lets be good neighbors and be compatible with all emacsen
564 (cond
565 ((memq 'v18 sc-emacs-features)
566 (setq event (read-char)))
567 ((memq 'Lucid sc-emacs-features)
568 (next-command-event event))
569 (t ; must be FSF19
570 (setq event (read-event))))
571 (prog1 quit-flag (setq quit-flag nil)))
572 (progn
573 (message "%s%s" p (single-key-description event))
574 (and (memq 'Lucid sc-emacs-features)
575 (deallocate-event event))
576 (setq quit-flag nil)
577 (signal 'quit '())))
578 (let ((char
579 (if (memq 'Lucid sc-emacs-features)
580 (let* ((key (and (key-press-event-p event) (event-key event)))
581 (char (and key (event-to-character event))))
582 char)
583 event))
584 elt)
585 (if char (setq char (downcase char)))
586 (cond
587 ((setq elt (rassq char alist))
588 (message "%s%s" p (car elt))
589 (setq p (cdr elt)))
590 ((and (memq 'Lucid sc-emacs-features)
591 (button-release-event-p event)) ; ignore them
592 nil)
593 (t
594 (message "%s%s" p (single-key-description event))
595 (if (memq 'Lucid sc-emacs-features)
596 (ding nil 'y-or-n-p)
597 (ding))
598 (discard-input)
599 (if (eq p prompt)
600 (setq p (concat "Try again. " prompt)))))))
601 (and (memq 'Lucid sc-emacs-features)
602 (deallocate-event event))
603 p))
604
605(defun sc-scan-info-alist (alist)
606 "Find a match in the info alist that matches a regexp in ALIST."
607 (let ((sc-mumble "")
608 rtnvalue)
609 (while alist
610 (let* ((elem (car alist))
611 (infokey (car elem))
612 (infoval (sc-mail-field infokey))
613 (mlist (car (cdr elem))))
614 (while mlist
615 (let* ((ml-elem (car mlist))
616 (regexp (car ml-elem))
617 (thing (cdr ml-elem)))
618 (if (string-match regexp infoval)
619 ;; we found a match, time to return
620 (setq rtnvalue thing
621 mlist nil
622 alist nil)
623 ;; else we didn't find a match
624 (setq mlist (cdr mlist))
625 ))) ;end of mlist loop
626 (setq alist (cdr alist))
627 )) ;end of alist loop
628 rtnvalue))
629
630\f
631;; ======================================================================
632;; extract mail field information from headers in reply buffer
633
634;; holder variables for bc happiness
635(defvar sc-mail-headers-start nil
636 "Start of header fields.")
637(defvar sc-mail-headers-end nil
638 "End of header fields.")
639(defvar sc-mail-field-history nil
640 "For minibuffer completion on mail field queries.")
641(defvar sc-mail-field-modification-history nil
642 "For minibuffer completion on mail field modifications.")
643(defvar sc-mail-glom-frame
644 '((begin (setq sc-mail-headers-start (point)))
645 ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
646 ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
647 ("^$" (list 'abort '(step . 0)))
648 ("^[ \t]+" (sc-mail-append-field))
649 (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
650 (end (setq sc-mail-headers-end (point))))
651 "Regi frame for glomming mail header information.")
652
653;; regi functions
654(defun sc-mail-fetch-field (&optional attribs-p)
655 "Insert a key and value into `sc-mail-info' alist.
656If optional ATTRIBS-P is non-nil, the key/value pair is placed in
657`sc-attributions' too."
658 (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline)
4a3393e4
SM
659 (let* ((key (downcase (sc-string-text (sc-submatch 1 curline))))
660 (val (sc-string-text (sc-submatch 2 curline)))
30b7c745
RS
661 (keyval (cons key val)))
662 (setq sc-mail-info (cons keyval sc-mail-info))
663 (if attribs-p
664 (setq sc-attributions (cons keyval sc-attributions)))
665 ))
666 nil)
667
668(defun sc-mail-append-field ()
669 "Append a continuation line onto the last fetched mail field's info."
670 (let ((keyval (car sc-mail-info)))
671 (if (and keyval (string-match "^\\s *\\(.*\\)$" curline))
4a3393e4
SM
672 (setcdr keyval (concat (cdr keyval) " "
673 (sc-string-text (sc-submatch 1 curline))))))
30b7c745
RS
674 nil)
675
676(defun sc-mail-error-in-mail-field ()
677 "Issue warning that mail headers don't conform to RFC 822."
678 (let* ((len (min (length curline) 10))
679 (ellipsis (if (< len (length curline)) "..." ""))
680 (msg "Mail header \"%s%s\" doesn't conform to RFC 822. skipping..."))
681 (message msg (substring curline 0 len) ellipsis))
682 (beep)
683 (sit-for 2)
684 nil)
685
686;; mail header nuking
687(defvar sc-mail-last-header-nuked-p nil
688 "True if the last header was nuked.")
689
690(defun sc-mail-nuke-line ()
691 "Nuke the current mail header line."
692 (delete-region (regi-pos 'bol) (regi-pos 'bonl))
693 '((step . -1)))
694
695(defun sc-mail-nuke-header-line ()
696 "Delete current-line and set up for possible continuation."
697 (setq sc-mail-last-header-nuked-p t)
698 (sc-mail-nuke-line))
699
700(defun sc-mail-nuke-continuation-line ()
701 "Delete a continuation line if the last header line was deleted."
702 (if sc-mail-last-header-nuked-p
703 (sc-mail-nuke-line)))
704
705(defun sc-mail-cleanup-blank-lines ()
706 "Leave some blank lines after original mail headers are nuked.
707The number of lines left is specified by `sc-blank-lines-after-headers'."
708 (if sc-blank-lines-after-headers
709 (save-restriction
710 (widen)
711 (skip-chars-backward " \t\n")
712 (forward-line 1)
713 (delete-blank-lines)
714 (beginning-of-line)
715 (if (looking-at "[ \t]*$")
716 (delete-region (regi-pos 'bol) (regi-pos 'bonl)))
717 (insert-char ?\n sc-blank-lines-after-headers)))
718 nil)
719
720(defun sc-mail-build-nuke-frame ()
721 "Build the regiframe for nuking mail headers."
722 (let (every-func entry-func nonentry-func)
723 (cond
724 ((eq sc-nuke-mail-headers 'all)
725 (setq every-func '(progn (forward-line -1) (sc-mail-nuke-line))))
726 ((eq sc-nuke-mail-headers 'specified)
727 (setq entry-func '(sc-mail-nuke-header-line)
728 nonentry-func '(setq sc-mail-last-header-nuked-p nil)))
729 ((eq sc-nuke-mail-headers 'keep)
730 (setq entry-func '(setq sc-mail-last-header-nuked-p nil)
731 nonentry-func '(sc-mail-nuke-header-line)))
732 ;; we never get far enough to interpret a frame if s-n-m-h == 'none
733 ((eq sc-nuke-mail-headers 'none))
734 (t (error "Illegal value for sc-nuke-mail-headers: %s"
735 sc-nuke-mail-headers))
736 ) ; end-cond
737 (append
738 (and entry-func
739 (regi-mapcar sc-nuke-mail-header-list entry-func nil t))
740 (and nonentry-func (list (list "^\\S +:.*$" nonentry-func)))
741 (and (not every-func)
742 '(("^[ \t]+" (sc-mail-nuke-continuation-line))))
743 '((begin (setq sc-mail-last-header-zapped-p nil)))
744 '((end (sc-mail-cleanup-blank-lines)))
745 (and every-func (list (list 'every every-func)))
746 )))
747
748;; mail processing and zapping. this is the top level entry defun to
749;; all header processing.
750(defun sc-mail-process-headers (start end)
751 "Process original mail message's mail headers.
752After processing, mail headers may be nuked. Header information is
753stored in `sc-mail-info', and any old information is lost unless an
754error occurs."
755 (interactive "r")
756 (let ((info (copy-alist sc-mail-info))
757 (attribs (copy-alist sc-attributions)))
758 (setq sc-mail-info nil
759 sc-attributions nil)
760 (regi-interpret sc-mail-glom-frame start end)
761 (if (null sc-mail-info)
762 (progn
763 (message "No mail headers found! Restoring old information.")
764 (setq sc-mail-info info
765 sc-attributions attribs))
766 (regi-interpret (sc-mail-build-nuke-frame)
767 sc-mail-headers-start sc-mail-headers-end)
768 )))
769
770\f
771;; let the user change mail field information
772(defun sc-mail-field (field)
773 "Return the mail header field value associated with FIELD.
774If there was no mail header with FIELD as its key, return the value of
775`sc-mumble'. FIELD is case insensitive."
776 (or (cdr (assoc (downcase field) sc-mail-info)) sc-mumble))
777
778(defun sc-mail-field-query (arg)
779 "View the value of a mail field.
780With `\\[universal-argument]', prompts for action on mail field.
781Action can be one of: View, Modify, Add, or Delete."
782 (interactive "P")
783 (let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d)))
784 (action (if (not arg) ?v (sc-ask alist)))
785 key)
786 (if (not action)
787 ()
788 (setq key (sc-completing-read
789 (concat (car (rassq action alist))
790 " information key: ")
791 sc-mail-info nil
792 (if (eq action ?a) nil 'noexit)
793 nil 'sc-mail-field-history))
794 (cond
795 ((eq action ?v)
796 (message "%s: %s" key (cdr (assoc key sc-mail-info))))
797 ((eq action ?d)
798 (setq sc-mail-info (delq (assoc key sc-mail-info) sc-mail-info)))
799 ((eq action ?m)
800 (let ((keyval (assoc key sc-mail-info)))
801 ;; first put initial value onto list if not already there
802 (if (not (sc-member (cdr keyval)
803 sc-mail-field-modification-history))
804 (setq sc-mail-field-modification-history
805 (cons (cdr keyval) sc-mail-field-modification-history)))
806 (setcdr keyval (sc-read-string
807 (concat key ": ") (cdr keyval)
808 'sc-mail-field-modification-history))))
809 ((eq action ?a)
810 (setq sc-mail-info
811 (cons (cons key
812 (sc-read-string (concat key ": "))) sc-mail-info)))
813 ))))
814
815\f
816;; ======================================================================
817;; attributions
818
819(defvar sc-attribution-confirmation-history nil
820 "History for confirmation of attribution strings.")
821(defvar sc-citation-confirmation-history nil
822 "History for confirmation of attribution prefixes.")
823
824(defun sc-attribs-%@-addresses (from &optional delim)
825 "Extract the author's email terminus from email address FROM.
826Match addresses of the style ``name%[stuff].'' when called with DELIM
827of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when
828called with DELIM \"@\". If DELIM is nil or not provided, matches
829addresses of the style ``name''."
830 (and (string-match (concat "[-a-zA-Z0-9_.]+" delim) from 0)
831 (substring from
832 (match-beginning 0)
833 (- (match-end 0) (if (null delim) 0 1)))))
834
835(defun sc-attribs-!-addresses (from)
836 "Extract the author's email terminus from email address FROM.
837Match addresses of the style ``[stuff]![stuff]...!name[stuff].''"
838 (let ((eos (length from))
839 (mstart (string-match "![-a-zA-Z0-9_.]+\\([^-!a-zA-Z0-9_.]\\|$\\)"
840 from 0))
841 (mend (match-end 0)))
842 (and mstart
843 (substring from (1+ mstart) (- mend (if (= mend eos) 0 1)))
844 )))
845
846(defun sc-attribs-<>-addresses (from)
847 "Extract the author's email terminus from email address FROM.
848Match addresses of the style ``<name[stuff]>.''"
849 (and (string-match "<\\(.*\\)>" from)
850 (sc-submatch 1 from)))
851
852(defun sc-get-address (from author)
853 "Get the full email address path from FROM.
854AUTHOR is the author's name (which is removed from the address)."
855 (let ((eos (length from)))
856 (if (string-match (concat "\\(^\\|^\"\\)" author
857 "\\(\\s +\\|\"\\s +\\)") from 0)
858 (let ((address (substring from (match-end 0) eos)))
859 (if (and (= (aref address 0) ?<)
860 (= (aref address (1- (length address))) ?>))
861 (substring address 1 (1- (length address)))
862 address))
863 (if (string-match "[-a-zA-Z0-9!@%._]+" from 0)
864 (sc-submatch 0 from)
865 "")
866 )))
867
868(defun sc-attribs-emailname (from)
869 "Get the email terminus name from FROM."
870 (or
871 (sc-attribs-%@-addresses from "%")
872 (sc-attribs-%@-addresses from "@")
873 (sc-attribs-!-addresses from)
874 (sc-attribs-<>-addresses from)
875 (sc-attribs-%@-addresses from)
876 (substring from 0 10)))
877
878(defun sc-name-substring (string start end extend)
879 "Extract the specified substring of STRING from START to END.
880EXTEND is the number of characters on each side to extend the
881substring."
882 (and start
883 (let ((sos (+ start extend))
884 (eos (- end extend)))
885 (substring string sos
886 (or (string-match sc-titlecue-regexp string sos) eos)
887 ))))
888
889(defun sc-attribs-extract-namestring (from)
890 "Extract the name string from FROM.
891This should be the author's full name minus an optional title."
892 (let ((namestring
893 (or
894 (sc-name-substring
895 from (string-match "(.*)" from 0) (match-end 0) 1)
896 (sc-name-substring
897 from (string-match "\".*\"" from 0) (match-end 0) 1)
898 (sc-name-substring
899 from (string-match "\\([-.a-zA-Z0-9_]+\\s +\\)+<" from 0)
900 (match-end 1) 0)
901 (sc-attribs-emailname from))))
902 ;; strip off any leading or trailing whitespace
903 (if namestring
904 (let ((bos 0)
905 (eos (1- (length namestring))))
906 (while (and (<= bos eos)
907 (memq (aref namestring bos) '(32 ?\t)))
908 (setq bos (1+ bos)))
909 (while (and (> eos bos)
910 (memq (aref namestring eos) '(32 ?\t)))
911 (setq eos (1- eos)))
912 (substring namestring bos (1+ eos))))))
913
914(defun sc-attribs-chop-namestring (namestring)
915 "Convert NAMESTRING to a list of names.
916example: (sc-namestring-to-list \"John Xavier Doe\")
917 => (\"John\" \"Xavier\" \"Doe\")"
918 (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring)
919 (cons (sc-submatch 2 namestring)
920 (sc-attribs-chop-namestring (substring namestring (match-end 3)))
921 )))
922
923(defun sc-attribs-strip-initials (namelist)
924 "Extract the author's initials from the NAMELIST."
925 (mapconcat
926 (function
927 (lambda (name)
928 (if (< 0 (length name))
929 (substring name 0 1))))
930 namelist ""))
931
932(defun sc-guess-attribution (&optional string)
933 "Guess attribution string on current line.
934If attribution cannot be guessed, nil is returned. Optional STRING if
935supplied, is used instead of the line point is on in the current buffer."
936 (let ((start 0)
937 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol))))
938 attribution)
939 (and
940 (= start (or (string-match sc-citation-leader-regexp string start) -1))
941 (setq start (match-end 0))
942 (= start (or (string-match sc-citation-root-regexp string start) 1))
943 (setq attribution (sc-submatch 0 string)
944 start (match-end 0))
945 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
946 (setq start (match-end 0))
947 (= start (or (string-match sc-citation-separator-regexp string start) -1))
948 attribution)))
949
950(defun sc-attribs-filter-namelist (namelist)
951 "Filter out noise in NAMELIST according to `sc-name-filter-alist'."
952 (let ((elements (length namelist))
953 (position -1)
954 keepers filtered-list)
955 (mapcar
956 (function
957 (lambda (name)
958 (setq position (1+ position))
959 (let ((keep-p t))
960 (mapcar
961 (function
962 (lambda (filter)
963 (let ((regexp (car filter))
964 (pos (cdr filter)))
965 (if (and (string-match regexp name)
966 (or (and (numberp pos)
967 (= pos position))
968 (and (eq pos 'last)
969 (= position (1- elements)))
970 (eq pos 'any)))
971 (setq keep-p nil))
972 )))
973 sc-name-filter-alist)
974 (if keep-p
975 (setq keepers (cons position keepers)))
976 )))
977 namelist)
978 (mapcar
979 (function
980 (lambda (position)
981 (setq filtered-list (cons (nth position namelist) filtered-list))
982 ))
983 keepers)
984 filtered-list))
985
986(defun sc-attribs-chop-address (from)
987 "Extract attribution information from FROM.
988This populates the `sc-attributions' with the list of possible attributions."
989 (if (and (stringp from)
990 (< 0 (length from)))
991 (let* ((sc-mumble "")
992 (namestring (sc-attribs-extract-namestring from))
993 (namelist (sc-attribs-filter-namelist
994 (sc-attribs-chop-namestring namestring)))
995 (revnames (reverse (cdr namelist)))
996 (firstname (car namelist))
997 (midnames (reverse (cdr revnames)))
998 (lastname (car revnames))
999 (initials (sc-attribs-strip-initials namelist))
1000 (emailname (sc-attribs-emailname from))
1001 (n 1)
1002 author middlenames)
1003
1004 ;; put basic information
1005 (setq
1006 ;; put middle names and build sc-author entry
1007 middlenames (mapconcat
1008 (function
1009 (lambda (midname)
1010 (let ((key-attribs (format "middlename-%d" n))
1011 (key-mail (format "sc-middlename-%d" n)))
1012 (setq
1013 sc-attributions (cons (cons key-attribs midname)
1014 sc-attributions)
1015 sc-mail-info (cons (cons key-mail midname)
1016 sc-mail-info)
1017 n (1+ n))
1018 midname)))
1019 midnames " ")
1020
1021 author (concat firstname " " middlenames (and midnames " ") lastname)
1022
1023 sc-attributions (append
1024 (list
1025 (cons "firstname" firstname)
1026 (cons "lastname" lastname)
1027 (cons "emailname" emailname)
1028 (cons "initials" initials))
1029 sc-attributions)
1030 sc-mail-info (append
1031 (list
1032 (cons "sc-firstname" firstname)
1033 (cons "sc-middlenames" middlenames)
1034 (cons "sc-lastname" lastname)
1035 (cons "sc-emailname" emailname)
1036 (cons "sc-initials" initials)
1037 (cons "sc-author" author)
1038 (cons "sc-from-address" (sc-get-address
1039 (sc-mail-field "from")
1040 namestring))
1041 (cons "sc-reply-address" (sc-get-address
1042 (sc-mail-field "reply-to")
1043 namestring))
1044 (cons "sc-sender-address" (sc-get-address
1045 (sc-mail-field "sender")
1046 namestring))
1047 )
1048 sc-mail-info)
1049 ))
1050 ;; from string is empty
1051 (setq sc-mail-info (cons (cons "sc-author" sc-default-author-name)
1052 sc-mail-info))))
1053
1054(defvar sc-attrib-or-cite nil
1055 "Used to toggle between attribution input or citation input.")
1056
1057(defun sc-toggle-fn ()
1058 "Toggle between attribution selection and citation selection.
1059Only used during confirmation."
1060 (interactive)
1061 (setq sc-attrib-or-cite (not sc-attrib-or-cite))
1062 (throw 'sc-reconfirm t))
1063
1064(defun sc-select-attribution ()
1065 "Select an attribution from `sc-attributions'.
1066
1067Variables involved in selection process include:
1068 `sc-preferred-attribution-list'
1069 `sc-use-only-preference-p'
1070 `sc-confirm-always-p'
1071 `sc-default-attribution'
1072 `sc-attrib-selection-list'.
1073
1074Runs the hook `sc-attribs-preselect-hook' before selecting an
1075attribution and the hook `sc-attribs-postselect-hook' after making the
1076selection but before querying is performed. During
1077`sc-attribs-postselect-hook' the variable `citation' is bound to the
1078auto-selected citation string and the variable `attribution' is bound
1079to the auto-selected attribution string."
1080 (run-hooks 'sc-attribs-preselect-hook)
1081 (let ((query-p sc-confirm-always-p)
1082 attribution citation
1083 (attriblist sc-preferred-attribution-list))
1084
1085 ;; first cruise through sc-preferred-attribution-list looking for
1086 ;; a match in either sc-attributions or sc-mail-info. if the
1087 ;; element is "sc-consult", then we have to do the alist
1088 ;; consultation phase
1089 (while attriblist
1090 (let* ((preferred (car attriblist)))
1091 (cond
1092 ((string= preferred "sc-consult")
1093 ;; we've been told to consult the attribution vs. mail
1094 ;; header key alist. we do this until we find a match in
1095 ;; the sc-attrib-selection-list. if we do not find a match,
1096 ;; we continue scanning attriblist
1097 (let ((attrib (sc-scan-info-alist sc-attrib-selection-list)))
1098 (cond
1099 ((not attrib)
1100 (setq attriblist (cdr attriblist)))
1101 ((stringp attrib)
1102 (setq attribution attrib
1103 attriblist nil))
1104 ((listp attrib)
1105 (setq attribution (eval attrib)
1106 attriblist nil))
1107 (t (error "%s did not evaluate to a string or list!"
1108 "sc-attrib-selection-list"))
1109 )))
1110 ((setq attribution (cdr (assoc preferred sc-attributions)))
1111 (setq attriblist nil))
1112 (t
1113 (setq attriblist (cdr attriblist)))
1114 )))
1115
1116 ;; if preference was not found, we may use a secondary method to
1117 ;; find a valid attribution
1118 (if (and (not attribution)
1119 (not sc-use-only-preference-p))
1120 ;; secondary method tries to find a preference in this order
1121 ;; 1. sc-lastchoice
1122 ;; 2. x-attribution
1123 ;; 3. firstname
1124 ;; 4. lastname
1125 ;; 5. initials
1126 ;; 6. first non-empty attribution in alist
1127 (setq attribution
1128 (or (cdr (assoc "sc-lastchoice" sc-attributions))
1129 (cdr (assoc "x-attribution" sc-attributions))
1130 (cdr (assoc "firstname" sc-attributions))
1131 (cdr (assoc "lastname" sc-attributions))
1132 (cdr (assoc "initials" sc-attributions))
1133 (cdr (car sc-attributions)))))
1134
1135 ;; still couldn't find an attribution. we're now limited to using
1136 ;; the default attribution, but we'll force a query when this happens
1137 (if (not attribution)
1138 (setq attribution sc-default-attribution
1139 query-p t))
1140
1141 ;; create the attribution prefix
1142 (setq citation (sc-make-citation attribution))
1143
1144 ;; run the post selection hook before querying the user
1145 (run-hooks 'sc-attribs-postselect-hook)
1146
1147 ;; query for confirmation
1148 (if query-p
1149 (let* ((query-alist (mapcar (function (lambda (entry)
1150 (list (cdr entry))))
1151 sc-attributions))
1152 (minibuffer-local-completion-map
1153 sc-minibuffer-local-completion-map)
1154 (minibuffer-local-map sc-minibuffer-local-map)
1155 (initial attribution)
1156 (completer-disable t) ; in case completer.el is used
1157 choice)
1158 (setq sc-attrib-or-cite nil) ; nil==attribution, t==citation
1159 (while
1160 (catch 'sc-reconfirm
1161 (string= "" (setq choice
1162 (if sc-attrib-or-cite
1163 (sc-read-string
1164 "Enter citation prefix: "
1165 citation
1166 'sc-citation-confirmation-history)
1167 (sc-completing-read
1168 "Complete attribution name: "
1169 query-alist nil nil
1170 (cons initial 0)
1171 'sc-attribution-confirmation-history)
1172 )))))
1173 (if sc-attrib-or-cite
1174 ;; since the citation was chosen, we have to guess at
1175 ;; the attribution
1176 (setq citation choice
1177 attribution (or (sc-guess-attribution citation)
1178 citation))
1179
1180 (setq citation (sc-make-citation choice)
1181 attribution choice))
1182 ))
1183
1184 ;; its possible that the user wants to downcase the citation and
1185 ;; attribution
1186 (if sc-downcase-p
1187 (setq citation (downcase citation)
1188 attribution (downcase attribution)))
1189
1190 ;; set up mail info alist
1191 (let* ((ckey "sc-citation")
1192 (akey "sc-attribution")
1193 (ckeyval (assoc ckey sc-mail-info))
1194 (akeyval (assoc akey sc-mail-info)))
1195 (if ckeyval
1196 (setcdr ckeyval citation)
1197 (setq sc-mail-info
1198 (append (list (cons ckey citation)) sc-mail-info)))
1199 (if akeyval
1200 (setcdr akeyval attribution)
1201 (setq sc-mail-info
1202 (append (list (cons akey attribution)) sc-mail-info))))
1203
1204 ;; set the sc-lastchoice attribution
1205 (let* ((lkey "sc-lastchoice")
1206 (lastchoice (assoc lkey sc-attributions)))
1207 (if lastchoice
1208 (setcdr lastchoice attribution)
1209 (setq sc-attributions
1210 (cons (cons lkey attribution) sc-attributions))))
1211 ))
1212
1213\f
1214;; ======================================================================
1215;; filladapt hooks for supercite 3.1. you shouldn't need anything
1216;; extra to make gin-mode understand supercited lines. Even this
1217;; stuff might not be entirely necessary...
1218
1219(defun sc-cite-regexp (&optional root-regexp)
1220 "Return a regexp describing a Supercited line.
1221The regexp is the concatenation of `sc-citation-leader-regexp',
1222`sc-citation-root-regexp', `sc-citation-delimiter-regexp', and
1223`sc-citation-separator-regexp'. If optional ROOT-REGEXP is supplied,
1224use it instead of `sc-citation-root-regexp'."
1225 (concat sc-citation-leader-regexp
1226 (or root-regexp sc-citation-root-regexp)
1227 sc-citation-delimiter-regexp
1228 sc-citation-separator-regexp))
1229
1230(defun sc-make-citation (attribution)
1231 "Make a non-nested citation from ATTRIBUTION."
1232 (concat sc-citation-leader
1233 attribution
1234 sc-citation-delimiter
1235 sc-citation-separator))
1236
1237(defun sc-setup-filladapt ()
1238 "Setup `filladapt-prefix-table' to handle Supercited paragraphs."
1239 (let* ((fa-sc-elt 'filladapt-supercite-included-text)
1240 (elt (rassq fa-sc-elt filladapt-prefix-table)))
1241 (if elt (setcar elt (sc-cite-regexp))
1242 (message "Filladapt doesn't seem to know about Supercite.")
1243 (beep))))
1244
1245\f
1246;; ======================================================================
1247;; citing and unciting regions of text
1248
1249(defvar sc-fill-begin 1
1250 "Buffer position to begin filling.")
1251(defvar sc-fill-line-prefix ""
1252 "Fill prefix of previous line")
1253
1254;; filling
1255(defun sc-fill-if-different (&optional prefix)
1256 "Fill the region bounded by `sc-fill-begin' and point.
1257Only fill if optional PREFIX is different than `sc-fill-line-prefix'.
1258If `sc-auto-fill-region-p' is nil, do not fill region. If PREFIX is
1259not supplied, initialize fill variables. This is useful for a regi
1260`begin' frame-entry."
1261 (if (not prefix)
1262 (setq sc-fill-line-prefix ""
1263 sc-fill-begin (regi-pos 'bol))
1264 (if (and sc-auto-fill-region-p
1265 (not (string= prefix sc-fill-line-prefix)))
1266 (let ((fill-prefix sc-fill-line-prefix))
1267 (if (not (string= fill-prefix ""))
1268 (fill-region sc-fill-begin (regi-pos 'bol)))
1269 (setq sc-fill-line-prefix prefix
1270 sc-fill-begin (regi-pos 'bol))))
1271 )
1272 nil)
1273
1274(defun sc-cite-coerce-cited-line ()
1275 "Coerce a Supercited line to look like our style."
1276 (let* ((attribution (sc-guess-attribution))
1277 (regexp (sc-cite-regexp attribution))
1278 (prefix (sc-make-citation attribution)))
1279 (if (and attribution
1280 (looking-at regexp))
1281 (progn
1282 (delete-region
1283 (match-beginning 0)
1284 (save-excursion
1285 (goto-char (match-end 0))
1286 (if (bolp) (forward-char -1))
1287 (point)))
1288 (insert prefix)
1289 (sc-fill-if-different prefix)))
1290 nil))
1291
1292(defun sc-cite-coerce-dumb-citer ()
1293 "Coerce a non-nested citation that's been cited with a dumb nesting citer."
1294 (delete-region (match-beginning 1) (match-end 1))
1295 (beginning-of-line)
1296 (sc-cite-coerce-cited-line))
1297
1298(defun sc-guess-nesting (&optional string)
1299 "Guess the citation nesting on the current line.
1300If nesting cannot be guessed, nil is returned. Optional STRING if
1301supplied, is used instead of the line point is on in the current
1302buffer."
1303 (let ((start 0)
1304 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol))))
1305 nesting)
1306 (and
1307 (= start (or (string-match sc-citation-leader-regexp string start) -1))
1308 (setq start (match-end 0))
1309 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
1310 (setq nesting (sc-submatch 0 string)
1311 start (match-end 0))
1312 (= start (or (string-match sc-citation-separator-regexp string start) -1))
1313 nesting)))
1314
1315(defun sc-add-citation-level ()
1316 "Add a citation level for nested citation style w/ coersion."
1317 (let* ((nesting (sc-guess-nesting))
1318 (citation (make-string (1+ (length nesting))
1319 (string-to-char sc-citation-delimiter)))
1320 (prefix (concat sc-citation-leader citation sc-citation-separator)))
1321 (if (looking-at (sc-cite-regexp ""))
1322 (delete-region (match-beginning 0) (match-end 0)))
1323 (insert prefix)
1324 (sc-fill-if-different prefix)))
1325
1326(defun sc-cite-line (&optional citation)
1327 "Cite a single line of uncited text.
1328Optional CITATION overrides any citation automatically selected."
1329 (if sc-fixup-whitespace-p
1330 (fixup-whitespace))
1331 (let ((prefix (or citation
1332 (cdr (assoc "sc-citation" sc-mail-info))
1333 sc-default-attribution)))
1334 (insert prefix)
1335 (sc-fill-if-different prefix))
1336 nil)
1337
1338(defun sc-uncite-line ()
1339 "Remove citation from current line."
1340 (let ((cited (looking-at (sc-cite-regexp))))
1341 (if cited
1342 (delete-region (match-beginning 0) (match-end 0))))
1343 nil)
1344
1345(defun sc-recite-line (regexp)
1346 "Remove citation matching REGEXP from current line and recite line."
1347 (let ((cited (looking-at (concat "^" regexp)))
1348 (prefix (cdr (assoc "sc-citation" sc-mail-info))))
1349 (if cited
1350 (delete-region (match-beginning 0) (match-end 0)))
1351 (insert (or prefix sc-default-attribution))
1352 (sc-fill-if-different prefix))
1353 nil)
1354
1355;; interactive functions
1356(defun sc-cite-region (start end &optional confirm-p)
1357 "Cite a region delineated by START and END.
1358If optional CONFIRM-P is non-nil, the attribution is confirmed before
1359its use in the citation string. This function first runs
1360`sc-pre-cite-hook'."
1361 (interactive "r\nP")
1362 (undo-boundary)
1363 (let ((frame (or (sc-scan-info-alist sc-cite-frame-alist)
1364 sc-default-cite-frame))
1365 (sc-confirm-always-p (if confirm-p t sc-confirm-always-p)))
1366 (run-hooks 'sc-pre-cite-hook)
1367 (if (interactive-p)
1368 (sc-select-attribution))
1369 (regi-interpret frame start end)))
1370
1371(defun sc-uncite-region (start end)
1372 "Uncite a region delineated by START and END.
1373First runs `sc-pre-uncite-hook'."
1374 (interactive "r")
1375 (undo-boundary)
1376 (let ((frame (or (sc-scan-info-alist sc-uncite-frame-alist)
1377 sc-default-uncite-frame)))
1378 (run-hooks 'sc-pre-uncite-hook)
1379 (regi-interpret frame start end)))
1380
1381(defun sc-recite-region (start end)
1382 "Recite a region delineated by START and END.
1383First runs `sc-pre-recite-hook'."
1384 (interactive "r")
1385 (let ((sc-confirm-always-p t))
1386 (sc-select-attribution))
1387 (undo-boundary)
1388 (let ((frame (or (sc-scan-info-alist sc-recite-frame-alist)
1389 sc-default-recite-frame)))
1390 (run-hooks 'sc-pre-recite-hook)
1391 (regi-interpret frame start end)))
1392
1393\f
1394;; ======================================================================
1395;; building headers
1396
1397(defun sc-hdr (prefix field &optional sep return-nil-p)
1398 "Returns a concatenation of PREFIX and FIELD.
1399If FIELD is not a string or is the empty string, the empty string will
1400be returned. Optional third argument SEP is concatenated on the end if
1401it is a string. Returns empty string, unless optional RETURN-NIL-P is
1402non-nil."
1403 (if (and (stringp field)
1404 (not (string= field "")))
1405 (concat prefix field (or sep ""))
1406 (and (not return-nil-p) "")))
1407
1408(defun sc-whofrom ()
1409 "Return the value of (sc-mail-field \"from\") or nil."
1410 (let ((sc-mumble nil))
1411 (sc-mail-field "from")))
1412
1413(defun sc-no-header ()
1414 "Does nothing. Use this instead of nil to get a blank header."
1415 ())
1416
1417(defun sc-no-blank-line-or-header()
1418 "Similar to `sc-no-header' except it removes the preceeding blank line."
1419 (if (not (bobp))
1420 (if (and (eolp)
1421 (progn (forward-line -1)
1422 (or (looking-at mail-header-separator)
1423 (and (eq major-mode 'mh-letter-mode)
1424 (mh-in-header-p)))))
1425 (progn (forward-line)
1426 (let ((kill-lines-magic t))
1427 (kill-line))))))
1428
1429(defun sc-header-on-said ()
1430 "\"On <date>, <from> said:\" unless:
14311. the \"from\" field cannot be found, in which case nothing is inserted;
14322. the \"date\" field is missing in which case only the from part is printed."
1433 (let ((sc-mumble "")
1434 (whofrom (sc-whofrom)))
1435 (if whofrom
1436 (insert sc-reference-tag-string
1437 (sc-hdr "On " (sc-mail-field "date") ", ")
1438 whofrom " said:\n"))))
1439
1440(defun sc-header-inarticle-writes ()
1441 "\"In article <message-id>, <from> writes:\"
1442Treats \"message-id\" and \"from\" fields similar to `sc-header-on-said'."
1443 (let ((sc-mumble "")
1444 (whofrom (sc-mail-field "from")))
1445 (if whofrom
1446 (insert sc-reference-tag-string
1447 (sc-hdr "In article " (sc-mail-field "message-id") ", ")
1448 whofrom " writes:\n"))))
1449
1450(defun sc-header-regarding-adds ()
1451 "\"Regarding <subject>; <from> adds:\"
1452Treats \"subject\" and \"from\" fields similar to `sc-header-on-said'."
1453 (let ((sc-mumble "")
1454 (whofrom (sc-whofrom)))
1455 (if whofrom
1456 (insert sc-reference-tag-string
1457 (sc-hdr "Regarding " (sc-mail-field "subject") "; ")
1458 whofrom " adds:\n"))))
1459
1460(defun sc-header-attributed-writes ()
1461 "\"<sc-attribution>\" == <sc-author> <address> writes:
1462Treats these fields in a similar manner to `sc-header-on-said'."
1463 (let ((sc-mumble "")
1464 (whofrom (sc-whofrom)))
1465 (if whofrom
1466 (insert sc-reference-tag-string
1467 (sc-hdr "\"" (sc-mail-field "sc-attribution") "\" == ")
1468 (sc-hdr "" (sc-mail-field "sc-author") " ")
1469 (or (sc-hdr "<" (sc-mail-field "sc-from-address") ">" t)
1470 (sc-hdr "<" (sc-mail-field "sc-reply-address") ">" t)
1471 "")
1472 " writes:\n"))))
1473
1474(defun sc-header-author-writes ()
1475 "<sc-author> writes:"
1476 (let ((sc-mumble "")
1477 (whofrom (sc-whofrom)))
1478 (if whofrom
1479 (insert sc-reference-tag-string
1480 (sc-hdr "" (sc-mail-field "sc-author"))
1481 " writes:\n"))))
1482
1483(defun sc-header-verbose ()
1484 "Very verbose, some say gross."
1485 (let ((sc-mumble "")
1486 (whofrom (sc-whofrom))
1487 (tag sc-reference-tag-string))
1488 (if whofrom
1489 (insert (sc-hdr (concat tag "On ") (sc-mail-field "date") ",\n")
1490 (or (sc-hdr tag (sc-mail-field "sc-author") "\n" t)
1491 (concat tag whofrom "\n"))
1492 (sc-hdr (concat tag "from the organization of ")
1493 (sc-mail-field "organization") "\n")
1494 (let ((rtag (concat tag "who can be reached at: ")))
1495 (or (sc-hdr rtag (sc-mail-field "sc-from-address") "\n" t)
1496 (sc-hdr rtag (sc-mail-field "sc-reply-address") "\n" t)
1497 ""))
1498 (sc-hdr
1499 (concat tag "(whose comments are cited below with \"")
1500 (sc-mail-field "sc-citation") "\"),\n")
1501 (sc-hdr (concat tag "had this to say in article ")
1502 (sc-mail-field "message-id") "\n")
1503 (sc-hdr (concat tag "in newsgroups ")
1504 (sc-mail-field "newsgroups") "\n")
1505 (sc-hdr (concat tag "concerning the subject of ")
1506 (sc-mail-field "subject") "\n")
1507 (sc-hdr (concat tag "(see ")
1508 (sc-mail-field "references")
1509 " for more details)\n")
1510 ))))
1511
1512\f
1513;; ======================================================================
1514;; header rewrites
1515
1516(defconst sc-electric-bufname " *sc-erefs* "
1517 "Supercite electric reference mode's buffer name.")
1518(defvar sc-eref-style 0
1519 "Current electric reference style.")
1520
1521(defun sc-valid-index-p (index)
1522 "Returns INDEX if it is a valid index into `sc-rewrite-header-list'.
1523Otherwise returns nil."
1524 ;; a number, and greater than or equal to zero
1525 ;; less than or equal to the last index
1526 (and (natnump index)
1527 (< index (length sc-rewrite-header-list))
1528 index))
1529
1530(defun sc-eref-insert-selected (&optional nomsg)
1531 "Insert the selected reference header in the current buffer.
1532Optional NOMSG, if non-nil, inhibits printing messages, unless an
1533error occurs."
1534 (let ((ref (nth sc-eref-style sc-rewrite-header-list)))
1535 (condition-case err
1536 (progn
1537 (eval ref)
1538 (let ((lines (count-lines (point-min) (point-max))))
1539 (or nomsg (message "Ref header %d [%d line%s]: %s"
1540 sc-eref-style lines
1541 (if (= lines 1) "" "s")
1542 ref))))
1543 (void-function
1544 (progn (message
1545 "Symbol's function definition is void: %s (Header %d)"
1546 (car (cdr err)) sc-eref-style)
1547 (beep)
1548 ))
1549 )))
1550
1551(defun sc-electric-mode (&optional arg)
1552 "
1553Mode for viewing Supercite reference headers. Commands are:
1554\n\\{sc-electric-mode-map}
1555
1556`sc-electric-mode' is not intended to be run interactively, but rather
1557accessed through Supercite's electric reference feature. See
1558`sc-insert-reference' for more details. Optional ARG is the initial
1559header style to use, unless not supplied or invalid, in which case
1560`sc-preferred-header-style' is used."
1561
1562 (let ((info sc-mail-info))
1563
1564 (setq sc-eref-style
1565 (or (sc-valid-index-p arg)
1566 (sc-valid-index-p sc-preferred-header-style)
1567 0))
1568
1569 (get-buffer-create sc-electric-bufname)
1570 ;; set up buffer and enter command loop
1571 (save-excursion
1572 (save-window-excursion
1573 (pop-to-buffer sc-electric-bufname)
1574 (kill-all-local-variables)
1575 (let ((sc-mail-info info)
1576 (buffer-read-only t)
1577 (mode-name "SC Electric Refs")
1578 (major-mode 'sc-electric-mode))
1579 (use-local-map sc-electric-mode-map)
1580 (sc-eref-show sc-eref-style)
1581 (run-hooks 'sc-electric-mode-hook)
1582 (recursive-edit)
1583 )))
1584
1585 (and sc-eref-style
1586 (sc-eref-insert-selected))
1587 (kill-buffer sc-electric-bufname)
1588 ))
1589
1590;; functions for electric reference mode
1591(defun sc-eref-show (index)
1592 "Show reference INDEX in `sc-rewrite-header-list'."
1593 (let ((msg "No %ing reference headers in list.")
1594 (last (length sc-rewrite-header-list)))
1595 (setq sc-eref-style
1596 (cond
1597 ((sc-valid-index-p index) index)
1598 ((< index 0)
1599 (if sc-electric-circular-p
1600 (1- last)
1601 (progn (error msg "preced") 0)))
1602 ((>= index last)
1603 (if sc-electric-circular-p
1604 0
1605 (progn (error msg "follow") (1- last))))
1606 ))
1607 (save-excursion
1608 (set-buffer sc-electric-bufname)
1609 (let ((buffer-read-only nil))
1610 (erase-buffer)
1611 (goto-char (point-min))
1612 (sc-eref-insert-selected)
1613 ;; now shrink the window to just contain the electric reference
1614 ;; header.
1615 (let ((hdrlines (count-lines (point-min) (point-max)))
1616 (winlines (1- (window-height))))
1617 (if (/= hdrlines winlines)
1618 (if (> hdrlines winlines)
1619 ;; we have to enlarge the window
1620 (enlarge-window (- hdrlines winlines))
1621 ;; we have to shrink the window
1622 (shrink-window (- winlines (max hdrlines window-min-height)))
1623 )))
1624 ))))
1625
1626(defun sc-eref-next ()
1627 "Display next reference in other buffer."
1628 (interactive)
1629 (sc-eref-show (1+ sc-eref-style)))
1630
1631(defun sc-eref-prev ()
1632 "Display previous reference in other buffer."
1633 (interactive)
1634 (sc-eref-show (1- sc-eref-style)))
1635
1636(defun sc-eref-setn ()
1637 "Set reference header selected as preferred."
1638 (interactive)
1639 (setq sc-preferred-header-style sc-eref-style)
1640 (message "Preferred reference style set to header %d." sc-eref-style))
1641
1642(defun sc-eref-goto (refnum)
1643 "Show reference style indexed by REFNUM.
1644If REFNUM is an invalid index, don't go to that reference and return
1645nil."
1646 (interactive "NGoto Reference: ")
1647 (if (sc-valid-index-p refnum)
1648 (sc-eref-show refnum)
1649 (error "Invalid reference: %d. (Range: [%d .. %d])"
1650 refnum 0 (1- (length sc-rewrite-header-list)))
1651 ))
1652
1653(defun sc-eref-jump ()
1654 "Set reference header to preferred header."
1655 (interactive)
1656 (sc-eref-show sc-preferred-header-style))
1657
1658(defun sc-eref-abort ()
1659 "Exit from electric reference mode without inserting reference."
1660 (interactive)
1661 (setq sc-eref-style nil)
1662 (exit-recursive-edit))
1663
1664(defun sc-eref-exit ()
1665 "Exit from electric reference mode and insert selected reference."
1666 (interactive)
1667 (exit-recursive-edit))
1668
1669(defun sc-insert-reference (arg)
1670 "Insert, at point, a reference header in the body of the reply.
1671Numeric ARG indicates which header style from `sc-rewrite-header-list'
1672to use when rewriting the header. No supplied ARG indicates use of
1673`sc-preferred-header-style'.
1674
1675With just `\\[universal-argument]', electric reference insert mode is
1676entered, regardless of the value of `sc-electric-references-p'. See
1677`sc-electric-mode' for more information."
1678 (interactive "P")
1679 (if (consp arg)
1680 (sc-electric-mode)
1681 (let ((preference (or (sc-valid-index-p arg)
1682 (sc-valid-index-p sc-preferred-header-style)
1683 sc-preferred-header-style
1684 0)))
1685 (if sc-electric-references-p
1686 (sc-electric-mode preference)
1687 (sc-eref-insert-selected t)
1688 ))))
1689
1690\f
1691;; ======================================================================
1692;; variable toggling
1693
1694(defun sc-raw-mode-toggle ()
1695 "Toggle, in one fell swoop, two important SC variables:
1696`sc-fixup-whitespace-p' and `sc-auto-fill-region-p'"
1697 (interactive)
1698 (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p)
1699 sc-auto-fill-region-p (not sc-auto-fill-region-p))
1700 (sc-set-mode-string)
1701 (set-buffer-modified-p (buffer-modified-p)))
1702
1703(defun sc-toggle-var (variable)
1704 "Boolean toggle VARIABLE's value.
1705VARIABLE must be a bound symbol. Nil values change to t, non-nil
1706values are changed to nil."
1707 (message "%s changed from %s to %s"
1708 variable (symbol-value variable)
1709 (set-variable variable (not (eval-expression variable))))
1710 (sc-set-mode-string))
1711
1712(defun sc-set-variable (var)
1713 "Set the Supercite VARIABLE.
1714This function mimics `set-variable', except that the variable to set
1715is determined non-interactively. The value is queried for in the
1716minibuffer exactly the same way that `set-variable' does it.
1717
1718You can see the current value of the variable when the minibuffer is
1719querying you by typing `C-h'. Note that the format is changed
1720slightly from that used by `set-variable' -- the current value is
1721printed just after the variable's name instead of at the bottom of the
1722help window."
1723 (let* ((minibuffer-help-form
1724 '(funcall myhelp))
1725 (myhelp
1726 (function
1727 (lambda ()
1728 (with-output-to-temp-buffer "*Help*"
1729 (prin1 var)
1730 (if (boundp var)
1731 (let ((print-length 20))
1732 (princ "\t(Current value: ")
1733 (prin1 (symbol-value var))
1734 (princ ")")))
1735 (princ "\n\nDocumentation:\n")
1736 (princ (substring (documentation-property
1737 var
1738 'variable-documentation)
1739 1))
5312cce7
KH
1740 (save-excursion
1741 (set-buffer standard-output)
1742 (help-mode))
30b7c745
RS
1743 nil)))))
1744 (set var (eval-minibuffer (format "Set %s to value: " var))))
1745 (sc-set-mode-string))
1746
1747(defmacro sc-toggle-symbol (rootname)
1748 (list 'defun (intern (concat "sc-T-" rootname)) '()
1749 (list 'interactive)
1750 (list 'sc-toggle-var
1751 (list 'quote (intern (concat "sc-" rootname "-p"))))))
1752
1753(defmacro sc-setvar-symbol (rootname)
1754 (list 'defun (intern (concat "sc-S-" rootname)) '()
1755 (list 'interactive)
1756 (list 'sc-set-variable
1757 (list 'quote (intern (concat "sc-" rootname))))))
1758
1759(sc-toggle-symbol "confirm-always")
1760(sc-toggle-symbol "downcase")
1761(sc-toggle-symbol "electric-references")
1762(sc-toggle-symbol "auto-fill-region")
1763(sc-toggle-symbol "mail-nuke-blank-lines")
1764(sc-toggle-symbol "nested-citation")
1765(sc-toggle-symbol "electric-circular")
1766(sc-toggle-symbol "use-only-preferences")
1767(sc-toggle-symbol "fixup-whitespace")
1768
1769(sc-setvar-symbol "preferred-attribution-list")
1770(sc-setvar-symbol "preferred-header-style")
1771(sc-setvar-symbol "mail-nuke-mail-headers")
1772(sc-setvar-symbol "mail-header-nuke-list")
1773(sc-setvar-symbol "cite-region-limit")
1774
1775(defun sc-T-describe ()
1776 "
1777
1778Supercite provides a number of key bindings which simplify the process
1779of setting or toggling certain variables controlling its operation.
1780
1781Note on function names in this list: all functions of the form
1782`sc-S-<name>' actually call `sc-set-variable' on the corresponding
1783`sc-<name>' variable. All functions of the form `sc-T-<name>' call
1784`sc-toggle-var' on the corresponding `sc-<name>-p' variable.
1785
1786\\{sc-T-keymap}"
1787 (interactive)
1788 (describe-function 'sc-T-describe))
1789
1790(defun sc-set-mode-string ()
1791 "Update the minor mode string to show state of Supercite."
1792 (setq sc-mode-string
1793 (concat " SC"
1794 (if (or sc-auto-fill-region-p
1795 sc-fixup-whitespace-p)
1796 ":" "")
1797 (if sc-auto-fill-region-p "f" "")
1798 (if sc-fixup-whitespace-p "w" "")
1799 )))
1800
1801\f
1802;; ======================================================================
1803;; published interface to mail and news readers
1804
80056f3d 1805;;;###autoload
30b7c745
RS
1806(defun sc-cite-original ()
1807 "Workhorse citing function which performs the initial citation.
1808This is callable from the various mail and news readers' reply
1809function according to the agreed upon standard. See `\\[sc-describe]'
1810for more details. `sc-cite-original' does not do any yanking of the
1811original message but it does require a few things:
1812
1813 1) The reply buffer is the current buffer.
1814
1815 2) The original message has been yanked and inserted into the
1816 reply buffer.
1817
1818 3) Verbose mail headers from the original message have been
1819 inserted into the reply buffer directly before the text of the
1820 original message.
1821
1822 4) Point is at the beginning of the verbose headers.
1823
1824 5) Mark is at the end of the body of text to be cited.
1825
1826For Emacs 19's, the region need not be active (and typically isn't
1827when this function is called. Also, the hook `sc-pre-hook' is run
1828before, and `sc-post-hook' is run after the guts of this function."
1829 (run-hooks 'sc-pre-hook)
1830
1831 ;; before we do anything, we want to insert the supercite keymap so
1832 ;; we can proceed from here
1833 (and sc-mode-map-prefix
1834 (local-set-key sc-mode-map-prefix sc-mode-map))
1835
1836 ;; hack onto the minor mode alist, if it hasn't been done before,
1837 ;; then turn on the minor mode. also, set the minor mode string with
1838 ;; the values of fill and fixup whitespace variables
1839 (if (not (get 'minor-mode-alist 'sc-minor-mode))
1840 (progn
1841 (put 'minor-mode-alist 'sc-minor-mode 'sc-minor-mode)
1842 (setq minor-mode-alist
1843 (cons '(sc-minor-mode sc-mode-string) minor-mode-alist))
1844 ))
1845 (setq sc-minor-mode t)
1846 (sc-set-mode-string)
1847
1848 (undo-boundary)
1849
1850 ;; grab point and mark since the region is probably not active when
1851 ;; this function gets automatically called. we want point to be a
1852 ;; mark so any deleting before point works properly
1853 (let* ((zmacs-regions nil) ; for Lemacs
1854 (mark-active t) ; for FSFmacs
1855 (point (point-marker))
1856 (mark (copy-marker (mark-marker))))
1857
1858 ;; make sure point comes before mark, not all functions are
1859 ;; interactive "r"
1860 (if (< mark point)
1861 (let ((tmp point))
1862 (setq point mark
1863 mark tmp)))
1864
1865 ;; first process mail headers, and populate sc-mail-info
1866 (sc-mail-process-headers point mark)
1867
1868 ;; now get possible attributions
1869 (sc-attribs-chop-address (or (sc-mail-field "from")
1870 (sc-mail-field "reply")
1871 (sc-mail-field "reply-to")
1872 (sc-mail-field "sender")))
1873 ;; select the attribution
1874 (sc-select-attribution)
1875
1876 ;; cite the region, but first check the value of sc-cite-region-limit
1877 (let ((linecnt (count-lines point mark)))
1878 (and sc-cite-region-limit
1879 (if (or (not (numberp sc-cite-region-limit))
1880 (<= linecnt sc-cite-region-limit))
1881 (progn
1882 ;; cite the region and insert the header rewrite
1883 (sc-cite-region point mark)
1884 (goto-char point)
1885 (let ((sc-eref-style (or sc-preferred-header-style 0)))
1886 (if sc-electric-references-p
1887 (sc-electric-mode sc-eref-style)
1888 (sc-eref-insert-selected t))))
1889 (beep)
1890 (message
1891 "Region not cited. %d lines exceeds sc-cite-region-limit: %d"
1892 linecnt sc-cite-region-limit))))
1893
1894 ;; finally, free the point-marker
1895 (set-marker point nil)
1896 (set-marker mark nil)
1897 )
1898 (run-hooks 'sc-post-hook)
1899 ;; post hook could have changed the variables
1900 (sc-set-mode-string))
1901
1902\f
1903;; ======================================================================
1904;; bug reporting and miscellaneous commands
1905
1906(defun sc-open-line (arg)
1907 "Like `open-line', but insert the citation prefix at the front of the line.
1908With numeric ARG, inserts that many new lines."
1909 (interactive "p")
1910 (save-excursion
1911 (let ((start (point))
1912 (prefix (or (progn (beginning-of-line)
1913 (if (looking-at (sc-cite-regexp))
1914 (sc-submatch 0)))
1915 "")))
1916 (goto-char start)
1917 (open-line arg)
1918 (forward-line 1)
1919 (while (< 0 arg)
1920 (insert prefix)
1921 (forward-line 1)
1922 (setq arg (1- arg))
1923 ))))
1924
1925(defun sc-insert-citation (arg)
1926 "Insert citation string at beginning of current line if not already cited.
1927With `\\[universal-argument]' insert citation even if line is already
1928cited."
1929 (interactive "P")
1930 (save-excursion
1931 (beginning-of-line)
1932 (if (or (not (looking-at (sc-cite-regexp)))
1933 (looking-at "^[ \t]*$")
1934 (consp arg))
1935 (insert (sc-mail-field "sc-citation"))
1936 (error "Line is already cited."))))
1937
1938(defun sc-version (arg)
1939 "Echo the current version of Supercite in the minibuffer.
1940With \\[universal-argument] (universal-argument), or if run non-interactively,
1941inserts the version string in the current buffer instead."
1942 (interactive "P")
1943 (let ((verstr (format "Using Supercite.el %s" sc-version)))
1944 (if (or (consp arg)
1945 (not (interactive-p)))
1946 (insert "`sc-version' says: " verstr)
1947 (message verstr))))
1948
1949(defun sc-describe ()
1950 "
1951Supercite is a package which provides a flexible mechanism for citing
1952email and news replies. Please see the associated texinfo file for
1953more information."
1954 (interactive)
1955 (describe-function 'sc-describe))
1956
1957(defun sc-submit-bug-report ()
1958 "Submit a bug report on Supercite via mail."
1959 (interactive)
1960 (require 'reporter)
1961 (and
1962 (y-or-n-p "Do you want to submit a report on Supercite? ")
1963 (reporter-submit-bug-report
1964 sc-help-address
1965 (concat "Supercite version " sc-version)
1966 (list
1967 'sc-attrib-selection-list
1968 'sc-auto-fill-region-p
1969 'sc-blank-lines-after-headers
1970 'sc-citation-leader
1971 'sc-citation-delimiter
1972 'sc-citation-separator
1973 'sc-citation-leader-regexp
1974 'sc-citation-root-regexp
1975 'sc-citation-nonnested-root-regexp
1976 'sc-citation-delimiter-regexp
1977 'sc-citation-separator-regexp
1978 'sc-cite-region-limit
1979 'sc-confirm-always-p
1980 'sc-default-attribution
1981 'sc-default-author-name
1982 'sc-downcase-p
1983 'sc-electric-circular-p
1984 'sc-electric-references-p
1985 'sc-fixup-whitespace-p
1986 'sc-mail-warn-if-non-rfc822-p
1987 'sc-mumble
1988 'sc-name-filter-alist
1989 'sc-nested-citation-p
1990 'sc-nuke-mail-headers
1991 'sc-nuke-mail-header-list
1992 'sc-preferred-attribution-list
1993 'sc-preferred-header-style
1994 'sc-reference-tag-string
1995 'sc-rewrite-header-list
1996 'sc-titlecue-regexp
1997 'sc-use-only-preference-p
1998 ))))
1999
2000\f
2001;; useful stuff
2002(provide 'supercite)
2003(run-hooks 'sc-load-hook)
2004
2005;;; supercite.el ends here