lisp/mail/supercite.el

   1 ;;; supercite.el --- minor mode for citing mail and news replies
   2
   3 ;; Copyright (C) 1993, 1997, 2003, 2004, 2005 Free Software Foundation, Inc.
   4
   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
  10
  11 ;; supercite.el revision: 3.54
  12
  13 ;; This file is part of GNU Emacs.
  14
  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.
  19
  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.
  24
  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.
  29
  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|
  34
  35 ;;; Commentary:
  36
  37 ;;; Code:
  38
  39 \f
  40 (require 'regi)
  41 (require 'sendmail)     ;; For mail-header-end.
  42
  43 ;; start user configuration variables
  44 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
  45
  46 (defgroup supercite nil
  47   "Supercite package"
  48   :prefix "sc-"
  49   :group 'mail
  50   :group 'news)
  51
  52 (defgroup supercite-frames nil
  53   "Supercite (regi) frames"
  54   :prefix "sc-"
  55   :group 'supercite)
  56
  57 (defgroup supercite-attr nil
  58   "Supercite attributions"
  59   :prefix "sc-"
  60   :group 'supercite)
  61
  62 (defgroup supercite-cite nil
  63   "Supercite citings"
  64   :prefix "sc-"
  65   :group 'supercite)
  66
  67 (defgroup supercite-hooks nil
  68   "Hooking into supercite"
  69   :prefix "sc-"
  70   :group 'supercite)
  71
  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)
  76
  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)
  83
  84 (defcustom sc-citation-leader "    "
  85   "*String comprising first part of a citation."
  86   :type 'string
  87   :group 'supercite-cite)
  88
  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)
  94
  95 (defcustom sc-citation-separator " "
  96   "*String comprising fourth and last part of a citation."
  97   :type 'string
  98   :group 'supercite-cite)
  99
 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)
 105
 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)
 114
 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)
 123
 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)
 129
 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)
 135
 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)
 140
 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              (...)))
 147
 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)
 156
 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)
 164
 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)
 172
 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))
 185                    )))
 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 ""))
 213     )
 214   "*Default REGI frame for citing a region."
 215   :type '(repeat (repeat sexp))
 216   :group 'supercite-frames)
 217
 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))
 223     )
 224   "*Default REGI frame for unciting a region."
 225   :type '(repeat (repeat sexp))
 226   :group 'supercite-frames)
 227
 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 ""))
 239     )
 240   "*Default REGI frame for reciting a region."
 241   :type '(repeat (repeat sexp))
 242   :group 'supercite-frames)
 243
 244 (defcustom sc-cite-region-limit t
 245   "*This variable controls automatic citation of yanked text.
 246 Valid values are:
 247
 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'.
 255
 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)
 264
 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)
 269
 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)
 287
 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)
 296
 297 (defcustom sc-fixup-whitespace-p nil
 298   "*If non-nil, delete all leading white space before citing."
 299   :type 'boolean
 300   :group 'supercite)
 301
 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)
 314
 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)
 323
 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).
 332
 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)
 341
 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)
 347
 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:
 351
 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)
 359
 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)
 366
 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.
 377
 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).
 385
 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'.
 390
 391 Barring error conditions, the following preferences are always present
 392 in the attribution alist:
 393
 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
 400 ...
 401
 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)
 408
 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:
 412
 413    (INFOKEY ((REGEXP . ATTRIBUTION)
 414              (REGEXP . ATTRIBUTION)
 415              (...)))
 416
 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)
 430
 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)
 441
 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)
 457
 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)
 463
 464 (defcustom sc-reference-tag-string ">>>>> "
 465   "*String used at the beginning of built-in reference headers."
 466   :type 'string
 467   :group 'supercite)
 468
 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)
 478     )
 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)
 485
 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)
 492
 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)
 500
 501 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 502 ;; end user configuration variables
 503 \f
 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.")
 508
 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.")
 513
 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.")
 520
 521 (make-variable-buffer-local 'sc-mail-info)
 522 (make-variable-buffer-local 'sc-attributions)
 523
 524 \f
 525 ;; ======================================================================
 526 ;; supercite keymaps
 527
 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.")
 531
 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.")
 552
 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.")
 571
 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.")
 589
 590
 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.")
 597
 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.")
 603
 604 \f
 605 ;; ======================================================================
 606 ;; utility functions
 607
 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)
 656          (t
 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))
 666     p))
 667
 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))
 692
 693 \f
 694 ;; ======================================================================
 695 ;; extract mail field information from headers in reply buffer
 696
 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.")
 715
 716 (defvar curline)                        ; dynamic bondage
 717
 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)
 731
 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)
 739
 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)
 749
 750 ;; mail header nuking
 751 (defvar sc-mail-last-header-nuked-p nil
 752   "True if the last header was nuked.")
 753
 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)))
 758
 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))
 763
 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)))
 768
 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)
 784
 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)))
 811      )))
 812
 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)
 833       )))
 834
 835 \f
 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 (downcase field) sc-mail-info)) sc-mumble))
 842
 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)
 852         ()
 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        ))))
 877
 878 \f
 879 ;; ======================================================================
 880 ;; attributions
 881
 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.")
 886
 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)))))
 897
 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)))
 907          )))
 908
 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)))
 914
 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 "\\(^\\|^\"\\)" author
 920                               "\\(\\s +\\|\"\\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)
 928         "")
 929       )))
 930
 931 (defun sc-attribs-emailname (from)
 932   "Get the email terminus name from FROM."
 933   (or
 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)))
 940
 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                     ))))
 951
 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
 957          (or
 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))))))
 988
 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)))
 996             )))
 997
 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 ""))
1006
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)))
1025
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))
1048                 )))
1049            sc-name-filter-alist)
1050           (if keep-p
1051               (setq keepers (cons position keepers)))
1052           )))
1053      namelist)
1054     (mapcar
1055      (function
1056       (lambda (position)
1057         (setq filtered-list (cons (nth position namelist) filtered-list))
1058         ))
1059      keepers)
1060     filtered-list))
1061
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)
1079
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 " ")
1093
1094          author (concat firstname " " middlenames (and midnames " ") lastname)
1095
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))
1120                         )
1121                        sc-mail-info)
1122          ))
1123     ;; from string is empty
1124     (push (cons "sc-author" sc-default-author-name) sc-mail-info)))
1125
1126 (defvar sc-attrib-or-cite nil
1127   "Used to toggle between attribution input or citation input.")
1128
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))
1135
1136 (defun sc-select-attribution ()
1137   "Select an attribution from `sc-attributions'.
1138
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'.
1145
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))
1156
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"))
1181              )))
1182          ((setq attribution (cdr (assoc preferred sc-attributions)))
1183           (setq attriblist nil))
1184          (t
1185           (setq attriblist (cdr attriblist)))
1186          )))
1187
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)))))
1206
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))
1212
1213     ;; create the attribution prefix
1214     (setq citation (sc-make-citation attribution))
1215
1216     ;; run the post selection hook before querying the user
1217     (run-hooks 'sc-attribs-postselect-hook)
1218
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)
1245                           ))
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))
1253
1254             (setq citation (sc-make-citation choice)
1255                   attribution choice))
1256           ))
1257
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)))
1263
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)))
1275
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)))
1282     ))
1283
1284 \f
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...
1289
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))
1300
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))
1307
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))))
1315
1316 \f
1317 ;; ======================================================================
1318 ;; citing and unciting regions of text
1319
1320 (defvar sc-fill-begin 1
1321   "Buffer position to begin filling.")
1322 (defvar sc-fill-line-prefix ""
1323   "Fill prefix of previous line")
1324
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))))
1342     )
1343   nil)
1344
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))
1362
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))
1368
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)))
1386
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)))
1397
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)
1409
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)
1416
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)
1426
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'.
1433
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)))
1447
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)))
1459
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)))
1473
1474 \f
1475 ;; ======================================================================
1476 ;; building headers
1477
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) "")))
1488
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")))
1493
1494 (defun sc-no-header ()
1495   "Does nothing.  Use this instead of nil to get a blank header."
1496   ())
1497
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))))))
1509
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"))))
1520
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"))))
1530
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"))))
1540
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)
1552                     "")
1553                 " writes:\n"))))
1554
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"))))
1563
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                 ))))
1592
1593 \f
1594 ;; ======================================================================
1595 ;; header rewrites
1596
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.")
1601
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))
1610
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)
1629               ))
1630       )))
1631
1632 (defun sc-electric-mode (&optional arg)
1633   "
1634 Mode for viewing Supercite reference headers.  Commands are:
1635 \n\\{sc-electric-mode-map}
1636
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."
1642
1643   (let ((info sc-mail-info))
1644
1645     (setq sc-eref-style
1646           (or (sc-valid-index-p arg)
1647               (sc-valid-index-p sc-preferred-header-style)
1648               0))
1649
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)
1664           )))
1665
1666     (and sc-eref-style
1667          (sc-eref-insert-selected))
1668     (kill-buffer sc-electric-bufname)
1669     ))
1670
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
1685                 0
1686               (progn (error msg "follow") (1- last))))
1687            ))
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)))
1704                )))
1705        ))))
1706
1707 (defun sc-eref-next ()
1708   "Display next reference in other buffer."
1709   (interactive)
1710   (sc-eref-show (1+ sc-eref-style)))
1711
1712 (defun sc-eref-prev ()
1713   "Display previous reference in other buffer."
1714   (interactive)
1715   (sc-eref-show (1- sc-eref-style)))
1716
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))
1722
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)))
1732     ))
1733
1734 (defun sc-eref-jump ()
1735   "Set reference header to preferred header."
1736   (interactive)
1737   (sc-eref-show sc-preferred-header-style))
1738
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))
1744
1745 (defun sc-eref-exit ()
1746   "Exit from electric reference mode and insert selected reference."
1747   (interactive)
1748   (exit-recursive-edit))
1749
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'.
1755
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         ))))
1770
1771 \f
1772 ;; ======================================================================
1773 ;; variable toggling
1774
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))
1782
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)))))
1790
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.
1796
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
1814                                  var
1815                                  'variable-documentation)
1816                                 1))
1817               (with-current-buffer standard-output
1818                 (help-mode))
1819               nil))))
1820     (set var (eval-minibuffer (format "Set %s to value: " var)))))
1821
1822 (defmacro sc-toggle-symbol (rootname)
1823   `(defun ,(intern (concat "sc-T-" rootname)) ()
1824      (interactive)
1825      (sc-toggle-var ',(intern (concat "sc-" rootname "-p")))))
1826
1827 (defmacro sc-setvar-symbol (rootname)
1828   `(defun ,(intern (concat "sc-S-" rootname)) ()
1829      (interactive)
1830      (sc-set-variable ',(intern (concat "sc-" rootname)))))
1831
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")
1841
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")
1847
1848 (defun sc-T-describe ()
1849   "
1850
1851 Supercite provides a number of key bindings which simplify the process
1852 of setting or toggling certain variables controlling its operation.
1853
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.
1858
1859 \\{sc-T-keymap}"
1860   (interactive)
1861   (describe-function 'sc-T-describe))
1862
1863 \f
1864 ;; ======================================================================
1865 ;; published interface to mail and news readers
1866
1867 (define-minor-mode sc-minor-mode
1868   "Supercite minor mode."
1869   nil (" SC" (sc-auto-fill-region-p
1870               (":f" (sc-fixup-whitespace-p "w"))
1871               (sc-fixup-whitespace-p ":w")))
1872   `((,sc-mode-map-prefix . ,sc-mode-map)))
1873
1874 ;;;###autoload
1875 (defun sc-cite-original ()
1876   "Workhorse citing function which performs the initial citation.
1877 This is callable from the various mail and news readers' reply
1878 function according to the agreed upon standard.  See the associated
1879 info node `(SC)Top' for more details.
1880 `sc-cite-original' does not do any yanking of the
1881 original message but it does require a few things:
1882
1883      1) The reply buffer is the current buffer.
1884
1885      2) The original message has been yanked and inserted into the
1886         reply buffer.
1887
1888      3) Verbose mail headers from the original message have been
1889         inserted into the reply buffer directly before the text of the
1890         original message.
1891
1892      4) Point is at the beginning of the verbose headers.
1893
1894      5) Mark is at the end of the body of text to be cited.
1895
1896 For Emacs 19's, the region need not be active (and typically isn't
1897 when this function is called.  Also, the hook `sc-pre-hook' is run
1898 before, and `sc-post-hook' is run after the guts of this function."
1899   (run-hooks 'sc-pre-hook)
1900
1901   (sc-minor-mode 1)
1902
1903   (undo-boundary)
1904
1905   ;; grab point and mark since the region is probably not active when
1906   ;; this function gets automatically called. we want point to be a
1907   ;; mark so any deleting before point works properly
1908   (let* ((zmacs-regions nil)            ; for XEemacs
1909          (mark-active t)                ; for Emacs
1910          (point (point-marker))
1911          (mark  (copy-marker (mark-marker))))
1912
1913     ;; make sure point comes before mark, not all functions are
1914     ;; interactive "r"
1915     (if (< mark point)
1916         (let ((tmp point))
1917           (setq point mark
1918                 mark tmp)))
1919
1920     ;; first process mail headers, and populate sc-mail-info
1921     (sc-mail-process-headers point mark)
1922
1923     ;; now get possible attributions
1924     (sc-attribs-chop-address (or (sc-mail-field "from")
1925                                  (sc-mail-field "reply")
1926                                  (sc-mail-field "reply-to")
1927                                  (sc-mail-field "sender")))
1928     ;; select the attribution
1929     (sc-select-attribution)
1930
1931     ;; cite the region, but first check the value of sc-cite-region-limit
1932     (let ((linecnt (count-lines point mark)))
1933       (and sc-cite-region-limit
1934            (if (or (not (numberp sc-cite-region-limit))
1935                    (<= linecnt sc-cite-region-limit))
1936                (progn
1937                  ;; cite the region and insert the header rewrite
1938                  (sc-cite-region point mark)
1939                  (goto-char point)
1940                  (let ((sc-eref-style (or sc-preferred-header-style 0)))
1941                    (if sc-electric-references-p
1942                        (sc-electric-mode sc-eref-style)
1943                      (sc-eref-insert-selected t))))
1944              (beep)
1945              (message
1946               "Region not cited. %d lines exceeds sc-cite-region-limit: %d"
1947               linecnt sc-cite-region-limit))))
1948
1949     ;; finally, free the point-marker
1950     (set-marker point nil)
1951     (set-marker mark nil)
1952     )
1953   (run-hooks 'sc-post-hook))
1954
1955 \f
1956 ;; ======================================================================
1957 ;; bug reporting and miscellaneous commands
1958
1959 (defun sc-open-line (arg)
1960   "Like `open-line', but insert the citation prefix at the front of the line.
1961 With numeric ARG, inserts that many new lines."
1962   (interactive "p")
1963   (save-excursion
1964     (let ((start (point))
1965           (prefix (or (progn (beginning-of-line)
1966                              (if (looking-at (sc-cite-regexp))
1967                                  (match-string 0)))
1968                       "")))
1969       (goto-char start)
1970       (open-line arg)
1971       (forward-line 1)
1972       (while (< 0 arg)
1973         (insert prefix)
1974         (forward-line 1)
1975         (setq arg (1- arg))
1976         ))))
1977
1978 (defun sc-insert-citation (arg)
1979   "Insert citation string at beginning of current line if not already cited.
1980 With `\\[universal-argument]' insert citation even if line is already
1981 cited."
1982   (interactive "P")
1983   (save-excursion
1984     (beginning-of-line)
1985     (if (or (not (looking-at (sc-cite-regexp)))
1986             (looking-at "^[ \t]*$")
1987             (consp arg))
1988         (insert (sc-mail-field "sc-citation"))
1989       (error "Line is already cited"))))
1990
1991 (defun sc-version (message)
1992   "Echo the current version of Supercite in the minibuffer.
1993 If MESSAGE is non-nil (interactively, with no prefix argument),
1994 inserts the version string in the current buffer instead."
1995   (interactive (not current-prefix-arg))
1996   (let ((verstr (format "Using Supercite.el %s" sc-version)))
1997     (if message
1998         (message verstr)
1999       (insert "`sc-version' says: " verstr))))
2000
2001 (defun sc-describe ()
2002   "
2003 Supercite is a package which provides a flexible mechanism for citing
2004 email and news replies.  Please see the associated texinfo file for
2005 more information.  Info node `(SC)Top'."
2006   (interactive)
2007   (describe-function 'sc-describe))
2008
2009 (defun sc-submit-bug-report ()
2010   "Submit a bug report on Supercite via mail."
2011   (interactive)
2012   (require 'reporter)
2013   (and
2014    (y-or-n-p "Do you want to submit a report on Supercite? ")
2015    (reporter-submit-bug-report
2016     sc-help-address
2017     (concat "Supercite version " sc-version)
2018     (list
2019      'sc-attrib-selection-list
2020      'sc-auto-fill-region-p
2021      'sc-blank-lines-after-headers
2022      'sc-citation-leader
2023      'sc-citation-delimiter
2024      'sc-citation-separator
2025      'sc-citation-leader-regexp
2026      'sc-citation-root-regexp
2027      'sc-citation-nonnested-root-regexp
2028      'sc-citation-delimiter-regexp
2029      'sc-citation-separator-regexp
2030      'sc-cite-region-limit
2031      'sc-confirm-always-p
2032      'sc-default-attribution
2033      'sc-default-author-name
2034      'sc-downcase-p
2035      'sc-electric-circular-p
2036      'sc-electric-references-p
2037      'sc-fixup-whitespace-p
2038      'sc-mail-warn-if-non-rfc822-p
2039      'sc-mumble
2040      'sc-name-filter-alist
2041      'sc-nested-citation-p
2042      'sc-nuke-mail-headers
2043      'sc-nuke-mail-header-list
2044      'sc-preferred-attribution-list
2045      'sc-preferred-header-style
2046      'sc-reference-tag-string
2047      'sc-rewrite-header-list
2048      'sc-titlecue-regexp
2049      'sc-use-only-preference-p
2050      ))))
2051
2052 \f
2053 ;; useful stuff
2054 (provide 'supercite)
2055 (run-hooks 'sc-load-hook)
2056
2057 ;;; arch-tag: a5d5bfa6-3bd5-4414-8c65-0afc83e45cd3
2058 ;;; supercite.el ends here