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