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