/[emacs]/emacs/lisp/mail/mail-extr.el
ViewVC logotype

Diff of /emacs/lisp/mail/mail-extr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.39 by jas, Wed Sep 25 20:21:28 2002 UTC revision 1.40 by lektu, Fri Oct 18 08:48:39 2002 UTC
# Line 29  Line 29 
29  ;; The entry point of this code is  ;; The entry point of this code is
30  ;;  ;;
31  ;;    mail-extract-address-components: (address &optional all)  ;;    mail-extract-address-components: (address &optional all)
32  ;;    ;;
33  ;;    Given an RFC-822 ADDRESS, extract full name and canonical address.  ;;    Given an RFC-822 ADDRESS, extract full name and canonical address.
34  ;;    Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).  ;;    Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
35  ;;    If no name can be extracted, FULL-NAME will be nil.  ;;    If no name can be extracted, FULL-NAME will be nil.
36  ;;    ADDRESS may be a string or a buffer.  If it is a buffer, the visible  ;;    ADDRESS may be a string or a buffer.  If it is a buffer, the visible
37  ;;     (narrowed) portion of the buffer will be interpreted as the address.  ;;     (narrowed) portion of the buffer will be interpreted as the address.
38  ;;     (This feature exists so that the clever caller might be able to avoid  ;;     (This feature exists so that the clever caller might be able to avoid
39  ;;     consing a string.)  ;;     consing a string.)
# Line 61  Line 61 
61  ;; make sure you're not breaking functionality.  The test cases aren't included  ;; make sure you're not breaking functionality.  The test cases aren't included
62  ;; because they are over 100K.  ;; because they are over 100K.
63  ;;  ;;
64  ;; If you find an address that mail-extr fails on, please send it to the  ;; If you find an address that mail-extr fails on, please send it to the
65  ;; maintainer along with what you think the correct results should be.  We do  ;; maintainer along with what you think the correct results should be.  We do
66  ;; not consider it a bug if mail-extr mangles a comment that does not  ;; not consider it a bug if mail-extr mangles a comment that does not
67  ;; correspond to a real human full name, although we would prefer that  ;; correspond to a real human full name, although we would prefer that
68  ;; mail-extr would return the comment as-is.  ;; mail-extr would return the comment as-is.
69  ;;  ;;
70  ;; Features:  ;; Features:
# Line 121  Line 121 
121  ;; * insert documentation strings!  ;; * insert documentation strings!
122  ;; * handle X.400-gatewayed addresses according to RFC 1148.  ;; * handle X.400-gatewayed addresses according to RFC 1148.
123    
124  ;;; Change Log:  ;;; Change Log:
125  ;;  ;;
126  ;; Thu Feb 17 17:57:33 1994  Jamie Zawinski (jwz@lucid.com)  ;; Thu Feb 17 17:57:33 1994  Jamie Zawinski (jwz@lucid.com)
127  ;;  ;;
128  ;;      * merged with jbw's latest version  ;;      * merged with jbw's latest version
# Line 140  Line 140 
140  ;;      * some more cleanup, doc, added provide  ;;      * some more cleanup, doc, added provide
141  ;;  ;;
142  ;; Tue Mar 23 21:23:18 1993  Joe Wells  (jbw at csd.bu.edu)  ;; Tue Mar 23 21:23:18 1993  Joe Wells  (jbw at csd.bu.edu)
143  ;;  ;;
144  ;;      * Made mail-full-name-prefixes a user-customizable variable.  ;;      * Made mail-full-name-prefixes a user-customizable variable.
145  ;;        Allow passing the address as a buffer as well as a string.  ;;        Allow passing the address as a buffer as well as a string.
146  ;;        Allow [ and ] as name characters (Finnish character set).  ;;        Allow [ and ] as name characters (Finnish character set).
147  ;;  ;;
148  ;; Mon Mar 22 21:20:56 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Mon Mar 22 21:20:56 1993  Joe Wells  (jbw at bigbird.bu.edu)
149  ;;  ;;
150  ;;      * Handle "null" addresses.  Handle = used for spacing in mailbox  ;;      * Handle "null" addresses.  Handle = used for spacing in mailbox
151  ;;        name.  Fix bug in handling of ROUTE-ADDR-type addresses that are  ;;        name.  Fix bug in handling of ROUTE-ADDR-type addresses that are
152  ;;        missing their brackets.  Handle uppercase "JR".  Extract full  ;;        missing their brackets.  Handle uppercase "JR".  Extract full
153  ;;        names from X.400 addresses encoded in RFC-822.  Fix bug in  ;;        names from X.400 addresses encoded in RFC-822.  Fix bug in
154  ;;        handling of multiple addresses where first has trailing comment.  ;;        handling of multiple addresses where first has trailing comment.
155  ;;        Handle more kinds of telephone extension lead-ins.  ;;        Handle more kinds of telephone extension lead-ins.
156  ;;  ;;
157  ;; Mon Mar 22 20:16:57 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Mon Mar 22 20:16:57 1993  Joe Wells  (jbw at bigbird.bu.edu)
158  ;;  ;;
159  ;;      * Handle HZ encoding for embedding GB encoded chinese characters.  ;;      * Handle HZ encoding for embedding GB encoded chinese characters.
160  ;;  ;;
161  ;; Mon Mar 22 00:46:12 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Mon Mar 22 00:46:12 1993  Joe Wells  (jbw at bigbird.bu.edu)
162  ;;  ;;
163  ;;      * Fixed too broad matching of ham radio call signs.  Fixed bug in  ;;      * Fixed too broad matching of ham radio call signs.  Fixed bug in
164  ;;        handling an unmatched ' in a name string.  Enhanced recognition  ;;        handling an unmatched ' in a name string.  Enhanced recognition
165  ;;        of when . in the mailbox name terminates the name portion.  ;;        of when . in the mailbox name terminates the name portion.
# Line 169  Line 169 
169  ;;        introduced in switching last name order.  Fixed bug in handling  ;;        introduced in switching last name order.  Fixed bug in handling
170  ;;        address with ! and % but no @.  Narrowed the cases in which  ;;        address with ! and % but no @.  Narrowed the cases in which
171  ;;        certain trailing words are discarded.  ;;        certain trailing words are discarded.
172  ;;  ;;
173  ;; Sun Mar 21 21:41:06 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Sun Mar 21 21:41:06 1993  Joe Wells  (jbw at bigbird.bu.edu)
174  ;;  ;;
175  ;;      * Fixed bugs in handling GROUP addresses.  Certain words in the  ;;      * Fixed bugs in handling GROUP addresses.  Certain words in the
176  ;;        middle of a name no longer terminate it.  Handle LISTSERV list  ;;        middle of a name no longer terminate it.  Handle LISTSERV list
177  ;;        names.  Ignore comment field containing mailbox name.  ;;        names.  Ignore comment field containing mailbox name.
178  ;;  ;;
179  ;; Sun Mar 21 14:39:38 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Sun Mar 21 14:39:38 1993  Joe Wells  (jbw at bigbird.bu.edu)
180  ;;  ;;
181  ;;      * Moved variant-method code back into main function.  Handle  ;;      * Moved variant-method code back into main function.  Handle
182  ;;      underscores as spaces in comments.  Handle leading nickname.  Add  ;;      underscores as spaces in comments.  Handle leading nickname.  Add
183  ;;      flag to ignore single-word names.  Other changes.  ;;      flag to ignore single-word names.  Other changes.
184  ;;  ;;
185  ;; Mon Feb  1 22:23:31 1993  Joe Wells  (jbw at bigbird.bu.edu)  ;; Mon Feb  1 22:23:31 1993  Joe Wells  (jbw at bigbird.bu.edu)
186  ;;  ;;
187  ;;      * Added in changes by Rod Whitby and Jamie Zawinski.  This  ;;      * Added in changes by Rod Whitby and Jamie Zawinski.  This
188  ;;        includes the flag mail-extr-guess-middle-initial and the fix for  ;;        includes the flag mail-extr-guess-middle-initial and the fix for
189  ;;        handling multiple addresses correctly.  (Whitby just changed  ;;        handling multiple addresses correctly.  (Whitby just changed
190  ;;        a > to a <.)  ;;        a > to a <.)
191  ;;  ;;
192  ;; Mon Apr  6 23:59:09 1992  Joe Wells  (jbw at bigbird.bu.edu)  ;; Mon Apr  6 23:59:09 1992  Joe Wells  (jbw at bigbird.bu.edu)
193  ;;  ;;
194  ;;      * Cleaned up some more.  Release version 1.0 to world.  ;;      * Cleaned up some more.  Release version 1.0 to world.
195  ;;  ;;
196  ;; Sun Apr  5 19:39:08 1992  Joe Wells  (jbw at bigbird.bu.edu)  ;; Sun Apr  5 19:39:08 1992  Joe Wells  (jbw at bigbird.bu.edu)
197  ;;  ;;
198  ;;      * Cleaned up full name extraction extensively.  ;;      * Cleaned up full name extraction extensively.
199  ;;  ;;
200  ;; Sun Feb  2 14:45:24 1992  Joe Wells  (jbw at bigbird.bu.edu)  ;; Sun Feb  2 14:45:24 1992  Joe Wells  (jbw at bigbird.bu.edu)
201  ;;  ;;
202  ;;      * Total rewrite.  Integrated mail-canonicalize-address into  ;;      * Total rewrite.  Integrated mail-canonicalize-address into
203  ;;      mail-extract-address-components.  Now handles GROUP addresses more  ;;      mail-extract-address-components.  Now handles GROUP addresses more
204  ;;      or less correctly.  Better handling of lots of different cases.  ;;      or less correctly.  Better handling of lots of different cases.
205  ;;  ;;
206  ;; Fri Jun 14 19:39:50 1991  ;; Fri Jun 14 19:39:50 1991
207  ;;      * Created.  ;;      * Created.
208    
# Line 318  by translating things like \"foo!bar!baz Line 318  by translating things like \"foo!bar!baz
318    
319  (defconst mail-extr-leading-garbage "\\W+")  (defconst mail-extr-leading-garbage "\\W+")
320    
321  ;; (defconst mail-extr-non-name-chars  ;; (defconst mail-extr-non-name-chars
322  ;;   (purecopy (concat "^" mail-extr-all-letters ".")))  ;;   (purecopy (concat "^" mail-extr-all-letters ".")))
323  ;; (defconst mail-extr-non-begin-name-chars  ;; (defconst mail-extr-non-begin-name-chars
324  ;;   (purecopy (concat "^" mail-extr-first-letters)))  ;;   (purecopy (concat "^" mail-extr-first-letters)))
325  ;; (defconst mail-extr-non-end-name-chars  ;; (defconst mail-extr-non-end-name-chars
326  ;;   (purecopy (concat "^" mail-extr-last-letters)))  ;;   (purecopy (concat "^" mail-extr-last-letters)))
327    
328  ;; Matches an initial not followed by both a period and a space.  ;; Matches an initial not followed by both a period and a space.
329  ;; (defconst mail-extr-bad-initials-pattern  ;; (defconst mail-extr-bad-initials-pattern
330  ;;   (purecopy  ;;   (purecopy
331  ;;    (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"  ;;    (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
332  ;;            mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))  ;;            mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))
333    
# Line 363  by translating things like \"foo!bar!baz Line 363  by translating things like \"foo!bar!baz
363  ;; Must not match a trailing uppercase last name or trailing initial  ;; Must not match a trailing uppercase last name or trailing initial
364  (defconst mail-extr-weird-acronym-pattern  (defconst mail-extr-weird-acronym-pattern
365    (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))    (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))
366          
367  ;; Matches a mixed-case or lowercase name (not an initial).  ;; Matches a mixed-case or lowercase name (not an initial).
368  ;; #### Match Latin1 lower case letters here too?  ;; #### Match Latin1 lower case letters here too?
369  ;; (defconst mail-extr-mixed-case-name-pattern  ;; (defconst mail-extr-mixed-case-name-pattern
# Line 376  by translating things like \"foo!bar!baz Line 376  by translating things like \"foo!bar!baz
376    
377  ;; Matches a trailing alternative address.  ;; Matches a trailing alternative address.
378  ;; #### Match Latin1 letters here too?  ;; #### Match Latin1 letters here too?
379  ;; #### Match _ before @ here too?    ;; #### Match _ before @ here too?
380  (defconst mail-extr-alternative-address-pattern  (defconst mail-extr-alternative-address-pattern
381    (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))    (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))
382    
# Line 435  by translating things like \"foo!bar!baz Line 435  by translating things like \"foo!bar!baz
435  ;; Matches a single word name.  ;; Matches a single word name.
436  ;; (defconst mail-extr-one-name-pattern  ;; (defconst mail-extr-one-name-pattern
437  ;;   (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))  ;;   (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))
438      
439  ;; Matches normal two names with missing middle initial  ;; Matches normal two names with missing middle initial
440  ;; The first name is not allowed to have a hyphen because this can cause  ;; The first name is not allowed to have a hyphen because this can cause
441  ;; false matches where the "middle initial" is actually the first letter  ;; false matches where the "middle initial" is actually the first letter
# Line 459  by translating things like \"foo!bar!baz Line 459  by translating things like \"foo!bar!baz
459  ;; encountered. The character '~' is an escape character. By convention, it  ;; encountered. The character '~' is an escape character. By convention, it
460  ;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the  ;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the
461  ;; following special meaning.  ;; following special meaning.
462  ;;  ;;
463  ;; o The escape sequence '~~' is interpreted as a '~'.  ;; o The escape sequence '~~' is interpreted as a '~'.
464  ;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB.  ;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB.
465  ;; o The escape sequence '~\n' is a line-continuation marker to be consumed  ;; o The escape sequence '~\n' is a line-continuation marker to be consumed
466  ;;   with no output produced.  ;;   with no output produced.
467  ;;  ;;
468  ;; In GB mode, characters are interpreted two bytes at a time as (pure) GB  ;; In GB mode, characters are interpreted two bytes at a time as (pure) GB
469  ;; codes until the escape-from-GB code '~}' is read. This code switches the  ;; codes until the escape-from-GB code '~}' is read. This code switches the
470  ;; mode from GB back to ASCII.  (Note that the escape-from-GB code '~}'  ;; mode from GB back to ASCII.  (Note that the escape-from-GB code '~}'
# Line 734  consing a string.)" Line 734  consing a string.)"
734        (widen)        (widen)
735        (erase-buffer)        (erase-buffer)
736        (setq case-fold-search nil)        (setq case-fold-search nil)
737          
738        ;; Insert extra space at beginning to allow later replacement with <        ;; Insert extra space at beginning to allow later replacement with <
739        ;; without having to move markers.        ;; without having to move markers.
740        (insert ?\ )        (insert ?\ )
# Line 754  consing a string.)" Line 754  consing a string.)"
754          (buffer-disable-undo canonicalization-buffer)          (buffer-disable-undo canonicalization-buffer)
755          (setq case-fold-search nil))          (setq case-fold-search nil))
756    
757          
758        ;; Unfold multiple lines.        ;; Unfold multiple lines.
759        (goto-char (point-min))        (goto-char (point-min))
760        (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)        (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
761          (replace-match "\\1 " t))          (replace-match "\\1 " t))
762          
763        ;; Loop over addresses until we have as many as we want.        ;; Loop over addresses until we have as many as we want.
764        (while (and (or all (null value-list))        (while (and (or all (null value-list))
765                    (progn (goto-char (point-min))                    (progn (goto-char (point-min))
# Line 1012  consing a string.)" Line 1012  consing a string.)"
1012    
1013            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
1014            ;; others.            ;; others.
1015            ;; Hell, go ahead an nuke all of the commas.            ;; Hell, go ahead and nuke all of the commas.
1016            ;; **** This will cause problems when we start handling commas in            ;; **** This will cause problems when we start handling commas in
1017            ;; the PHRASE part .... no it won't ... yes it will ... ?????            ;; the PHRASE part .... no it won't ... yes it will ... ?????
1018            (mail-extr-nuke-outside-range comma-pos 1 1)            (mail-extr-nuke-outside-range comma-pos 1 1)
# Line 1495  consing a string.)" Line 1495  consing a string.)"
1495                (if (bobp)                (if (bobp)
1496                    (delete-region (point) cbeg)                    (delete-region (point) cbeg)
1497                  (just-one-space))))))                  (just-one-space))))))
1498          
1499        ;; This was moved above.        ;; This was moved above.
1500        ;; Fix . used as space        ;; Fix . used as space
1501        ;; But it belongs here because it occurs not only as        ;; But it belongs here because it occurs not only as
# Line 1524  consing a string.)" Line 1524  consing a string.)"
1524        ;; Loop over the words (and other junk) in the name.        ;; Loop over the words (and other junk) in the name.
1525        (goto-char (point-min))        (goto-char (point-min))
1526        (while (not name-done-flag)        (while (not name-done-flag)
1527            
1528          (when word-found-flag          (when word-found-flag
1529            ;; Last time through this loop we skipped over a word.            ;; Last time through this loop we skipped over a word.
1530            (setq last-word-beg this-word-beg)            (setq last-word-beg this-word-beg)
# Line 1543  consing a string.)" Line 1543  consing a string.)"
1543            (setq lower-case-flag nil)            (setq lower-case-flag nil)
1544            ;;           (setq upper-case-flag nil)            ;;           (setq upper-case-flag nil)
1545            (setq begin-again-flag nil))            (setq begin-again-flag nil))
1546            
1547          ;; Initialize for this iteration of the loop.          ;; Initialize for this iteration of the loop.
1548          (mail-extr-skip-whitespace-forward)          (mail-extr-skip-whitespace-forward)
1549          (if (eq word-count 0) (narrow-to-region (point) (point-max)))          (if (eq word-count 0) (narrow-to-region (point) (point-max)))
1550          (setq this-word-beg (point))          (setq this-word-beg (point))
1551          (setq drop-this-word-if-trailing-flag nil)          (setq drop-this-word-if-trailing-flag nil)
1552            
1553          ;; Decide what to do based on what we are looking at.          ;; Decide what to do based on what we are looking at.
1554          (cond          (cond
1555            
1556           ;; Delete title           ;; Delete title
1557           ((and (eq word-count 0)           ((and (eq word-count 0)
1558                 (looking-at mail-extr-full-name-prefixes))                 (looking-at mail-extr-full-name-prefixes))
1559            (goto-char (match-end 0))            (goto-char (match-end 0))
1560            (narrow-to-region (point) (point-max)))            (narrow-to-region (point) (point-max)))
1561            
1562           ;; Stop after name suffix           ;; Stop after name suffix
1563           ((and (>= word-count 2)           ((and (>= word-count 2)
1564                 (looking-at mail-extr-full-name-suffix-pattern))                 (looking-at mail-extr-full-name-suffix-pattern))
# Line 1580  consing a string.)" Line 1580  consing a string.)"
1580                   (upcase-word 1)))                   (upcase-word 1)))
1581            (setq word-found-flag t)            (setq word-found-flag t)
1582            (setq name-done-flag t))            (setq name-done-flag t))
1583            
1584           ;; Handle SCA names           ;; Handle SCA names
1585           ((looking-at "MKA \\(.+\\)")   ; "Mundanely Known As"           ((looking-at "MKA \\(.+\\)")   ; "Mundanely Known As"
1586            (goto-char (match-beginning 1))            (goto-char (match-beginning 1))
1587            (narrow-to-region (point) (point-max))            (narrow-to-region (point) (point-max))
1588            (setq begin-again-flag t))            (setq begin-again-flag t))
1589            
1590           ;; Check for initial last name followed by comma           ;; Check for initial last name followed by comma
1591           ((and (eq ?, (following-char))           ((and (eq ?, (following-char))
1592                 (eq word-count 1))                 (eq word-count 1))
# Line 1594  consing a string.)" Line 1594  consing a string.)"
1594            (setq last-name-comma-flag t)            (setq last-name-comma-flag t)
1595            (or (eq ?\  (following-char))            (or (eq ?\  (following-char))
1596                (insert ?\ )))                (insert ?\ )))
1597            
1598           ;; Stop before trailing comma-separated comment           ;; Stop before trailing comma-separated comment
1599           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
1600           ;; *** This case is redundant???           ;; *** This case is redundant???
1601           ;;((eq ?, (following-char))           ;;((eq ?, (following-char))
1602           ;; (setq name-done-flag t))           ;; (setq name-done-flag t))
1603            
1604           ;; Delete parenthesized/quoted comment/nickname           ;; Delete parenthesized/quoted comment/nickname
1605           ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))           ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
1606            (setq cbeg (point))            (setq cbeg (point))
# Line 1632  consing a string.)" Line 1632  consing a string.)"
1632              (delete-region cbeg cend)              (delete-region cbeg cend)
1633              (if initial              (if initial
1634                  (insert initial ". ")))))                  (insert initial ". ")))))
1635            
1636           ;; Handle *Stupid* VMS date stamps           ;; Handle *Stupid* VMS date stamps
1637           ((looking-at mail-extr-stupid-vms-date-stamp-pattern)           ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
1638            (replace-match "" t))            (replace-match "" t))
1639            
1640           ;; Handle Chinese characters.           ;; Handle Chinese characters.
1641           ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)           ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
1642            (goto-char (match-end 0))            (goto-char (match-end 0))
1643            (setq word-found-flag t))            (setq word-found-flag t))
1644            
1645           ;; Skip initial garbage characters.           ;; Skip initial garbage characters.
1646           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
1647           ((and (eq word-count 0)           ((and (eq word-count 0)
# Line 1650  consing a string.)" Line 1650  consing a string.)"
1650            ;; *** Skip backward over these???            ;; *** Skip backward over these???
1651            ;; (skip-chars-backward "& \"")            ;; (skip-chars-backward "& \"")
1652            (narrow-to-region (point) (point-max)))            (narrow-to-region (point) (point-max)))
1653            
1654           ;; Various stopping points           ;; Various stopping points
1655           ((or           ((or
1656              
1657             ;; Stop before ALL CAPS acronyms, if preceded by mixed-case             ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
1658             ;; words.  Example: XT-DEM.             ;; words.  Example: XT-DEM.
1659             (and (>= word-count 2)             (and (>= word-count 2)
1660                  mixed-case-flag                  mixed-case-flag
1661                  (looking-at mail-extr-weird-acronym-pattern)                  (looking-at mail-extr-weird-acronym-pattern)
1662                  (not (looking-at mail-extr-roman-numeral-pattern)))                  (not (looking-at mail-extr-roman-numeral-pattern)))
1663              
1664             ;; Stop before trailing alternative address             ;; Stop before trailing alternative address
1665             (looking-at mail-extr-alternative-address-pattern)             (looking-at mail-extr-alternative-address-pattern)
1666              
1667             ;; Stop before trailing comment not introduced by comma             ;; Stop before trailing comment not introduced by comma
1668             ;; THIS CASE MUST BE AFTER AN EARLIER CASE.             ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
1669             (looking-at mail-extr-trailing-comment-start-pattern)             (looking-at mail-extr-trailing-comment-start-pattern)
1670              
1671             ;; Stop before telephone numbers             ;; Stop before telephone numbers
1672             (and (>= word-count 1)             (and (>= word-count 1)
1673                  (looking-at mail-extr-telephone-extension-pattern)))                  (looking-at mail-extr-telephone-extension-pattern)))
1674            (setq name-done-flag t))            (setq name-done-flag t))
1675            
1676           ;; Delete ham radio call signs           ;; Delete ham radio call signs
1677           ((looking-at mail-extr-ham-call-sign-pattern)           ((looking-at mail-extr-ham-call-sign-pattern)
1678            (delete-region (match-beginning 0) (match-end 0)))            (delete-region (match-beginning 0) (match-end 0)))
1679            
1680           ;; Fixup initials           ;; Fixup initials
1681           ((looking-at mail-extr-initial-pattern)           ((looking-at mail-extr-initial-pattern)
1682            (or (eq (following-char) (upcase (following-char)))            (or (eq (following-char) (upcase (following-char)))
# Line 1688  consing a string.)" Line 1688  consing a string.)"
1688            (or (eq ?\  (following-char))            (or (eq ?\  (following-char))
1689                (insert ?\ ))                (insert ?\ ))
1690            (setq word-found-flag t))            (setq word-found-flag t))
1691            
1692           ;; Handle BITNET LISTSERV list names.           ;; Handle BITNET LISTSERV list names.
1693           ((and (eq word-count 0)           ((and (eq word-count 0)
1694                 (looking-at mail-extr-listserv-list-name-pattern))                 (looking-at mail-extr-listserv-list-name-pattern))
1695            (narrow-to-region (match-beginning 1) (match-end 1))            (narrow-to-region (match-beginning 1) (match-end 1))
1696            (setq word-found-flag t)            (setq word-found-flag t)
1697            (setq name-done-flag t))            (setq name-done-flag t))
1698            
1699           ;; Handle & substitution, when & is last and is not first.           ;; Handle & substitution, when & is last and is not first.
1700           ((and (> word-count 0)           ((and (> word-count 0)
1701                 (eq ?\  (preceding-char))                 (eq ?\  (preceding-char))
# Line 1722  consing a string.)" Line 1722  consing a string.)"
1722           ((looking-at mail-extr-name-pattern)           ((looking-at mail-extr-name-pattern)
1723            (setq name-beg (point))            (setq name-beg (point))
1724            (setq name-end (match-end 0))            (setq name-end (match-end 0))
1725              
1726            ;; Certain words will be dropped if they are at the end.            ;; Certain words will be dropped if they are at the end.
1727            (and (>= word-count 2)            (and (>= word-count 2)
1728                 (not lower-case-flag)                 (not lower-case-flag)
# Line 1733  consing a string.)" Line 1733  consing a string.)"
1733                  ;; Drop a trailing word which is terminated with a period.                  ;; Drop a trailing word which is terminated with a period.
1734                  (eq ?. (char-after (1- name-end))))                  (eq ?. (char-after (1- name-end))))
1735                 (setq drop-this-word-if-trailing-flag t))                 (setq drop-this-word-if-trailing-flag t))
1736              
1737            ;; Set the flags that indicate whether we have seen a lowercase            ;; Set the flags that indicate whether we have seen a lowercase
1738            ;; word, a mixed case word, and an uppercase word.            ;; word, a mixed case word, and an uppercase word.
1739            (if (re-search-forward "[a-z]" name-end t)            (if (re-search-forward "[a-z]" name-end t)
# Line 1744  consing a string.)" Line 1744  consing a string.)"
1744                  (setq lower-case-flag t))                  (setq lower-case-flag t))
1745  ;;          (setq upper-case-flag t)  ;;          (setq upper-case-flag t)
1746              )              )
1747              
1748            (goto-char name-end)            (goto-char name-end)
1749            (setq word-found-flag t))            (setq word-found-flag t))
1750    
# Line 1758  consing a string.)" Line 1758  consing a string.)"
1758           (t           (t
1759            (setq name-done-flag t)            (setq name-done-flag t)
1760            ))            ))
1761            
1762          ;; Count any word that we skipped over.          ;; Count any word that we skipped over.
1763          (if word-found-flag          (if word-found-flag
1764              (setq word-count (1+ word-count))))              (setq word-count (1+ word-count))))
1765          
1766        ;; If the last thing in the name is 2 or more periods, or one or more        ;; If the last thing in the name is 2 or more periods, or one or more
1767        ;; other sentence terminators (but not a single period) then keep them        ;; other sentence terminators (but not a single period) then keep them
1768        ;; and the preceding word.  This is for the benefit of whole sentences        ;; and the preceding word.  This is for the benefit of whole sentences
# Line 1777  consing a string.)" Line 1777  consing a string.)"
1777                          (or (and drop-last-word-if-trailing-flag                          (or (and drop-last-word-if-trailing-flag
1778                                   last-word-beg)                                   last-word-beg)
1779                              (point)))                              (point)))
1780          
1781        ;; Xerox's mailers SUCK!!!!!!        ;; Xerox's mailers SUCK!!!!!!
1782        ;; We simply refuse to believe that any last name is PARC or ADOC.        ;; We simply refuse to believe that any last name is PARC or ADOC.
1783        ;; If it looks like that is the last name, that there is no meaningful        ;; If it looks like that is the last name, that there is no meaningful
# Line 1802  consing a string.)" Line 1802  consing a string.)"
1802          (goto-char name-end)          (goto-char name-end)
1803          (skip-chars-forward "\t ,")          (skip-chars-forward "\t ,")
1804          (narrow-to-region (point) (point-max)))          (narrow-to-region (point) (point-max)))
1805          
1806        ;; Delete leading and trailing junk characters.        ;; Delete leading and trailing junk characters.
1807        ;; *** This is probably completely unneeded now.        ;; *** This is probably completely unneeded now.
1808        ;;(goto-char (point-max))        ;;(goto-char (point-max))
# Line 1814  consing a string.)" Line 1814  consing a string.)"
1814        ;;                    (goto-char (point-min))        ;;                    (goto-char (point-min))
1815        ;;                    (skip-chars-forward mail-extr-non-begin-name-chars)        ;;                    (skip-chars-forward mail-extr-non-begin-name-chars)
1816        ;;                    (point)))        ;;                    (point)))
1817          
1818        ;; Compress whitespace        ;; Compress whitespace
1819        (goto-char (point-min))        (goto-char (point-min))
1820        (while (re-search-forward "[ \t\n]+" nil t)        (while (re-search-forward "[ \t\n]+" nil t)
# Line 2132  consing a string.)" Line 2132  consing a string.)"
2132    
2133  ;(let ((all nil))  ;(let ((all nil))
2134  ;  (mapatoms #'(lambda (x)  ;  (mapatoms #'(lambda (x)
2135  ;               (if (and (boundp x)  ;               (if (and (boundp x)
2136  ;                        (string-match "^mail-extr-" (symbol-name x)))  ;                        (string-match "^mail-extr-" (symbol-name x)))
2137  ;                   (setq all (cons x all)))))  ;                   (setq all (cons x all)))))
2138  ;  (setq all (sort all #'string-lessp))  ;  (setq all (sort all #'string-lessp))

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.40

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26