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