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.) |
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: |
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 |
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. |
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 |
|
|
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 |
|
|
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 |
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 |
|
|
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 |
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 '~}' |
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 ?\ ) |
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)) |
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) |
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 |
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) |
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)) |
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)) |
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)) |
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) |
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))) |
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)) |
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) |
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) |
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 |
|
|
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 |
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 |
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)) |
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) |
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)) |