/[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.34 by pj, Sun Jul 15 16:15:34 2001 UTC revision 1.34.4.1 by lektu, Mon Oct 21 09:14:09 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 as a string.  ;;        Allow passing the address as a buffer as well as 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 319  by translating things like \"foo!bar!baz Line 319  by translating things like \"foo!bar!baz
319  (defconst mail-extr-leading-garbage  (defconst mail-extr-leading-garbage
320    (purecopy (format "[^%s]+" mail-extr-first-letters)))    (purecopy (format "[^%s]+" mail-extr-first-letters)))
321    
322  ;; (defconst mail-extr-non-name-chars  ;; (defconst mail-extr-non-name-chars
323  ;;   (purecopy (concat "^" mail-extr-all-letters ".")))  ;;   (purecopy (concat "^" mail-extr-all-letters ".")))
324  ;; (defconst mail-extr-non-begin-name-chars  ;; (defconst mail-extr-non-begin-name-chars
325  ;;   (purecopy (concat "^" mail-extr-first-letters)))  ;;   (purecopy (concat "^" mail-extr-first-letters)))
326  ;; (defconst mail-extr-non-end-name-chars  ;; (defconst mail-extr-non-end-name-chars
327  ;;   (purecopy (concat "^" mail-extr-last-letters)))  ;;   (purecopy (concat "^" mail-extr-last-letters)))
328    
329  ;; Matches an initial not followed by both a period and a space.  ;; Matches an initial not followed by both a period and a space.
330  ;; (defconst mail-extr-bad-initials-pattern  ;; (defconst mail-extr-bad-initials-pattern
331  ;;   (purecopy  ;;   (purecopy
332  ;;    (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"  ;;    (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
333  ;;            mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))  ;;            mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))
334    
# Line 364  by translating things like \"foo!bar!baz Line 364  by translating things like \"foo!bar!baz
364  ;; Must not match a trailing uppercase last name or trailing initial  ;; Must not match a trailing uppercase last name or trailing initial
365  (defconst mail-extr-weird-acronym-pattern  (defconst mail-extr-weird-acronym-pattern
366    (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))    (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))
367          
368  ;; Matches a mixed-case or lowercase name (not an initial).  ;; Matches a mixed-case or lowercase name (not an initial).
369  ;; #### Match Latin1 lower case letters here too?  ;; #### Match Latin1 lower case letters here too?
370  ;; (defconst mail-extr-mixed-case-name-pattern  ;; (defconst mail-extr-mixed-case-name-pattern
# Line 377  by translating things like \"foo!bar!baz Line 377  by translating things like \"foo!bar!baz
377    
378  ;; Matches a trailing alternative address.  ;; Matches a trailing alternative address.
379  ;; #### Match Latin1 letters here too?  ;; #### Match Latin1 letters here too?
380  ;; #### Match _ before @ here too?    ;; #### Match _ before @ here too?
381  (defconst mail-extr-alternative-address-pattern  (defconst mail-extr-alternative-address-pattern
382    (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))    (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))
383    
# Line 436  by translating things like \"foo!bar!baz Line 436  by translating things like \"foo!bar!baz
436  ;; Matches a single word name.  ;; Matches a single word name.
437  ;; (defconst mail-extr-one-name-pattern  ;; (defconst mail-extr-one-name-pattern
438  ;;   (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))  ;;   (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))
439      
440  ;; Matches normal two names with missing middle initial  ;; Matches normal two names with missing middle initial
441  ;; 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
442  ;; false matches where the "middle initial" is actually the first letter  ;; false matches where the "middle initial" is actually the first letter
# Line 460  by translating things like \"foo!bar!baz Line 460  by translating things like \"foo!bar!baz
460  ;; encountered. The character '~' is an escape character. By convention, it  ;; encountered. The character '~' is an escape character. By convention, it
461  ;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the  ;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the
462  ;; following special meaning.  ;; following special meaning.
463  ;;  ;;
464  ;; o The escape sequence '~~' is interpreted as a '~'.  ;; o The escape sequence '~~' is interpreted as a '~'.
465  ;; 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.
466  ;; 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
467  ;;   with no output produced.  ;;   with no output produced.
468  ;;  ;;
469  ;; 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
470  ;; 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
471  ;; 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 742  ADDRESS may be a string or a buffer.  If Line 742  ADDRESS may be a string or a buffer.  If
742        (widen)        (widen)
743        (erase-buffer)        (erase-buffer)
744        (setq case-fold-search nil)        (setq case-fold-search nil)
745          
746        ;; Insert extra space at beginning to allow later replacement with <        ;; Insert extra space at beginning to allow later replacement with <
747        ;; without having to move markers.        ;; without having to move markers.
748        (insert ?\ )        (insert ?\ )
# Line 762  ADDRESS may be a string or a buffer.  If Line 762  ADDRESS may be a string or a buffer.  If
762          (buffer-disable-undo canonicalization-buffer)          (buffer-disable-undo canonicalization-buffer)
763          (setq case-fold-search nil))          (setq case-fold-search nil))
764    
765          
766        ;; Unfold multiple lines.        ;; Unfold multiple lines.
767        (goto-char (point-min))        (goto-char (point-min))
768        (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)        (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
769          (replace-match "\\1 " t))          (replace-match "\\1 " t))
770          
771        ;; Loop over addresses until we have as many as we want.        ;; Loop over addresses until we have as many as we want.
772        (while (and (or all (null value-list))        (while (and (or all (null value-list))
773                    (progn (goto-char (point-min))                    (progn (goto-char (point-min))
# Line 1023  ADDRESS may be a string or a buffer.  If Line 1023  ADDRESS may be a string or a buffer.  If
1023    
1024            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
1025            ;; others.            ;; others.
1026            ;; Hell, go ahead an nuke all of the commas.            ;; Hell, go ahead and nuke all of the commas.
1027            ;; **** This will cause problems when we start handling commas in            ;; **** This will cause problems when we start handling commas in
1028            ;; the PHRASE part .... no it won't ... yes it will ... ?????            ;; the PHRASE part .... no it won't ... yes it will ... ?????
1029            (mail-extr-nuke-outside-range comma-pos 1 1)            (mail-extr-nuke-outside-range comma-pos 1 1)
# Line 1156  ADDRESS may be a string or a buffer.  If Line 1156  ADDRESS may be a string or a buffer.  If
1156                                    (setq %-pos (cons (point) %-pos))                                    (setq %-pos (cons (point) %-pos))
1157                                    (insert-before-markers "% ")))                                    (insert-before-markers "% ")))
1158                             (backward-char 1)                             (backward-char 1)
1159                             (insert-buffer-substring                             (insert-buffer-substring
1160                              (current-buffer)                              (current-buffer)
1161                              (if (nth 1 !-pos)                              (if (nth 1 !-pos)
1162                                  (1+ (nth 1 !-pos))                                  (1+ (nth 1 !-pos))
# Line 1512  ADDRESS may be a string or a buffer.  If Line 1512  ADDRESS may be a string or a buffer.  If
1512                (if (bobp)                (if (bobp)
1513                    (delete-region (point) cbeg)                    (delete-region (point) cbeg)
1514                  (just-one-space))))))                  (just-one-space))))))
1515          
1516        ;; This was moved above.        ;; This was moved above.
1517        ;; Fix . used as space        ;; Fix . used as space
1518        ;; But it belongs here because it occurs not only as        ;; But it belongs here because it occurs not only as
# Line 1541  ADDRESS may be a string or a buffer.  If Line 1541  ADDRESS may be a string or a buffer.  If
1541        ;; Loop over the words (and other junk) in the name.        ;; Loop over the words (and other junk) in the name.
1542        (goto-char (point-min))        (goto-char (point-min))
1543        (while (not name-done-flag)        (while (not name-done-flag)
1544            
1545          (cond (word-found-flag          (cond (word-found-flag
1546                 ;; Last time through this loop we skipped over a word.                 ;; Last time through this loop we skipped over a word.
1547                 (setq last-word-beg this-word-beg)                 (setq last-word-beg this-word-beg)
# Line 1561  ADDRESS may be a string or a buffer.  If Line 1561  ADDRESS may be a string or a buffer.  If
1561  ;;             (setq upper-case-flag nil)  ;;             (setq upper-case-flag nil)
1562                 (setq begin-again-flag nil)                 (setq begin-again-flag nil)
1563                 ))                 ))
1564            
1565          ;; Initialize for this iteration of the loop.          ;; Initialize for this iteration of the loop.
1566          (mail-extr-skip-whitespace-forward)          (mail-extr-skip-whitespace-forward)
1567          (if (eq word-count 0) (narrow-to-region (point) (point-max)))          (if (eq word-count 0) (narrow-to-region (point) (point-max)))
1568          (setq this-word-beg (point))          (setq this-word-beg (point))
1569          (setq drop-this-word-if-trailing-flag nil)          (setq drop-this-word-if-trailing-flag nil)
1570            
1571          ;; Decide what to do based on what we are looking at.          ;; Decide what to do based on what we are looking at.
1572          (cond          (cond
1573            
1574           ;; Delete title           ;; Delete title
1575           ((and (eq word-count 0)           ((and (eq word-count 0)
1576                 (looking-at mail-extr-full-name-prefixes))                 (looking-at mail-extr-full-name-prefixes))
1577            (goto-char (match-end 0))            (goto-char (match-end 0))
1578            (narrow-to-region (point) (point-max)))            (narrow-to-region (point) (point-max)))
1579            
1580           ;; Stop after name suffix           ;; Stop after name suffix
1581           ((and (>= word-count 2)           ((and (>= word-count 2)
1582                 (looking-at mail-extr-full-name-suffix-pattern))                 (looking-at mail-extr-full-name-suffix-pattern))
# Line 1598  ADDRESS may be a string or a buffer.  If Line 1598  ADDRESS may be a string or a buffer.  If
1598                   (upcase-word 1)))                   (upcase-word 1)))
1599            (setq word-found-flag t)            (setq word-found-flag t)
1600            (setq name-done-flag t))            (setq name-done-flag t))
1601            
1602           ;; Handle SCA names           ;; Handle SCA names
1603           ((looking-at "MKA \\(.+\\)")   ; "Mundanely Known As"           ((looking-at "MKA \\(.+\\)")   ; "Mundanely Known As"
1604            (goto-char (match-beginning 1))            (goto-char (match-beginning 1))
1605            (narrow-to-region (point) (point-max))            (narrow-to-region (point) (point-max))
1606            (setq begin-again-flag t))            (setq begin-again-flag t))
1607            
1608           ;; Check for initial last name followed by comma           ;; Check for initial last name followed by comma
1609           ((and (eq ?, (following-char))           ((and (eq ?, (following-char))
1610                 (eq word-count 1))                 (eq word-count 1))
# Line 1612  ADDRESS may be a string or a buffer.  If Line 1612  ADDRESS may be a string or a buffer.  If
1612            (setq last-name-comma-flag t)            (setq last-name-comma-flag t)
1613            (or (eq ?\  (following-char))            (or (eq ?\  (following-char))
1614                (insert ?\ )))                (insert ?\ )))
1615            
1616           ;; Stop before trailing comma-separated comment           ;; Stop before trailing comma-separated comment
1617           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
1618           ;; *** This case is redundant???           ;; *** This case is redundant???
1619           ;;((eq ?, (following-char))           ;;((eq ?, (following-char))
1620           ;; (setq name-done-flag t))           ;; (setq name-done-flag t))
1621            
1622           ;; Delete parenthesized/quoted comment/nickname           ;; Delete parenthesized/quoted comment/nickname
1623           ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))           ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
1624            (setq cbeg (point))            (setq cbeg (point))
# Line 1650  ADDRESS may be a string or a buffer.  If Line 1650  ADDRESS may be a string or a buffer.  If
1650              (delete-region cbeg cend)              (delete-region cbeg cend)
1651              (if initial              (if initial
1652                  (insert initial ". ")))))                  (insert initial ". ")))))
1653            
1654           ;; Handle *Stupid* VMS date stamps           ;; Handle *Stupid* VMS date stamps
1655           ((looking-at mail-extr-stupid-vms-date-stamp-pattern)           ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
1656            (replace-match "" t))            (replace-match "" t))
1657            
1658           ;; Handle Chinese characters.           ;; Handle Chinese characters.
1659           ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)           ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
1660            (goto-char (match-end 0))            (goto-char (match-end 0))
1661            (setq word-found-flag t))            (setq word-found-flag t))
1662            
1663           ;; Skip initial garbage characters.           ;; Skip initial garbage characters.
1664           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.           ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
1665           ((and (eq word-count 0)           ((and (eq word-count 0)
# Line 1668  ADDRESS may be a string or a buffer.  If Line 1668  ADDRESS may be a string or a buffer.  If
1668            ;; *** Skip backward over these???            ;; *** Skip backward over these???
1669            ;; (skip-chars-backward "& \"")            ;; (skip-chars-backward "& \"")
1670            (narrow-to-region (point) (point-max)))            (narrow-to-region (point) (point-max)))
1671            
1672           ;; Various stopping points           ;; Various stopping points
1673           ((or           ((or
1674              
1675             ;; Stop before ALL CAPS acronyms, if preceded by mixed-case             ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
1676             ;; words.  Example: XT-DEM.             ;; words.  Example: XT-DEM.
1677             (and (>= word-count 2)             (and (>= word-count 2)
1678                  mixed-case-flag                  mixed-case-flag
1679                  (looking-at mail-extr-weird-acronym-pattern)                  (looking-at mail-extr-weird-acronym-pattern)
1680                  (not (looking-at mail-extr-roman-numeral-pattern)))                  (not (looking-at mail-extr-roman-numeral-pattern)))
1681              
1682             ;; Stop before trailing alternative address             ;; Stop before trailing alternative address
1683             (looking-at mail-extr-alternative-address-pattern)             (looking-at mail-extr-alternative-address-pattern)
1684              
1685             ;; Stop before trailing comment not introduced by comma             ;; Stop before trailing comment not introduced by comma
1686             ;; THIS CASE MUST BE AFTER AN EARLIER CASE.             ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
1687             (looking-at mail-extr-trailing-comment-start-pattern)             (looking-at mail-extr-trailing-comment-start-pattern)
1688              
1689             ;; Stop before telephone numbers             ;; Stop before telephone numbers
1690             (looking-at mail-extr-telephone-extension-pattern))             (looking-at mail-extr-telephone-extension-pattern))
1691            (setq name-done-flag t))            (setq name-done-flag t))
1692            
1693           ;; Delete ham radio call signs           ;; Delete ham radio call signs
1694           ((looking-at mail-extr-ham-call-sign-pattern)           ((looking-at mail-extr-ham-call-sign-pattern)
1695            (delete-region (match-beginning 0) (match-end 0)))            (delete-region (match-beginning 0) (match-end 0)))
1696            
1697           ;; Fixup initials           ;; Fixup initials
1698           ((looking-at mail-extr-initial-pattern)           ((looking-at mail-extr-initial-pattern)
1699            (or (eq (following-char) (upcase (following-char)))            (or (eq (following-char) (upcase (following-char)))
# Line 1705  ADDRESS may be a string or a buffer.  If Line 1705  ADDRESS may be a string or a buffer.  If
1705            (or (eq ?\  (following-char))            (or (eq ?\  (following-char))
1706                (insert ?\ ))                (insert ?\ ))
1707            (setq word-found-flag t))            (setq word-found-flag t))
1708            
1709           ;; Handle BITNET LISTSERV list names.           ;; Handle BITNET LISTSERV list names.
1710           ((and (eq word-count 0)           ((and (eq word-count 0)
1711                 (looking-at mail-extr-listserv-list-name-pattern))                 (looking-at mail-extr-listserv-list-name-pattern))
1712            (narrow-to-region (match-beginning 1) (match-end 1))            (narrow-to-region (match-beginning 1) (match-end 1))
1713            (setq word-found-flag t)            (setq word-found-flag t)
1714            (setq name-done-flag t))            (setq name-done-flag t))
1715            
1716           ;; Handle & substitution, when & is last and is not first.           ;; Handle & substitution, when & is last and is not first.
1717           ((and (> word-count 0)           ((and (> word-count 0)
1718                 (eq ?\  (preceding-char))                 (eq ?\  (preceding-char))
# Line 1739  ADDRESS may be a string or a buffer.  If Line 1739  ADDRESS may be a string or a buffer.  If
1739           ((looking-at mail-extr-name-pattern)           ((looking-at mail-extr-name-pattern)
1740            (setq name-beg (point))            (setq name-beg (point))
1741            (setq name-end (match-end 0))            (setq name-end (match-end 0))
1742              
1743            ;; Certain words will be dropped if they are at the end.            ;; Certain words will be dropped if they are at the end.
1744            (and (>= word-count 2)            (and (>= word-count 2)
1745                 (not lower-case-flag)                 (not lower-case-flag)
# Line 1750  ADDRESS may be a string or a buffer.  If Line 1750  ADDRESS may be a string or a buffer.  If
1750                  ;; Drop a trailing word which is terminated with a period.                  ;; Drop a trailing word which is terminated with a period.
1751                  (eq ?. (char-after (1- name-end))))                  (eq ?. (char-after (1- name-end))))
1752                 (setq drop-this-word-if-trailing-flag t))                 (setq drop-this-word-if-trailing-flag t))
1753              
1754            ;; Set the flags that indicate whether we have seen a lowercase            ;; Set the flags that indicate whether we have seen a lowercase
1755            ;; word, a mixed case word, and an uppercase word.            ;; word, a mixed case word, and an uppercase word.
1756            (if (re-search-forward "[a-z]" name-end t)            (if (re-search-forward "[a-z]" name-end t)
# Line 1761  ADDRESS may be a string or a buffer.  If Line 1761  ADDRESS may be a string or a buffer.  If
1761                  (setq lower-case-flag t))                  (setq lower-case-flag t))
1762  ;;          (setq upper-case-flag t)  ;;          (setq upper-case-flag t)
1763              )              )
1764              
1765            (goto-char name-end)            (goto-char name-end)
1766            (setq word-found-flag t))            (setq word-found-flag t))
1767    
1768           (t           (t
1769            (setq name-done-flag t)            (setq name-done-flag t)
1770            ))            ))
1771            
1772          ;; Count any word that we skipped over.          ;; Count any word that we skipped over.
1773          (if word-found-flag          (if word-found-flag
1774              (setq word-count (1+ word-count))))              (setq word-count (1+ word-count))))
1775          
1776        ;; 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
1777        ;; other sentence terminators (but not a single period) then keep them        ;; other sentence terminators (but not a single period) then keep them
1778        ;; 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 1787  ADDRESS may be a string or a buffer.  If Line 1787  ADDRESS may be a string or a buffer.  If
1787                          (or (and drop-last-word-if-trailing-flag                          (or (and drop-last-word-if-trailing-flag
1788                                   last-word-beg)                                   last-word-beg)
1789                              (point)))                              (point)))
1790          
1791        ;; Xerox's mailers SUCK!!!!!!        ;; Xerox's mailers SUCK!!!!!!
1792        ;; 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.
1793        ;; 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 1812  ADDRESS may be a string or a buffer.  If Line 1812  ADDRESS may be a string or a buffer.  If
1812               (goto-char name-end)               (goto-char name-end)
1813               (skip-chars-forward "\t ,")               (skip-chars-forward "\t ,")
1814               (narrow-to-region (point) (point-max))))               (narrow-to-region (point) (point-max))))
1815          
1816        ;; Delete leading and trailing junk characters.        ;; Delete leading and trailing junk characters.
1817        ;; *** This is probably completely unneeded now.        ;; *** This is probably completely unneeded now.
1818        ;;(goto-char (point-max))        ;;(goto-char (point-max))
# Line 1824  ADDRESS may be a string or a buffer.  If Line 1824  ADDRESS may be a string or a buffer.  If
1824        ;;                    (goto-char (point-min))        ;;                    (goto-char (point-min))
1825        ;;                    (skip-chars-forward mail-extr-non-begin-name-chars)        ;;                    (skip-chars-forward mail-extr-non-begin-name-chars)
1826        ;;                    (point)))        ;;                    (point)))
1827          
1828        ;; Compress whitespace        ;; Compress whitespace
1829        (goto-char (point-min))        (goto-char (point-min))
1830        (while (re-search-forward "[ \t\n]+" nil t)        (while (re-search-forward "[ \t\n]+" nil t)
# Line 2128  ADDRESS may be a string or a buffer.  If Line 2128  ADDRESS may be a string or a buffer.  If
2128    
2129  ;(let ((all nil))  ;(let ((all nil))
2130  ;  (mapatoms #'(lambda (x)  ;  (mapatoms #'(lambda (x)
2131  ;               (if (and (boundp x)  ;               (if (and (boundp x)
2132  ;                        (string-match "^mail-extr-" (symbol-name x)))  ;                        (string-match "^mail-extr-" (symbol-name x)))
2133  ;                   (setq all (cons x all)))))  ;                   (setq all (cons x all)))))
2134  ;  (setq all (sort all #'string-lessp))  ;  (setq all (sort all #'string-lessp))

Legend:
Removed from v.1.34  
changed lines
  Added in v.1.34.4.1

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