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