home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / mail-extr.el < prev    next >
Encoding:
Text File  |  1992-09-10  |  48.4 KB  |  1,503 lines
  1. ;; Extract full name and canonical address from RFC 822 mail header.
  2. ;; Copyright (C) 1991, 1992 Free Software Foundation, Inc.
  3.  
  4. ;; This program is free software; you can redistribute it and/or modify it
  5. ;; under the terms of the GNU General Public License as published by the
  6. ;; Free Software Foundation; either version 2, or (at your option) any
  7. ;; later version.
  8.  
  9. ;; This program is distributed in the hope that it will be useful, but
  10. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12. ;; General Public License for more details.
  13.  
  14. ;; You should have received a copy of the GNU General Public License along
  15. ;; with GNU Emacs, which you need to use this program; see the file
  16. ;; COPYING.  If not, write to the Free Software Foundation, 675 Mass Ave,
  17. ;; Cambridge, MA 02139, USA.
  18.  
  19. ;; LCD Archive Entry:
  20. ;; mail-extr|Joe Wells|jbw@cs.bu.edu
  21. ;; |Extract full name and canonical address from RFC 822 mail header.
  22. ;; |April 7 1992|1.0|????
  23.  
  24. ;; Created by: Joe Wells, jbw@maverick
  25. ;; Created on: Fri Jun 14 19:39:50 1991
  26. ;; Last modified by: Joe Wells, jbw@bigbird.bu.edu
  27. ;; Last modified on: Tue Apr  7 00:24:14 1992
  28. ;; Filename: mail-extr.el
  29. ;; Purpose: Extract full name and canonical address from RFC 822 mail header.
  30. ;; Version: 1.0
  31. ;; Change log: 
  32. ;; 
  33. ;; Fri Apr 24 23:35:56 1992  Jamie Zawinski (jwz@lucid.com)
  34. ;;
  35. ;;      * hack hack
  36. ;;
  37. ;; Mon Apr  6 23:59:09 1992  Joe Wells  (jbw at bigbird.bu.edu)
  38. ;; 
  39. ;;     * Cleaned up some more.  Release version 1.0 to world.
  40. ;; 
  41. ;; Sun Apr  5 19:39:08 1992  Joe Wells  (jbw at bigbird.bu.edu)
  42. ;; 
  43. ;;     * Cleaned up full name extraction extensively.
  44. ;; 
  45. ;; Sun Feb  2 14:45:24 1992  Joe Wells  (jbw at bigbird.bu.edu)
  46. ;; 
  47. ;;     * Total rewrite.  Integrated mail-canonicalize-address into
  48. ;;     mail-extract-address-components.  Now handles GROUP addresses more
  49. ;;     or less correctly.  Better handling of lots of different cases.
  50. ;; 
  51.  
  52. ;; Here is `mail-extr', a package for extracting full names and canonical
  53. ;; addresses from RFC 822 mail headers.  It is intended to be hooked into
  54. ;; other Emacs Lisp packages that deal with RFC 822 format messages, such as
  55. ;; Gnews, GNUS, RMAIL, MH-E, BBDB, VM, Supercite, etc.  Thus, this release is
  56. ;; mainly for Emacs Lisp developers.
  57.  
  58. ;; There are two main benefits:
  59.  
  60. ;; 1. Higher probability of getting the correct full name for a human than
  61. ;;    any other package I know of.  (On the other hand, it will cheerfully
  62. ;;    mangle non-human names/comments.)
  63. ;; 2. Address part is put in a canonical form.
  64.  
  65. ;; The interface is not yet carved in stone; please give me suggestions.
  66.  
  67. ;; I have an extensive test-case collection of funny addresses if you want to
  68. ;; work with the code.  Developing this code requires frequent testing to
  69. ;; make sure you're not breaking functionality.  I'm not posting the
  70. ;; test-cases because they take over 100K.
  71.  
  72. ;; If you find an address that mail-extr fails on, please send it to me along
  73. ;; with what you think the correct results should be.  I do not consider it a
  74. ;; bug if mail-extr mangles a comment that does not correspond to a real
  75. ;; human full name, although I would prefer that mail-extr would return the
  76. ;; comment as-is.
  77.  
  78. ;; Features:
  79.  
  80. ;; * Full name handling:
  81.  
  82. ;;   * knows where full names can be found in an address.
  83. ;;   * avoids using empty comments and quoted text.
  84. ;;   * extracts full names from mailbox names.
  85. ;;   * recognizes common formats for comments after a full name.
  86. ;;   * puts a period and a space after each initial.
  87. ;;   * understands & referring to the mailbox name capitalized.
  88. ;;   * strips name prefixes like "Prof.", etc..
  89. ;;   * understands what characters can occur in names (not just letters).
  90. ;;   * figures out middle initial from mailbox name.
  91. ;;   * removes funny nicknames.
  92. ;;   * keeps suffixes such as Jr., Sr., III, etc.
  93. ;;   * reorders "Last, First" type names.
  94.  
  95. ;; * Address handling:
  96.  
  97. ;;   * parses rfc822 quoted text, comments, and domain literals.
  98. ;;   * parses rfc822 multi-line headers.
  99. ;;   * does something reasonable with rfc822 GROUP addresses.
  100. ;;   * handles many rfc822 noncompliant and garbage addresses.
  101. ;;   * canonicalizes addresses (after stripping comments/phrases outside <>).
  102. ;;     * converts ! addresses into .UUCP and %-style addresses.
  103. ;;     * converts rfc822 ROUTE addresses to %-style addresses.
  104. ;;     * truncates %-style addresses at leftmost fully qualified domain name.
  105. ;;     * handles local relative precedence of ! vs. % and @ (untested).
  106.  
  107. ;; It does almost no string creation.  It primarily uses the built-in
  108. ;; parsing routines with the appropriate syntax tables.  This should
  109. ;; result in greater speed.
  110.  
  111. ;; TODO:
  112.  
  113. ;; * handle all test cases.  (This will take forever.)
  114. ;; * software to pick the correct header to use (eg., "Senders-Name:").
  115. ;; * multiple addresses in the "From:" header (almost all of the necessary
  116. ;;   code is there).
  117. ;; * flag to not treat `,' as an address separator.  (This is useful when
  118. ;;   there is a "From:" header but no "Sender:" header, because then there
  119. ;;   is only allowed to be one address.)
  120. ;; * mailbox name does not necessarily contain full name.
  121. ;; * fixing capitalization when it's all upper or lowercase.  (Hard!)
  122. ;; * some of the domain literal handling is missing.  (But I've never even
  123. ;;   seen one of these in a mail address, so maybe no big deal.)
  124. ;; * arrange to have syntax tables byte-compiled.
  125. ;; * speed hacks.
  126. ;; * delete unused variables.
  127. ;; * arrange for testing with different relative precedences of ! vs. @
  128. ;;   and %.
  129. ;; * put variant-method back into mail-extract-address-components.
  130. ;; * insert documentation strings!
  131. ;; * handle X.400-gatewayed addresses according to RFC 1148.
  132.  
  133.  
  134. ;; Variable definitions.
  135.  
  136. (defvar mail-extr-guess-middle-initial nil
  137.   "*If true, then when we see an address like \"John Smith <jqs@host.com>\"
  138. we will assume that \"John Q. Smith\" is the fellow's name.")
  139.  
  140. (defvar mail-extr-mangle-uucp nil
  141.   "*If true, then bang-paths like \"foo!bar!baz@host\" will be turned 
  142. into \"baz@bar.UUCP\".")
  143.  
  144.  
  145. (defvar mail-@-binds-tighter-than-! nil)
  146.  
  147. ;;----------------------------------------------------------------------
  148. ;; what orderings are meaningful?????
  149. ;;(defvar mail-operator-precedence-list '(?! ?% ?@))
  150. ;; Right operand of a % or a @ must be a domain name, period.  No other
  151. ;; operators allowed.  Left operand of a @ is an address relative to that
  152. ;; site.
  153.  
  154. ;; Left operand of a ! must be a domain name.  Right operand is an
  155. ;; arbitrary address.
  156. ;;----------------------------------------------------------------------
  157.  
  158. (defconst mail-space-char 32)
  159.  
  160. (defconst mail-whitespace " \t\n")
  161.  
  162. ;; Any character that can occur in a name in an RFC822 address.
  163. ;; Yes, there are weird people with digits in their names.
  164. (defconst mail-all-letters "A-Za-z---{|}'~0-9`.")
  165.  
  166. ;; Any character that can occur in a name, not counting characters that
  167. ;; separate parts of a multipart name.
  168. (defconst mail-all-letters-but-separators "A-Za-z{|}'~0-9`")
  169.  
  170. ;; Any character that can start a name
  171. (defconst mail-first-letters "A-Za-z")
  172.  
  173. ;; Any character that can end a name.
  174. (defconst mail-last-letters "A-Za-z`'.")
  175.  
  176. ;; Matches an initial not followed by both a period and a space. 
  177. (defconst mail-bad-initials-pattern
  178.   (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
  179.       mail-all-letters mail-first-letters mail-all-letters))
  180.  
  181. (defconst mail-non-name-chars (concat "^" mail-all-letters "."))
  182.  
  183. (defconst mail-non-begin-name-chars (concat "^" mail-first-letters))
  184.  
  185. (defconst mail-non-end-name-chars (concat "^" mail-last-letters))
  186.  
  187. ;; Matches periods used instead of spaces.  Must not match the period
  188. ;; following an initial.
  189. (defconst mail-bad-\.-pattern
  190.   (format "\\([%s][%s]\\)\\.+\\([%s]\\)"
  191.       mail-all-letters mail-last-letters mail-first-letters))
  192.  
  193. ;; Matches an embedded or leading nickname that should be removed.
  194. (defconst mail-nickname-pattern
  195.   (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] "
  196.       mail-all-letters))
  197.  
  198. ;; Matches a leading title that is not part of the name (does not
  199. ;; contribute to uniquely identifying the person).
  200. (defconst mail-full-name-prefixes
  201.       '"\\` *\\(Prof\\|Dr\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.? ")
  202.  
  203. ;; Matches the occurrence of a generational name suffix, and the last
  204. ;; character of the preceding name.
  205. (defconst mail-full-name-suffix-pattern
  206.   (format
  207.    "\\(,? ?\\([JjSs]r\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)"
  208.    mail-all-letters mail-all-letters))
  209.  
  210. (defconst mail-roman-numeral-pattern
  211.   "V?I+V?\\b")
  212.  
  213. ;; Matches a trailing uppercase (with other characters possible) acronym.
  214. ;; Must not match a trailing uppercase last name or trailing initial
  215. (defconst mail-weird-acronym-pattern "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)")
  216.       
  217. ;; Matches a mixed-case or lowercase name (not an initial).
  218. (defconst mail-mixed-case-name-pattern
  219.   (format
  220.    "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)"
  221.    mail-all-letters mail-last-letters
  222.    mail-first-letters mail-all-letters mail-all-letters mail-last-letters
  223.    mail-first-letters mail-all-letters))
  224.  
  225. ;; Matches a trailing alternative address.
  226. (defconst mail-alternative-address-pattern "[a-zA-Z.]+[!@][a-zA-Z.]")
  227.  
  228. ;; Matches a variety of trailing comments not including comma-delimited
  229. ;; comments.
  230. (defconst mail-trailing-comment-start-pattern " [-{]\\|--\\|[+@#></\;]")
  231.  
  232. ;; Matches a name (not an initial).
  233. ;; This doesn't force a word boundary at the end because sometimes a
  234. ;; comment is separated by a `-' with no preceding space.
  235. (defconst mail-name-pattern
  236.   (format
  237.    "\\b[%s][%s]*[%s]"
  238.    mail-first-letters mail-all-letters mail-last-letters))
  239.  
  240. (defconst mail-initial-pattern
  241.   (format "\\b[%s]\\([. ]\\|\\b\\)" mail-first-letters))
  242.  
  243. ;; Matches a single name before a comma.
  244. (defconst mail-last-name-first-pattern
  245.   (concat "\\`" mail-name-pattern ","))
  246.  
  247. ;; Matches telephone extensions.
  248. (defconst mail-telephone-extension-pattern
  249.   "\\(\\([Ee]xt\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+")
  250.  
  251. ;; Matches ham radio call signs.
  252. (defconst mail-ham-call-sign-pattern
  253.   "\\b[A-Z]+[0-9][A-Z0-9]*")
  254.  
  255. ;; Matches normal single-part name
  256. (defconst mail-normal-name-pattern
  257.   (format
  258.    "\\b[%s][%s]+[%s]"
  259.    mail-first-letters mail-all-letters-but-separators mail-last-letters))
  260.  
  261. ;; Matches normal two names with missing middle initial
  262. (defconst mail-two-name-pattern
  263.   (concat "\\`\\(" mail-normal-name-pattern
  264.       "\\|" mail-initial-pattern
  265.       "\\) +\\(" mail-normal-name-pattern "\\)\\(,\\|\\'\\)"))
  266.  
  267. (defvar address-syntax-table (make-syntax-table))
  268. (defvar address-comment-syntax-table (make-syntax-table))
  269. (defvar address-domain-literal-syntax-table (make-syntax-table))
  270. (defvar address-text-comment-syntax-table (make-syntax-table))
  271. (defvar address-text-syntax-table (make-syntax-table))
  272. (mapcar
  273.  (function
  274.   (lambda (pair)
  275.     (let ((syntax-table (symbol-value (car pair))))
  276.       (mapcar
  277.        (function
  278.     (lambda (item)
  279.       (if (eq 2 (length item))
  280.           (modify-syntax-entry (car item) (car (cdr item)) syntax-table)
  281.         (let ((char (car item))
  282.           (bound (car (cdr item)))
  283.           (syntax (car (cdr (cdr item)))))
  284.           (while (<= char bound)
  285.         (modify-syntax-entry char syntax syntax-table)
  286.         (setq char (1+ char)))))))
  287.        (cdr pair)))))
  288.  '((address-syntax-table
  289.     (0  31   "w")            ;control characters
  290.     (32      " ")            ;SPC
  291.     (?! ?~   "w")            ;printable characters
  292.     (127     "w")            ;DEL
  293.     (128 255 "w")            ;high-bit-on characters
  294.     (?\t " ")
  295.     (?\r " ")
  296.     (?\n " ")
  297.     (?\( ".")
  298.     (?\) ".")
  299.     (?<  ".")
  300.     (?>  ".")
  301.     (?@  ".")
  302.     (?,  ".")
  303.     (?\; ".")
  304.     (?:  ".")
  305.     (?\\ "\\")
  306.     (?\" "\"")
  307.     (?.  ".")
  308.     (?\[ ".")
  309.     (?\] ".")
  310.     ;; % and ! aren't RFC822 characters, but it is convenient to pretend
  311.     (?%  ".")
  312.     (?!  ".") ;; this needs to be word-constituent when not in .UUCP mode
  313.     )
  314.    (address-comment-syntax-table
  315.     (0 255 "w")
  316.     (?\( "\(\)")
  317.     (?\) "\)\(")
  318.     (?\\ "\\"))
  319.    (address-domain-literal-syntax-table
  320.     (0 255 "w")
  321.     (?\[ "\(\]")            ;??????
  322.     (?\] "\)\[")            ;??????
  323.     (?\\ "\\"))
  324.    (address-text-comment-syntax-table
  325.     (0 255 "w")
  326.     (?\( "\(\)")
  327.     (?\) "\)\(")
  328.     (?\[ "\(\]")
  329.     (?\] "\)\[")
  330.     (?\{ "\(\}")
  331.     (?\} "\)\{")
  332.     (?\\ "\\")
  333.     (?\" "\"")
  334.     ;; (?\' "\)\`")
  335.     ;; (?\` "\(\'")
  336.     )
  337.    (address-text-syntax-table
  338.     (0 255 ".")
  339.     (?A ?Z "w")
  340.     (?a ?z "w")
  341.     (?-    "w")
  342.     (?\}   "w")
  343.     (?\{   "w")
  344.     (?|    "w")
  345.     (?\'   "w")
  346.     (?~    "w")
  347.     (?0 ?9 "w"))
  348.    ))
  349.  
  350.  
  351. ;; Utility functions and macros.
  352.  
  353. (defmacro undo-backslash-quoting (beg end)
  354.   (`(save-excursion
  355.       (save-restriction
  356.     (narrow-to-region (, beg) (, end))
  357.     (goto-char (point-min))
  358.     ;; undo \ quoting
  359.     (while (search-forward "\\" nil t)
  360.       (delete-char -1)
  361.       (or (eobp)
  362.           (forward-char 1))
  363.       )))))
  364.  
  365. (defmacro mail-nuke-char-at (pos)
  366.   (` (save-excursion
  367.        (goto-char (, pos))
  368.        (delete-char 1)
  369.        (insert mail-space-char))))
  370.  
  371. (defmacro mail-nuke-elements-outside-range (list-symbol beg-symbol end-symbol
  372.                             &optional no-replace)
  373.   (` (progn
  374.        (setq temp (, list-symbol))
  375.        (while temp
  376.      (cond ((or (> (car temp) (, end-symbol))
  377.             (< (car temp) (, beg-symbol)))
  378.         (, (or no-replace
  379.                (` (mail-nuke-char-at (car temp)))))
  380.         (setcar temp nil)))
  381.      (setq temp (cdr temp)))
  382.        (setq (, list-symbol) (delq nil (, list-symbol))))))
  383.  
  384. (defun mail-demarkerize (marker)
  385.   (and marker
  386.        (if (markerp marker)
  387.        (let ((temp (marker-position marker)))
  388.          (set-marker marker nil)
  389.          temp)
  390.      marker)))
  391.  
  392. (defun mail-markerize (pos)
  393.   (and pos
  394.        (if (markerp pos)
  395.        pos
  396.      (copy-marker pos))))
  397.  
  398. (defmacro mail-last-element (list)
  399.   "Return last element of LIST."
  400.   (` (let ((list (, list)))
  401.        (while (not (null (cdr list)))
  402.      (setq list (cdr list)))
  403.        (car list))))
  404.   
  405. (defmacro safe-move-sexp (arg)
  406.   "Safely skip over one balanced sexp, if there is one.  Return t if success."
  407.   (` (condition-case error
  408.      (progn
  409.        (goto-char (scan-sexps (point) (, arg)))
  410.        t)
  411.        (error
  412.     (if (string-equal (nth 1 error) "Unbalanced parentheses")
  413.         nil
  414.       (while t
  415.         (signal (car error) (cdr error))))))))
  416.  
  417.  
  418. ;; The main function to grind addresses
  419.  
  420. (defun mail-extract-address-components (address)
  421.   "Given an rfc 822 ADDRESS, extract full name and canonical address.
  422. Returns a list of the form (FULL-NAME CANONICAL-ADDRESS)."
  423.   (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
  424.     (extraction-buffer (get-buffer-create " *extract address components*"))
  425.     (foo 'bar)
  426.     char
  427.     multiple-addresses
  428.     <-pos >-pos @-pos :-pos ,-pos !-pos %-pos \;-pos
  429.     group-:-pos group-\;-pos route-addr-:-pos
  430.     record-pos-symbol
  431.     first-real-pos last-real-pos
  432.     phrase-beg phrase-end
  433.     comment-beg comment-end
  434.     quote-beg quote-end
  435.     atom-beg atom-end
  436.     mbox-beg mbox-end
  437.     \.-ends-name
  438.     temp
  439.     name-suffix
  440.     saved-point
  441.     fi mi li
  442.     saved-%-pos saved-!-pos saved-@-pos
  443.     domain-pos \.-pos insert-point)
  444.     
  445.     (save-excursion
  446.       (set-buffer extraction-buffer)
  447.       (buffer-flush-undo extraction-buffer)
  448.       (set-syntax-table address-syntax-table)
  449.       (widen)
  450.       (erase-buffer)
  451.       (setq case-fold-search nil)
  452.       
  453.       ;; Insert extra space at beginning to allow later replacement with <
  454.       ;; without having to move markers.
  455.       (insert mail-space-char address)
  456.       
  457.       ;; stolen from rfc822.el
  458.       ;; Unfold multiple lines.
  459.       (goto-char (point-min))
  460.       (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
  461.     (replace-match "\\1 " t))
  462.       
  463.       ;; first pass grabs useful information about address
  464.       (goto-char (point-min))
  465.       (while (progn
  466.            (skip-chars-forward mail-whitespace)
  467.            (not (eobp)))
  468.     (setq char (char-after (point)))
  469.     (or first-real-pos
  470.         (if (not (eq char ?\())
  471.         (setq first-real-pos (point))))
  472.     (cond
  473.      ;; comment
  474.      ((eq char ?\()
  475.       (set-syntax-table address-comment-syntax-table)
  476.       ;; only record the first non-empty comment's position
  477.       (if (and (not comment-beg)
  478.            (save-excursion
  479.              (forward-char 1)
  480.              (skip-chars-forward mail-whitespace)
  481.              (not (eq ?\) (char-after (point))))))
  482.           (setq comment-beg (point)))
  483.       ;; TODO: don't record if unbalanced
  484.       (or (safe-move-sexp 1)
  485.           (forward-char 1))
  486.       (set-syntax-table address-syntax-table)
  487.       (if (and comment-beg
  488.            (not comment-end))
  489.           (setq comment-end (point))))
  490.      ;; quoted text
  491.      ((eq char ?\")
  492.       ;; only record the first non-empty quote's position
  493.       (if (and (not quote-beg)
  494.            (save-excursion
  495.              (forward-char 1)
  496.              (skip-chars-forward mail-whitespace)
  497.              (not (eq ?\" (char-after (point))))))
  498.           (setq quote-beg (point)))
  499.       ;; TODO: don't record if unbalanced
  500.       (or (safe-move-sexp 1)
  501.           (forward-char 1))
  502.       (if (and quote-beg
  503.            (not quote-end))
  504.           (setq quote-end (point))))
  505.      ;; domain literals
  506.      ((eq char ?\[)
  507.       (set-syntax-table address-domain-literal-syntax-table)
  508.       (or (safe-move-sexp 1)
  509.           (forward-char 1))
  510.       (set-syntax-table address-syntax-table))
  511.      ;; commas delimit addresses when outside < > pairs.
  512.      ((and (eq char ?,)
  513.            (or (null <-pos)
  514.            (and >-pos
  515.             ;; handle weird munged addresses
  516.             (> (mail-last-element <-pos) (car >-pos)))))
  517. ;; It'd be great if some day this worked, but for now, punt.
  518. ;;      (setq multiple-addresses t)
  519. ;;      (delete-char 1)
  520. ;;      (narrow-to-region (point-min) (point))
  521.       (delete-region (point) (point-max))
  522.       (setq char ?\() ; HAVE I NO SHAME??
  523.       )
  524.      ;; record the position of various interesting chars, determine
  525.      ;; legality later.
  526.      ((setq record-pos-symbol
  527.         (cdr (assq char
  528.                '((?< . <-pos) (?> . >-pos) (?@ . @-pos)
  529.                  (?: . :-pos) (?, . ,-pos) (?! . !-pos)
  530.                  (?% . %-pos) (?\; . \;-pos)))))
  531.       (set record-pos-symbol
  532.            (cons (point) (symbol-value record-pos-symbol)))
  533.       (forward-char 1))
  534.      ((eq char ?.)
  535.       (forward-char 1))
  536.      ((memq char '(
  537.                ;; comment terminator illegal
  538.                ?\)
  539.                ;; domain literal terminator illegal
  540.                ?\]
  541.                ;; \ allowed only within quoted strings,
  542.                ;; domain literals, and comments
  543.                ?\\
  544.                ))
  545.       (mail-nuke-char-at (point))
  546.       (forward-char 1))
  547.      (t
  548.       (forward-word 1)))
  549.     (or (eq char ?\()
  550.         (setq last-real-pos (point))))
  551.       
  552.       ;; Use only the leftmost <, if any.  Replace all others with spaces.
  553.       (while (cdr <-pos)
  554.     (mail-nuke-char-at (car <-pos))
  555.     (setq <-pos (cdr <-pos)))
  556.       
  557.       ;; Use only the rightmost >, if any.  Replace all others with spaces.
  558.       (while (cdr >-pos)
  559.     (mail-nuke-char-at (nth 1 >-pos))
  560.     (setcdr >-pos (nthcdr 2 >-pos)))
  561.       
  562.       ;; If multiple @s and a :, but no < and >, insert around buffer.
  563.       ;; This commonly happens on the UUCP "From " line.  Ugh.
  564.       (cond ((and (> (length @-pos) 1)
  565.           :-pos            ;TODO: check if between @s
  566.           (not <-pos))
  567.          (goto-char (point-min))
  568.          (delete-char 1)
  569.          (setq <-pos (list (point)))
  570.          (insert ?<)))
  571.       
  572.       ;; If < but no >, insert > in rightmost possible position
  573.       (cond ((and <-pos
  574.           (null >-pos))
  575.          (goto-char (point-max))
  576.          (setq >-pos (list (point)))
  577.          (insert ?>)))
  578.       
  579.       ;; If > but no <, replace > with space.
  580.       (cond ((and >-pos
  581.           (null <-pos))
  582.          (mail-nuke-char-at (car >-pos))
  583.          (setq >-pos nil)))
  584.  
  585.       ;; Turn >-pos and <-pos into non-lists
  586.       (setq >-pos (car >-pos)
  587.         <-pos (car <-pos))
  588.       
  589.       ;; Trim other punctuation lists of items outside < > pair to handle
  590.       ;; stupid MTAs.
  591.       (cond (<-pos            ; don't need to check >-pos also
  592.          ;; handle bozo software that violates RFC 822 by sticking
  593.          ;; punctuation marks outside of a < > pair
  594.          (mail-nuke-elements-outside-range @-pos <-pos >-pos t)
  595.          ;; RFC 822 says nothing about these two outside < >, but
  596.          ;; remove those positions from the lists to make things
  597.          ;; easier.
  598.          (mail-nuke-elements-outside-range !-pos <-pos >-pos t)
  599.          (mail-nuke-elements-outside-range %-pos <-pos >-pos t)))
  600.       
  601.       ;; Check for : that indicates GROUP list and for : part of
  602.       ;; ROUTE-ADDR spec.
  603.       ;; Can't possibly be more than two :.  Nuke any extra.
  604.       (while :-pos
  605.     (setq temp (car :-pos)
  606.           :-pos (cdr :-pos))
  607.     (cond ((and <-pos >-pos
  608.             (> temp <-pos)
  609.             (< temp >-pos))
  610.            (if (or route-addr-:-pos
  611.                (< (length @-pos) 2)
  612.                (> temp (car @-pos))
  613.                (< temp (nth 1 @-pos)))
  614.            (mail-nuke-char-at temp)
  615.          (setq route-addr-:-pos temp)))
  616.           ((or (not <-pos)
  617.            (and <-pos
  618.             (< temp <-pos)))
  619.            (setq group-:-pos temp))))
  620.       
  621.       ;; Nuke any ; that is in or to the left of a < > pair or to the left
  622.       ;; of a GROUP starting :.  Also, there may only be one ;.
  623.       (while \;-pos
  624.     (setq temp (car \;-pos)
  625.           \;-pos (cdr \;-pos))
  626.     (cond ((and <-pos >-pos
  627.             (> temp <-pos)
  628.             (< temp >-pos))
  629.            (mail-nuke-char-at temp))
  630.           ((and (or (not group-:-pos)
  631.             (> temp group-:-pos))
  632.             (not group-\;-pos))
  633.            (setq group-\;-pos temp))))
  634.       
  635.       ;; Handle junk like ";@host.company.dom" that sendmail adds.
  636.       ;; **** should I remember comment positions?
  637.       (and group-\;-pos
  638.        ;; this is fine for now
  639.        (mail-nuke-elements-outside-range !-pos group-:-pos group-\;-pos t)
  640.        (mail-nuke-elements-outside-range @-pos group-:-pos group-\;-pos t)
  641.        (mail-nuke-elements-outside-range %-pos group-:-pos group-\;-pos t)
  642.        (mail-nuke-elements-outside-range ,-pos group-:-pos group-\;-pos t)
  643.        (and last-real-pos
  644.         (> last-real-pos (1+ group-\;-pos))
  645.         (setq last-real-pos (1+ group-\;-pos)))
  646.        (and comment-end
  647.         (> comment-end group-\;-pos)
  648.         (setq comment-end nil
  649.               comment-beg nil))
  650.        (and quote-end
  651.         (> quote-end group-\;-pos)
  652.         (setq quote-end nil
  653.               quote-beg nil))
  654.        (narrow-to-region (point-min) group-\;-pos))
  655.       
  656.       ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
  657.       ;; others.
  658.       ;; Hell, go ahead an nuke all of the commas.
  659.       ;; **** This will cause problems when we start handling commas in
  660.       ;; the PHRASE part .... no it won't ... yes it will ... ?????
  661.       (mail-nuke-elements-outside-range ,-pos 1 1)
  662.       
  663.       ;; can only have multiple @s inside < >.  The fact that some MTAs
  664.       ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is
  665.       ;; handled above.
  666.       
  667.       ;; Locate PHRASE part of ROUTE-ADDR.
  668.       (cond (<-pos
  669.          (goto-char <-pos)
  670.          (skip-chars-backward mail-whitespace)
  671.          (setq phrase-end (point))
  672.          (goto-char (or ;;group-:-pos
  673.                 (point-min)))
  674.          (skip-chars-forward mail-whitespace)
  675.          (if (< (point) phrase-end)
  676.          (setq phrase-beg (point))
  677.            (setq phrase-end nil))))
  678.       
  679.       ;; handle ROUTE-ADDRS with real ROUTEs.
  680.       ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and
  681.       ;; any % or ! must be semantically meaningless.
  682.       ;; TODO: do this processing into canonicalization buffer
  683.       (cond (route-addr-:-pos
  684.          (setq !-pos nil
  685.            %-pos nil
  686.            >-pos (copy-marker >-pos)
  687.            route-addr-:-pos (copy-marker route-addr-:-pos))
  688.          (goto-char >-pos)
  689.          (insert-before-markers ?X)
  690.          (goto-char (car @-pos))
  691.          (while (setq @-pos (cdr @-pos))
  692.            (delete-char 1)
  693.            (setq %-pos (cons (point-marker) %-pos))
  694.            (insert "%")
  695.            (goto-char (1- >-pos))
  696.            (save-excursion
  697.          (insert-buffer-substring extraction-buffer
  698.                       (car @-pos) route-addr-:-pos)
  699.          (delete-region (car @-pos) route-addr-:-pos))
  700.            (or (cdr @-pos)
  701.            (setq saved-@-pos (list (point)))))
  702.          (setq @-pos saved-@-pos)
  703.          (goto-char >-pos)
  704.          (delete-char -1)
  705.          (mail-nuke-char-at route-addr-:-pos)
  706.          (mail-demarkerize route-addr-:-pos)
  707.          (setq route-addr-:-pos nil
  708.            >-pos (mail-demarkerize >-pos)
  709.            %-pos (mapcar 'mail-demarkerize %-pos))))
  710.       
  711.       ;; de-listify @-pos
  712.       (setq @-pos (car @-pos))
  713.       
  714.       ;; TODO: remove comments in the middle of an address
  715.       
  716.       (set-buffer canonicalization-buffer)
  717.       
  718.       (buffer-flush-undo canonicalization-buffer)
  719.       (set-syntax-table address-syntax-table)
  720.       (setq case-fold-search nil)
  721.       
  722.       (widen)
  723.       (erase-buffer)
  724.       (insert-buffer-substring extraction-buffer)
  725.       
  726.       (if <-pos
  727.       (narrow-to-region (progn
  728.                   (goto-char (1+ <-pos))
  729.                   (skip-chars-forward mail-whitespace)
  730.                   (point))
  731.                 >-pos)
  732.     ;; ****** Oh no!  What if the address is completely empty!
  733.     (narrow-to-region first-real-pos last-real-pos))
  734.       
  735.       (and @-pos %-pos
  736.        (mail-nuke-elements-outside-range %-pos (point-min) @-pos))
  737.       (and %-pos !-pos
  738.        (mail-nuke-elements-outside-range !-pos (point-min) (car %-pos)))
  739.       (and @-pos !-pos (not %-pos)
  740.        (mail-nuke-elements-outside-range !-pos (point-min) @-pos))
  741.       
  742.       ;; Error condition:?? (and %-pos (not @-pos))
  743.  
  744.       (if mail-extr-mangle-uucp
  745.       (cond (!-pos
  746.          ;; **** I don't understand this save-restriction and the
  747.          ;; narrow-to-region inside it.  Why did I do that?
  748.          (save-restriction
  749.            (cond ((and @-pos
  750.                mail-@-binds-tighter-than-!)
  751.               (goto-char @-pos)
  752.               (setq %-pos (cons (point) %-pos)
  753.                 @-pos nil)
  754.               (delete-char 1)
  755.               (insert "%")
  756.               (setq insert-point (point-max)))
  757.              (mail-@-binds-tighter-than-!
  758.               (setq insert-point (point-max)))
  759.              (%-pos
  760.               (setq insert-point (mail-last-element %-pos)
  761.                 saved-%-pos (mapcar 'mail-markerize %-pos)
  762.                 %-pos nil
  763.                 @-pos (mail-markerize @-pos)))
  764.              (@-pos
  765.               (setq insert-point @-pos)
  766.               (setq @-pos (mail-markerize @-pos)))
  767.              (t
  768.               (setq insert-point (point-max))))
  769.            (narrow-to-region (point-min) insert-point)
  770.            (setq saved-!-pos (car !-pos))
  771.            (while !-pos
  772.          (goto-char (point-max))
  773.          (cond ((and (not @-pos)
  774.                  (not (cdr !-pos)))
  775.             (setq @-pos (point))
  776.             (insert-before-markers "@ "))
  777.                (t
  778.             (setq %-pos (cons (point) %-pos))
  779.             (insert-before-markers "% ")))
  780.          (backward-char 1)
  781.          (insert-buffer-substring 
  782.           (current-buffer)
  783.           (if (nth 1 !-pos)
  784.               (1+ (nth 1 !-pos))
  785.             (point-min))
  786.           (car !-pos))
  787.          (delete-char 1)
  788.          (or (save-excursion
  789.                (safe-move-sexp -1)
  790.                (skip-chars-backward mail-whitespace)
  791.                (eq ?. (preceding-char)))
  792.              (insert-before-markers
  793.               (if (save-excursion
  794.                 (skip-chars-backward mail-whitespace)
  795.                 (eq ?. (preceding-char)))
  796.               ""
  797.             ".")
  798.               "uucp"))
  799.          (setq !-pos (cdr !-pos))))
  800.          (and saved-%-pos
  801.           (setq %-pos (append (mapcar 'mail-demarkerize saved-%-pos)
  802.                     %-pos)))
  803.          (setq @-pos (mail-demarkerize @-pos))
  804.          (narrow-to-region (1+ saved-!-pos) (point-max)))))
  805.       (cond ((and %-pos
  806.           (not @-pos))
  807.          (goto-char (car %-pos))
  808.          (delete-char 1)
  809.          (setq @-pos (point))
  810.          (insert "@")
  811.          (setq %-pos (cdr %-pos))))
  812.       (setq %-pos (nreverse %-pos))
  813.       ;; RFC 1034 doesn't approve of this, oh well:
  814.       (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
  815.       (cond (%-pos            ; implies @-pos valid
  816.          (setq temp %-pos)
  817.          (catch 'truncated
  818.            (while temp
  819.          (goto-char (or (nth 1 temp)
  820.                 @-pos))
  821.          (skip-chars-backward mail-whitespace)
  822.          (save-excursion
  823.            (safe-move-sexp -1)
  824.            (setq domain-pos (point))
  825.            (skip-chars-backward mail-whitespace)
  826.            (setq \.-pos (eq ?. (preceding-char))))
  827.          (cond ((and \.-pos
  828.                  (get
  829.                   (intern
  830.                    (buffer-substring domain-pos (point)))
  831.                   'domain-name))
  832.             (narrow-to-region (point-min) (point))
  833.             (goto-char (car temp))
  834.             (delete-char 1)
  835.             (setq @-pos (point))
  836.             (setcdr temp nil)
  837.             (setq %-pos (delq @-pos %-pos))
  838.             (insert "@")
  839.             (throw 'truncated t)))
  840.          (setq temp (cdr temp))))))
  841.       (setq mbox-beg (point-min)
  842.         mbox-end (if %-pos (car %-pos)
  843.                (or @-pos
  844.                (point-max))))
  845.       
  846.       ;; Done canonicalizing address.
  847.       
  848.       (set-buffer extraction-buffer)
  849.       
  850.       ;; Find the full name
  851.       
  852.         (cond ((and phrase-beg
  853.           (eq quote-beg phrase-beg)
  854.           (<= quote-end phrase-end))
  855.          (narrow-to-region (1+ quote-beg) (1- quote-end))
  856.          (undo-backslash-quoting (point-min) (point-max)))
  857.         (phrase-beg
  858.          (narrow-to-region phrase-beg phrase-end))
  859.         (comment-beg
  860.          (narrow-to-region (1+ comment-beg) (1- comment-end))
  861.          (undo-backslash-quoting (point-min) (point-max)))
  862.         (t
  863.          ;; *** Work in canon buffer instead?  No, can't.  Hmm.
  864.          (delete-region (point-min) (point-max))
  865.          (insert-buffer-substring canonicalization-buffer
  866.                       mbox-beg mbox-end)
  867.          (goto-char (point-min))
  868.          (setq \.-ends-name (search-forward "_" nil t))
  869.          (goto-char (point-min))
  870.  
  871.          (if (not mail-extr-mangle-uucp)
  872.          (modify-syntax-entry ?! "w" (syntax-table)))
  873.            
  874.          (while (progn
  875.               (skip-chars-forward mail-whitespace)
  876.               (not (eobp)))
  877.            (setq char (char-after (point)))
  878.            (cond
  879.         ((eq char ?\")
  880.          (setq quote-beg (point))
  881.          (or (safe-move-sexp 1)
  882.              ;; TODO: handle this error condition!!!!!
  883.              (forward-char 1))
  884.          ;; take into account deletions
  885.          (setq quote-end (- (point) 2))
  886.          (save-excursion
  887.            (backward-char 1)
  888.            (delete-char 1)
  889.            (goto-char quote-beg)
  890.            (delete-char 1))
  891.          (undo-backslash-quoting quote-beg quote-end)
  892.          (or (eq mail-space-char (char-after (point)))
  893.              (insert " "))
  894.          (setq \.-ends-name t))
  895.         ((eq char ?.)
  896.          (if (eq (char-after (1+ (point))) ?_)
  897.              (progn
  898.                (forward-char 1)
  899.                (delete-char 1)
  900.                (insert mail-space-char))
  901.            (if \.-ends-name
  902.                (narrow-to-region (point-min) (point))
  903.              (delete-char 1)
  904.              (insert " "))))
  905.         ((memq (char-syntax char) '(?. ?\\))
  906.          (delete-char 1)
  907.          (insert " "))
  908.         (t
  909.          (setq atom-beg (point))
  910.          (forward-word 1)
  911.          (setq atom-end (point))
  912.          (save-restriction
  913.            (narrow-to-region atom-beg atom-end)
  914.            (goto-char (point-min))
  915.            (while (re-search-forward "\\([^_]+\\)_" nil t)
  916.              (replace-match "\\1 "))
  917.            (goto-char (point-max))))))
  918.  
  919.          ;; undo the dirty deed
  920.          (if (not mail-extr-mangle-uucp)
  921.          (modify-syntax-entry ?! "." (syntax-table)))
  922.          ;;
  923.          ;; If we derived the name from the mailbox part of the address,
  924.          ;; and we only got one word out of it, don't treat that as a
  925.          ;; name.  "foo@bar" --> (nil "foo@bar"), not ("foo" "foo@bar")
  926.          (if (not (search-backward " " nil t))
  927.          (delete-region (point-min) (point-max)))
  928.          ))
  929.       
  930.       (set-syntax-table address-text-syntax-table)
  931.       
  932.       (let ((xxx (variant-method (buffer-string))))
  933.     (delete-region (point-min) (point-max))
  934.     (insert xxx))
  935.       (goto-char (point-min))
  936.  
  937. ;;       ;; Compress whitespace
  938. ;;       (goto-char (point-min))
  939. ;;       (while (re-search-forward "[ \t\n]+" nil t)
  940. ;;     (replace-match " "))
  941. ;;       
  942. ;;       ;; Fix . used as space
  943. ;;       (goto-char (point-min))
  944. ;;       (while (re-search-forward mail-bad-\.-pattern nil t)
  945. ;;     (replace-match "\\1 \\2"))
  946. ;; 
  947. ;;       ;; Delete trailing parenthesized comment
  948. ;;       (goto-char (point-max))
  949. ;;       (skip-chars-backward mail-whitespace)
  950. ;;       (cond ((memq (char-after (1- (point))) '(?\) ?\} ?\]))
  951. ;;          (setq comment-end (point))
  952. ;;          (set-syntax-table address-text-comment-syntax-table)
  953. ;;          (or (safe-move-sexp -1)
  954. ;;          (backward-char 1))
  955. ;;          (set-syntax-table address-text-syntax-table)
  956. ;;          (setq comment-beg (point))
  957. ;;          (skip-chars-backward mail-whitespace)
  958. ;;          (if (bobp)
  959. ;;          (narrow-to-region (1+ comment-beg) (1- comment-end))
  960. ;;            (narrow-to-region (point-min) (point)))))
  961. ;;       
  962. ;;       ;; Find, save, and delete any name suffix
  963. ;;       ;; *** Broken!
  964. ;;       (goto-char (point-min))
  965. ;;       (cond ((re-search-forward mail-full-name-suffix-pattern nil t)
  966. ;;          (setq name-suffix (buffer-substring (match-beginning 3)
  967. ;;                          (match-end 3)))
  968. ;;          (replace-match "\\1 \\4")))
  969. ;;       
  970. ;;       ;; Delete ALL CAPS words and after, if preceded by mixed-case or
  971. ;;       ;; lowercase words.  Eg. XT-DEM.
  972. ;;       (goto-char (point-min))
  973. ;;       ;; ## This will lose on something like "SMITH MAX".
  974. ;;       ;; ## maybe it should be
  975. ;;       ;; ##  " \\([A-Z]+[-_/][A-Z]+\\|[A-Z][A-Z][A-Z]\\)\\b.*[^A-Z \t]"
  976. ;;       ;; ## that is, three-letter-upper-case-word with non-upper-case
  977. ;;       ;; ## characters following it.
  978. ;;       (if (re-search-forward mail-mixed-case-name-pattern nil t)
  979. ;;       (if (re-search-forward mail-weird-acronym-pattern nil t)
  980. ;;           (narrow-to-region (point-min) (match-beginning 0))))
  981. ;;       
  982. ;;       ;; Delete trailing alternative address
  983. ;;       (goto-char (point-min))
  984. ;;       (if (re-search-forward mail-alternative-address-pattern nil t)
  985. ;;       (narrow-to-region (point-min) (match-beginning 0)))
  986. ;;       
  987. ;;       ;; Delete trailing comment
  988. ;;       (goto-char (point-min))
  989. ;;       (if (re-search-forward mail-trailing-comment-start-pattern nil t)
  990. ;;       (or (progn
  991. ;;         (goto-char (match-beginning 0))
  992. ;;         (skip-chars-backward mail-whitespace)
  993. ;;         (bobp))
  994. ;;           (narrow-to-region (point-min) (match-beginning 0))))
  995. ;;       
  996. ;;       ;; Delete trailing comma-separated comment
  997. ;;       (goto-char (point-min))
  998. ;;       ;; ## doesn't this break "Smith, John"?  Yes.
  999. ;;       (re-search-forward mail-last-name-first-pattern nil t)
  1000. ;;       (while (search-forward "," nil t)
  1001. ;;     (or (save-excursion
  1002. ;;           (backward-char 2)
  1003. ;;           (looking-at mail-full-name-suffix-pattern))
  1004. ;;         (narrow-to-region (point-min) (1- (point)))))
  1005. ;;       
  1006. ;;       ;; Delete telephone numbers and ham radio call signs
  1007. ;;       (goto-char (point-min))
  1008. ;;       (if (re-search-forward mail-telephone-extension-pattern nil t)
  1009. ;;       (narrow-to-region (point-min) (match-beginning 0)))
  1010. ;;       (goto-char (point-min))
  1011. ;;       (if (re-search-forward mail-ham-call-sign-pattern nil t)
  1012. ;;       (if (eq (match-beginning 0) (point-min))
  1013. ;;           (narrow-to-region (match-end 0) (point-max))
  1014. ;;         (narrow-to-region (point-min) (match-beginning 0))))
  1015. ;;       
  1016. ;;       ;; Delete trailing word followed immediately by .
  1017. ;;       (goto-char (point-min))
  1018. ;;       ;; ## what's this for?  doesn't it mess up "Public, Harry Q."?  No.
  1019. ;;       (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t)
  1020. ;;       (narrow-to-region (point-min) (match-beginning 0)))
  1021. ;;       
  1022. ;;       ;; Handle & substitution
  1023. ;;       ;; TODO: remember to disable middle initial guessing
  1024. ;;       (goto-char (point-min))
  1025. ;;       (cond ((re-search-forward "\\( \\|\\`\\)&\\( \\|\\'\\)" nil t)
  1026. ;;          (goto-char (match-end 1))
  1027. ;;          (delete-char 1)
  1028. ;;          (capitalize-region
  1029. ;;           (point)
  1030. ;;           (progn
  1031. ;;         (insert-buffer-substring canonicalization-buffer
  1032. ;;                      mbox-beg mbox-end)
  1033. ;;         (point)))))
  1034. ;;       
  1035. ;;       ;; Delete nickname
  1036. ;;       (goto-char (point-min))
  1037. ;;       (if (re-search-forward mail-nickname-pattern nil t)
  1038. ;;       (replace-match (if (eq (match-beginning 2) (1- (match-end 2)))
  1039. ;;                  " \\2 "
  1040. ;;                " ")))
  1041. ;;       
  1042. ;;       ;; Fixup initials
  1043. ;;       (while (progn
  1044. ;;            (goto-char (point-min))
  1045. ;;            (re-search-forward mail-bad-initials-pattern nil t))
  1046. ;;     (replace-match
  1047. ;;      (if (match-beginning 4)
  1048. ;;          "\\1. \\4"
  1049. ;;        (if (match-beginning 5)
  1050. ;;            "\\1. \\5"
  1051. ;;          "\\1. "))))
  1052. ;;       
  1053. ;;       ;; Delete title
  1054. ;;       (goto-char (point-min))
  1055. ;;       (if (re-search-forward mail-full-name-prefixes nil t)
  1056. ;;       (narrow-to-region (point) (point-max)))
  1057. ;;       
  1058. ;;       ;; Delete trailing and preceding non-name characters
  1059. ;;       (goto-char (point-min))
  1060. ;;       (skip-chars-forward mail-non-begin-name-chars)
  1061. ;;       (narrow-to-region (point) (point-max))
  1062. ;;       (goto-char (point-max))
  1063. ;;       (skip-chars-backward mail-non-end-name-chars)
  1064. ;;       (narrow-to-region (point-min) (point))
  1065.       
  1066.       ;; If name is "First Last" and userid is "F?L", then assume
  1067.       ;; the middle initial is the second letter in the userid.
  1068.       ;; initially by Jamie Zawinski <jwz@lucid.com>
  1069.       (cond ((and mail-extr-guess-middle-initial
  1070.           (eq 3 (- mbox-end mbox-beg))
  1071.           (progn
  1072.             (goto-char (point-min))
  1073.             (looking-at mail-two-name-pattern)))
  1074.          (setq fi (char-after (match-beginning 0))
  1075.            li (char-after (match-beginning 3)))
  1076.          (save-excursion
  1077.            (set-buffer canonicalization-buffer)
  1078.            ;; char-equal is ignoring case here, so no need to upcase
  1079.            ;; or downcase.
  1080.            (let ((case-fold-search t))
  1081.          (and (char-equal fi (char-after mbox-beg))
  1082.               (char-equal li (char-after (1- mbox-end)))
  1083.               (setq mi (char-after (1+ mbox-beg))))))
  1084.          (cond ((and mi
  1085.              ;; TODO: use better table than syntax table
  1086.              (eq ?w (char-syntax mi)))
  1087.             (goto-char (match-beginning 3))
  1088.             (insert (upcase mi) ". ")))))
  1089.       
  1090. ;;       ;; Restore suffix
  1091. ;;       (cond (name-suffix
  1092. ;;          (goto-char (point-max))
  1093. ;;          (insert ", " name-suffix)
  1094. ;;          (backward-word 1)
  1095. ;;          (cond ((memq (following-char) '(?j ?J ?s ?S))
  1096. ;;             (capitalize-word 1)
  1097. ;;             (or (eq (following-char) ?.)
  1098. ;;             (insert ?.)))
  1099. ;;            (t
  1100. ;;             (upcase-word 1)))))
  1101.       
  1102.       ;; Result
  1103.       (list (and (not (= (point-min) (point-max)))
  1104.          (buffer-string))
  1105.         (progn
  1106.           (set-buffer canonicalization-buffer)
  1107.           (buffer-string)))
  1108.       )))
  1109.  
  1110. ;; TODO: put this back in the above function now that it's proven:
  1111. (defun variant-method (string)
  1112.   (let ((variant-buffer (get-buffer-create " *variant method buffer*"))
  1113.     (word-count 0)
  1114.     mixed-case-flag lower-case-flag upper-case-flag
  1115.     suffix-flag last-name-comma-flag
  1116.     comment-beg comment-end initial beg end
  1117.     )
  1118.     (save-excursion
  1119.       (set-buffer variant-buffer)
  1120.       (buffer-flush-undo variant-buffer)
  1121.       (set-syntax-table address-text-syntax-table)
  1122.       (widen)
  1123.       (erase-buffer)
  1124.       (setq case-fold-search nil)
  1125.       
  1126.       (insert string)
  1127.       
  1128.       ;; Fix . used as space
  1129.       (goto-char (point-min))
  1130.       (while (re-search-forward mail-bad-\.-pattern nil t)
  1131.     (replace-match "\\1 \\2"))
  1132.  
  1133.       ;; Skip any initial garbage.
  1134.       (goto-char (point-min))
  1135.       (skip-chars-forward mail-non-begin-name-chars)
  1136.       (skip-chars-backward "& \"")
  1137.       (narrow-to-region (point) (point-max))
  1138.       
  1139.       (catch 'stop
  1140.     (while t
  1141.       (skip-chars-forward mail-whitespace)
  1142.       
  1143.       (cond
  1144.        
  1145.        ;; Delete title
  1146.        ((and (eq word-count 0)
  1147.          (looking-at mail-full-name-prefixes))
  1148.         (goto-char (match-end 0))
  1149.         (narrow-to-region (point) (point-max)))
  1150.        
  1151.        ;; Stop after name suffix
  1152.        ((and (>= word-count 2)
  1153.          (looking-at mail-full-name-suffix-pattern))
  1154.         (skip-chars-backward mail-whitespace)
  1155.         (setq suffix-flag (point))
  1156.         (if (eq ?, (following-char))
  1157.         (forward-char 1)
  1158.           (insert ?,))
  1159.         ;; Enforce at least one space after comma
  1160.         (or (eq mail-space-char (following-char))
  1161.         (insert mail-space-char))
  1162.         (skip-chars-forward mail-whitespace)
  1163.         (cond ((memq (following-char) '(?j ?J ?s ?S))
  1164.            (capitalize-word 1)
  1165.            (if (eq (following-char) ?.)
  1166.                (forward-char 1)
  1167.              (insert ?.)))
  1168.           (t
  1169.            (upcase-word 1)))
  1170.         (setq word-count (1+ word-count))
  1171.         (throw 'stop t))
  1172.        
  1173.        ;; Handle SCA names
  1174.        ((looking-at "MKA \\(.+\\)")    ; "Mundanely Known As"
  1175.         (setq word-count 0)
  1176.         (goto-char (match-beginning 1))
  1177.         (narrow-to-region (point) (point-max)))
  1178.        
  1179.        ;; Various stopping points
  1180.        ((or
  1181.          ;; Stop before ALL CAPS acronyms, if preceded by mixed-case or
  1182.          ;; lowercase words.  Eg. XT-DEM.
  1183.          (and (>= word-count 2)
  1184.           (or mixed-case-flag lower-case-flag)
  1185.           (looking-at mail-weird-acronym-pattern)
  1186.           (not (looking-at mail-roman-numeral-pattern)))
  1187.          ;; Stop before 4-or-more letter lowercase words preceded by
  1188.          ;; mixed case or uppercase words.
  1189.          (and (>= word-count 2)
  1190.           (or upper-case-flag mixed-case-flag)
  1191.           (looking-at "[a-z][a-z][a-z][a-z]+\\b"))
  1192.          ;; Stop before trailing alternative address
  1193.          (looking-at mail-alternative-address-pattern)
  1194.          ;; Stop before trailing comment not introduced by comma
  1195.          (looking-at mail-trailing-comment-start-pattern)
  1196.          ;; Stop before telephone numbers
  1197.          (looking-at mail-telephone-extension-pattern))
  1198.         (throw 'stop t))
  1199.        
  1200.        ;; Check for initial last name followed by comma
  1201.        ((and (eq ?, (following-char))
  1202.          (eq word-count 1))
  1203.         (forward-char 1)
  1204.         (setq last-name-comma-flag t)
  1205.         (or (eq mail-space-char (following-char))
  1206.         (insert mail-space-char)))
  1207.        
  1208.        ;; Stop before trailing comma-separated comment
  1209.        ((eq ?, (following-char))
  1210.         (throw 'stop t))
  1211.        
  1212.        ;; Delete parenthesized/quoted comment/nickname
  1213.        ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
  1214.         (setq comment-beg (point))
  1215.         (set-syntax-table address-text-comment-syntax-table)
  1216.         (cond ((memq (following-char) '(?\' ?\`))
  1217.            (if (eq ?\' (following-char))
  1218.                (forward-char 1))
  1219.            (or (search-forward "'" nil t)
  1220.                (delete-char 1)))
  1221.           (t
  1222.            (or (safe-move-sexp 1)
  1223.                (goto-char (point-max)))))
  1224.         (set-syntax-table address-text-syntax-table)
  1225.         (setq comment-end (point))
  1226.         (cond
  1227.          ;; Handle case of entire name being quoted
  1228.          ((and (eq word-count 0)
  1229.            (looking-at " *\\'")
  1230.            (>= (- comment-end comment-beg) 2))
  1231.           (narrow-to-region (1+ comment-beg) (1- comment-end))
  1232.           (goto-char (point-min)))
  1233.          (t
  1234.           ;; Handle case of quoted initial
  1235.           (if (and (or (= 3 (- comment-end comment-beg))
  1236.                (and (= 4 (- comment-end comment-beg))
  1237.                 (eq ?. (char-after (+ 2 comment-beg)))))
  1238.                (not (looking-at " *\\'")))
  1239.           (setq initial (char-after (1+ comment-beg)))
  1240.         (setq initial nil))
  1241.           (delete-region comment-beg comment-end)
  1242.           (if initial
  1243.           (insert initial ". ")))))
  1244.        
  1245.        ;; Delete ham radio call signs
  1246.        ((looking-at mail-ham-call-sign-pattern)
  1247.         (delete-region (match-beginning 0) (match-end 0)))
  1248.        
  1249.        ;; Handle & substitution
  1250.        ;; TODO: remember to disable middle initial guessing
  1251.        ((and (or (bobp)
  1252.              (eq mail-space-char (preceding-char)))
  1253.          (looking-at "&\\( \\|\\'\\)"))
  1254.         (delete-char 1)
  1255.         (capitalize-region
  1256.          (point)
  1257.          (progn
  1258.            (insert-buffer-substring canonicalization-buffer
  1259.                     mbox-beg mbox-end)
  1260.            (point))))
  1261.        
  1262.        ;; Fixup initials
  1263.        ((looking-at mail-initial-pattern)
  1264.         (or (eq (following-char) (upcase (following-char)))
  1265.         (setq lower-case-flag t))
  1266.         (forward-char 1)
  1267.         (if (eq ?. (following-char))
  1268.         (forward-char 1)
  1269.           (insert ?.))
  1270.         (or (eq mail-space-char (following-char))
  1271.         (insert mail-space-char))
  1272.         (setq word-count (1+ word-count)))
  1273.        
  1274.        ;; Regular name words
  1275.        ((looking-at mail-name-pattern)
  1276.         (setq beg (point))
  1277.         (setq end (match-end 0))
  1278.         (set (if (re-search-forward "[a-z]" end t)
  1279.              (if (progn
  1280.                (goto-char beg)
  1281.                (re-search-forward "[A-Z]" end t))
  1282.              'mixed-case-flag
  1283.                'lower-case-flag)
  1284.            'upper-case-flag) t)
  1285.         (goto-char end)
  1286.         (setq word-count (1+ word-count)))
  1287.  
  1288.        (t
  1289.         (throw 'stop t)))))
  1290.       
  1291.       (narrow-to-region (point-min) (point))
  1292.  
  1293.       ;; Delete trailing word followed immediately by .
  1294.       (cond ((not suffix-flag)
  1295.          (goto-char (point-min))
  1296.          (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t)
  1297.          (narrow-to-region (point-min) (match-beginning 0)))))
  1298.       
  1299.       ;; If last name first put it at end (but before suffix)
  1300.       (cond (last-name-comma-flag
  1301.          (goto-char (point-min))
  1302.          (search-forward ",")
  1303.          (setq end (1- (point)))
  1304.          (goto-char (or suffix-flag (point-max)))
  1305.          (or (eq mail-space-char (preceding-char))
  1306.          (insert mail-space-char))
  1307.          (insert-buffer-substring (current-buffer) (point-min) end)
  1308.          (narrow-to-region (1+ end) (point-max))))
  1309.       
  1310.       (goto-char (point-max))
  1311.       (skip-chars-backward mail-non-end-name-chars)
  1312.       (if (eq ?. (following-char))
  1313.       (forward-char 1))
  1314.       (narrow-to-region (point)
  1315.             (progn
  1316.               (goto-char (point-min))
  1317.               (skip-chars-forward mail-non-begin-name-chars)
  1318.               (point)))
  1319.       
  1320.       ;; Compress whitespace
  1321.       (goto-char (point-min))
  1322.       (while (re-search-forward "[ \t\n]+" nil t)
  1323.     (replace-match " "))
  1324.  
  1325.       (buffer-substring (point-min) (point-max))
  1326.  
  1327.       )))
  1328.  
  1329. ;; The country names are just in there for show right now, and because
  1330. ;; Jamie thought it would be neat.  They aren't used yet.
  1331.  
  1332. ;; Keep in mind that the country abbreviations follow ISO-3166.  There is
  1333. ;; a U.S. FIPS that specifies a different set of two-letter country
  1334. ;; abbreviations.
  1335.  
  1336. ;; TODO: put this in its own obarray, instead of cluttering up the main
  1337. ;; symbol table with junk.
  1338.  
  1339. (mapcar
  1340.  (function
  1341.   (lambda (x)
  1342.     (if (symbolp x)
  1343.     (put x 'domain-name t)
  1344.       (put (car x) 'domain-name (nth 1 x)))))
  1345.  '((ag "Antigua")
  1346.    (ar "Argentina")            ; Argentine Republic
  1347.    arpa                    ; Advanced Projects Research Agency
  1348.    (at "Austria")            ; The Republic of _
  1349.    (au "Australia")
  1350.    (bb "Barbados")
  1351.    (be "Belgium")            ; The Kingdom of _
  1352.    (bg "Bulgaria")
  1353.    bitnet                ; Because It's Time NET
  1354.    (bo "Bolivia")            ; Republic of _
  1355.    (br "Brazil")            ; The Federative Republic of _
  1356.    (bs "Bahamas")
  1357.    (bz "Belize")
  1358.    (ca "Canada")
  1359.    (ch "Switzerland")            ; The Swiss Confederation
  1360.    (cl "Chile")                ; The Republic of _
  1361.    (cn "China")                ; The People's Republic of _
  1362.    (co "Columbia")
  1363.    com                    ; Commercial
  1364.    (cr "Costa Rica")            ; The Republic of _
  1365.    (cs "Czechoslovakia")
  1366.    (de "Germany")
  1367.    (dk "Denmark")
  1368.    (dm "Dominica")
  1369.    (do "Dominican Republic")        ; The _
  1370.    (ec "Ecuador")            ; The Republic of _
  1371.    edu                    ; Educational
  1372.    (eg "Egypt")                ; The Arab Republic of _
  1373.    (es "Spain")                ; The Kingdom of _
  1374.    (fi "Finland")            ; The Republic of _
  1375.    (fj "Fiji")
  1376.    (fr "France")
  1377.    gov                    ; Government (U.S.A.)
  1378.    (gr "Greece")            ; The Hellenic Republic
  1379.    (hk "Hong Kong")
  1380.    (hu "Hungary")            ; The Hungarian People's Republic (???)
  1381.    (ie "Ireland")
  1382.    (il "Israel")            ; The State of _
  1383.    (in "India")                ; The Republic of _
  1384.    int                    ; something British, don't know what
  1385.    (is "Iceland")            ; The Republic of _
  1386.    (it "Italy")                ; The Italian Republic
  1387.    (jm "Jamaica")
  1388.    (jp "Japan")
  1389.    (kn "St. Kitts and Nevis")
  1390.    (kr "South Korea")
  1391.    (lc "St. Lucia")
  1392.    (lk "Sri Lanka")               ; The Democratic Socialist Republic of _
  1393.    mil                    ; Military (U.S.A.)
  1394.    (mx "Mexico")            ; The United Mexican States
  1395.    (my "Malaysia")            ; changed to Myanmar????
  1396.    (na "Namibia")
  1397.    nato                    ; North Atlantic Treaty Organization
  1398.    net                    ; Network
  1399.    (ni "Nicaragua")            ; The Republic of _
  1400.    (nl "Netherlands")            ; The Kingdom of the _
  1401.    (no "Norway")            ; The Kingdom of _
  1402.    (nz "New Zealand")
  1403.    org                    ; Organization
  1404.    (pe "Peru")
  1405.    (pg "Papua New Guinea")
  1406.    (ph "Philippines")            ; The Republic of the _
  1407.    (pl "Poland")
  1408.    (pr "Puerto Rico")
  1409.    (pt "Portugal")            ; The Portugese Republic
  1410.    (py "Paraguay")
  1411.    (se "Sweden")            ; The Kingdom of _
  1412.    (sg "Singapore")            ; The Republic of _
  1413.    (sr "Suriname")
  1414.    (su "Soviet Union")
  1415.    (th "Thailand")            ; The Kingdom of _
  1416.    (tn "Tunisia")
  1417.    (tr "Turkey")            ; The Republic of _
  1418.    (tt "Trinidad and Tobago")
  1419.    (tw "Taiwan")
  1420.    (uk "United Kingdom")        ; The _ of Great Britain
  1421.    unter-dom                ; something German
  1422.    (us "U.S.A.")            ; The United States of America
  1423.    uucp                    ; Unix to Unix CoPy
  1424.    (uy "Uruguay")            ; The Eastern Republic of _
  1425.    (vc "St. Vincent and the Grenadines")
  1426.    (ve "Venezuela")            ; The Republic of _
  1427.    (yu "Yugoslavia")            ; The Socialist Federal Republic of _
  1428.    ;; Also said to be Zambia ...
  1429.    (za "South Africa")            ; The Republic of _ (why not Zaire???)
  1430.    (zw "Zimbabwe")            ; Republic of _
  1431.    ))
  1432. ;; fipnet
  1433.  
  1434.  
  1435. ;; Code for testing.
  1436.  
  1437. (defun time-extract ()
  1438.   (let (times list)
  1439.     (setq times (cons (current-time-string) times)
  1440.       list problem-address-alist)
  1441.     (while list
  1442.       (mail-extract-address-components (car (car list)))
  1443.       (setq list (cdr list)))
  1444.     (setq times (cons (current-time-string) times))
  1445.     (nreverse times)))
  1446.  
  1447. (defun test-extract (&optional starting-point)
  1448.   (interactive)
  1449.   (set-buffer (get-buffer-create "*Testing*"))
  1450.   (erase-buffer)
  1451.   (sit-for 0)
  1452.   (mapcar 'test-extract-internal
  1453.       (if starting-point
  1454.           (memq starting-point problem-address-alist)
  1455.          problem-address-alist)))
  1456.  
  1457. (defvar failed-item)
  1458. (defun test-extract-internal (item)
  1459.   (setq failed-item item)
  1460.   (let* ((address (car item))
  1461.      (correct-name (nth 1 item))
  1462.      (correct-canon (nth 2 item))
  1463.      (result (mail-extract-address-components address))
  1464.      (name (or (car result) ""))
  1465.      (canon (nth 1 result))
  1466.      (name-correct (or (null correct-name)
  1467.                (string-equal (downcase correct-name)
  1468.                      (downcase name))))
  1469.      (canon-correct (or (null correct-canon)
  1470.                 (string-equal correct-canon canon))))
  1471.     (cond ((not (and name-correct canon-correct))
  1472.        (pop-to-buffer "*Testing*")
  1473.        (select-window (get-buffer-window (current-buffer)))
  1474.        (goto-char (point-max))
  1475.        (insert "Address: " address "\n")
  1476.        (if (not name-correct)
  1477.            (insert " Correct Name:  [" correct-name
  1478.                "]\; Result: [" name "]\n"))
  1479.        (if (not canon-correct)
  1480.            (insert " Correct Canon: [" correct-canon
  1481.                "]\; Result: [" canon "]\n"))
  1482.        (insert "\n")
  1483.        (sit-for 0))))
  1484.   (setq failed-item nil))
  1485.  
  1486. (defun test-continue-extract ()
  1487.   (interactive)
  1488.   (test-extract failed-item))
  1489.  
  1490.  
  1491. ;; Assorted junk.
  1492.  
  1493. ;;    warsaw@nlm.nih.gov (A Bad Dude -- Barry Warsaw)
  1494.  
  1495. ;;'(from
  1496. ;;  reply-to
  1497. ;;  return-path
  1498. ;;  x-uucp-from
  1499. ;;  sender
  1500. ;;  resent-from
  1501. ;;  resent-sender
  1502. ;;  resent-reply-to)
  1503.