lisp/sc.el

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