|
0
|
1 ;;; mail-extr.el --- extract full name and address from RFC 822 mail header.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Author: Joe Wells <jbw@cs.bu.edu>
|
|
|
6 ;; Maintainer: Chuck Thompson <cthomp@xemacs.org>
|
|
|
7 ;; Version: 1.8
|
|
|
8 ;; Keywords: mail
|
|
|
9
|
|
|
10 ;; This file is part of XEmacs.
|
|
|
11
|
|
|
12 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
13 ;; under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;; any later version.
|
|
|
16
|
|
|
17 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
20 ;; General Public License for more details.
|
|
|
21
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
16
|
23 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
25 ;; Boston, MA 02111-1307, USA.
|
|
0
|
26
|
|
|
27 ;;; Synched up with: Not synched with FSF but close to 19.28.
|
|
|
28
|
|
|
29 ;;; Commentary:
|
|
|
30
|
|
|
31 ;; The entry point of this code is
|
|
|
32 ;;
|
|
|
33 ;; mail-extract-address-components: (address)
|
|
|
34 ;;
|
|
|
35 ;; Given an RFC-822 ADDRESS, extract full name and canonical address.
|
|
|
36 ;; Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
|
|
|
37 ;; If no name can be extracted, FULL-NAME will be nil.
|
|
|
38 ;; ADDRESS may be a string or a buffer. If it is a buffer, the visible
|
|
|
39 ;; (narrowed) portion of the buffer will be interpreted as the address.
|
|
|
40 ;; (This feature exists so that the clever caller might be able to avoid
|
|
|
41 ;; consing a string.)
|
|
|
42 ;; If ADDRESS contains more than one RFC-822 address, only the first is
|
|
|
43 ;; returned.
|
|
|
44 ;;
|
|
|
45 ;; This code is more correct (and more heuristic) parser than the code in
|
|
|
46 ;; rfc822.el. And despite its size, it's fairly fast.
|
|
|
47 ;;
|
|
|
48 ;; There are two main benefits:
|
|
|
49 ;;
|
|
|
50 ;; 1. Higher probability of getting the correct full name for a human than
|
|
|
51 ;; any other package we know of. (On the other hand, it will cheerfully
|
|
|
52 ;; mangle non-human names/comments.)
|
|
|
53 ;; 2. Address part is put in a canonical form.
|
|
|
54 ;;
|
|
|
55 ;; The interface is not yet carved in stone; please give us suggestions.
|
|
|
56 ;;
|
|
|
57 ;; We have an extensive test-case collection of funny addresses if you want to
|
|
|
58 ;; work with the code. Developing this code requires frequent testing to
|
|
|
59 ;; make sure you're not breaking functionality. The test cases aren't included
|
|
|
60 ;; because they are over 100K.
|
|
|
61 ;;
|
|
|
62 ;; If you find an address that mail-extr fails on, please send it to the
|
|
|
63 ;; maintainer along with what you think the correct results should be. We do
|
|
|
64 ;; not consider it a bug if mail-extr mangles a comment that does not
|
|
|
65 ;; correspond to a real human full name, although we would prefer that
|
|
|
66 ;; mail-extr would return the comment as-is.
|
|
|
67 ;;
|
|
|
68 ;; Features:
|
|
|
69 ;;
|
|
|
70 ;; * Full name handling:
|
|
|
71 ;;
|
|
|
72 ;; * knows where full names can be found in an address.
|
|
|
73 ;; * avoids using empty comments and quoted text.
|
|
|
74 ;; * extracts full names from mailbox names.
|
|
|
75 ;; * recognizes common formats for comments after a full name.
|
|
|
76 ;; * puts a period and a space after each initial.
|
|
|
77 ;; * understands & referring to the mailbox name, capitalized.
|
|
|
78 ;; * strips name prefixes like "Prof.", etc.
|
|
|
79 ;; * understands what characters can occur in names (not just letters).
|
|
|
80 ;; * figures out middle initial from mailbox name.
|
|
|
81 ;; * removes funny nicknames.
|
|
|
82 ;; * keeps suffixes such as Jr., Sr., III, etc.
|
|
|
83 ;; * reorders "Last, First" type names.
|
|
|
84 ;;
|
|
|
85 ;; * Address handling:
|
|
|
86 ;;
|
|
|
87 ;; * parses rfc822 quoted text, comments, and domain literals.
|
|
|
88 ;; * parses rfc822 multi-line headers.
|
|
|
89 ;; * does something reasonable with rfc822 GROUP addresses.
|
|
|
90 ;; * handles many rfc822 noncompliant and garbage addresses.
|
|
|
91 ;; * canonicalizes addresses (after stripping comments/phrases outside <>).
|
|
|
92 ;; * converts ! addresses into .UUCP and %-style addresses.
|
|
|
93 ;; * converts rfc822 ROUTE addresses to %-style addresses.
|
|
|
94 ;; * truncates %-style addresses at leftmost fully qualified domain name.
|
|
|
95 ;; * handles local relative precedence of ! vs. % and @ (untested).
|
|
|
96 ;;
|
|
|
97 ;; It does almost no string creation. It primarily uses the built-in
|
|
|
98 ;; parsing routines with the appropriate syntax tables. This should
|
|
|
99 ;; result in greater speed.
|
|
|
100 ;;
|
|
|
101 ;; TODO:
|
|
|
102 ;;
|
|
|
103 ;; * handle all test cases. (This will take forever.)
|
|
|
104 ;; * software to pick the correct header to use (eg., "Senders-Name:").
|
|
|
105 ;; * multiple addresses in the "From:" header (almost all of the necessary
|
|
|
106 ;; code is there).
|
|
|
107 ;; * flag to not treat `,' as an address separator. (This is useful when
|
|
|
108 ;; there is a "From:" header but no "Sender:" header, because then there
|
|
|
109 ;; is only allowed to be one address.)
|
|
|
110 ;; * mailbox name does not necessarily contain full name.
|
|
|
111 ;; * fixing capitalization when it's all upper or lowercase. (Hard!)
|
|
|
112 ;; * some of the domain literal handling is missing. (But I've never even
|
|
|
113 ;; seen one of these in a mail address, so maybe no big deal.)
|
|
|
114 ;; * arrange to have syntax tables byte-compiled.
|
|
|
115 ;; * speed hacks.
|
|
|
116 ;; * delete unused variables.
|
|
|
117 ;; * arrange for testing with different relative precedences of ! vs. @
|
|
|
118 ;; and %.
|
|
|
119 ;; * insert documentation strings!
|
|
|
120 ;; * handle X.400-gatewayed addresses according to RFC 1148.
|
|
|
121
|
|
|
122 ;;; Change Log:
|
|
|
123 ;;
|
|
|
124 ;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@netscape.com)
|
|
|
125 ;;
|
|
|
126 ;; * merged with jbw's latest version
|
|
|
127 ;;
|
|
|
128 ;; Wed Feb 9 21:56:27 1994 Jamie Zawinski (jwz@netscape.com)
|
|
|
129 ;;
|
|
|
130 ;; * high-bit chars in comments weren't treated as word syntax
|
|
|
131 ;;
|
|
|
132 ;; Sat Feb 5 03:13:40 1994 Jamie Zawinski (jwz@netscape.com)
|
|
|
133 ;;
|
|
|
134 ;; * call replace-match with fixed-case arg
|
|
|
135 ;;
|
|
|
136 ;; Thu Dec 16 21:56:45 1993 Jamie Zawinski (jwz@netscape.com)
|
|
|
137 ;;
|
|
|
138 ;; * some more cleanup, doc, added provide
|
|
|
139 ;;
|
|
|
140 ;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu)
|
|
|
141 ;;
|
|
|
142 ;; * Made mail-full-name-prefixes a user-customizable variable.
|
|
2
|
143 ;; Allow passing the address as a buffer as well as a string.
|
|
0
|
144 ;; Allow [ and ] as name characters (Finnish character set).
|
|
|
145 ;;
|
|
|
146 ;; Mon Mar 22 21:20:56 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
147 ;;
|
|
|
148 ;; * Handle "null" addresses. Handle = used for spacing in mailbox
|
|
|
149 ;; name. Fix bug in handling of ROUTE-ADDR-type addresses that are
|
|
|
150 ;; missing their brackets. Handle uppercase "JR". Extract full
|
|
|
151 ;; names from X.400 addresses encoded in RFC-822. Fix bug in
|
|
|
152 ;; handling of multiple addresses where first has trailing comment.
|
|
|
153 ;; Handle more kinds of telephone extension lead-ins.
|
|
|
154 ;;
|
|
|
155 ;; Mon Mar 22 20:16:57 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
156 ;;
|
|
|
157 ;; * Handle HZ encoding for embedding GB encoded chinese characters.
|
|
|
158 ;;
|
|
|
159 ;; Mon Mar 22 00:46:12 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
160 ;;
|
|
|
161 ;; * Fixed too broad matching of ham radio call signs. Fixed bug in
|
|
|
162 ;; handling an unmatched ' in a name string. Enhanced recognition
|
|
|
163 ;; of when . in the mailbox name terminates the name portion.
|
|
|
164 ;; Narrowed conversion of . to space to only the necessary
|
|
|
165 ;; situation. Deal with VMS's stupid date stamps. Handle a unique
|
|
|
166 ;; way of introducing an alternate address. Fixed spacing bug I
|
|
|
167 ;; introduced in switching last name order. Fixed bug in handling
|
|
|
168 ;; address with ! and % but no @. Narrowed the cases in which
|
|
|
169 ;; certain trailing words are discarded.
|
|
|
170 ;;
|
|
|
171 ;; Sun Mar 21 21:41:06 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
172 ;;
|
|
|
173 ;; * Fixed bugs in handling GROUP addresses. Certain words in the
|
|
|
174 ;; middle of a name no longer terminate it. Handle LISTSERV list
|
|
|
175 ;; names. Ignore comment field containing mailbox name.
|
|
|
176 ;;
|
|
|
177 ;; Sun Mar 21 14:39:38 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
178 ;;
|
|
|
179 ;; * Moved variant-method code back into main function. Handle
|
|
|
180 ;; underscores as spaces in comments. Handle leading nickname. Add
|
|
|
181 ;; flag to ignore single-word names. Other changes.
|
|
|
182 ;;
|
|
|
183 ;; Mon Feb 1 22:23:31 1993 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
184 ;;
|
|
|
185 ;; * Added in changes by Rod Whitby and Jamie Zawinski. This
|
|
|
186 ;; includes the flag mail-extr-guess-middle-initial and the fix for
|
|
|
187 ;; handling multiple addresses correctly.
|
|
|
188 ;;
|
|
|
189 ;; Mon Apr 6 23:59:09 1992 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
190 ;;
|
|
|
191 ;; * Cleaned up some more. Release version 1.0 to world.
|
|
|
192 ;;
|
|
|
193 ;; Sun Apr 5 19:39:08 1992 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
194 ;;
|
|
|
195 ;; * Cleaned up full name extraction extensively.
|
|
|
196 ;;
|
|
|
197 ;; Sun Feb 2 14:45:24 1992 Joe Wells (jbw at bigbird.bu.edu)
|
|
|
198 ;;
|
|
|
199 ;; * Total rewrite. Integrated mail-canonicalize-address into
|
|
|
200 ;; mail-extract-address-components. Now handles GROUP addresses more
|
|
|
201 ;; or less correctly. Better handling of lots of different cases.
|
|
|
202 ;;
|
|
|
203 ;; Fri Jun 14 19:39:50 1991
|
|
|
204 ;; * Created.
|
|
|
205
|
|
|
206 ;;; Code:
|
|
|
207
|
|
|
208
|
|
|
209 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
210 ;;
|
|
|
211 ;; User configuration variable definitions.
|
|
|
212 ;;
|
|
|
213
|
|
|
214 (defvar mail-extr-guess-middle-initial nil
|
|
|
215 "*Whether to try to guess middle initial from mail address.
|
|
|
216 If true, then when we see an address like \"John Smith <jqs@host.com>\"
|
|
|
217 we will assume that \"John Q. Smith\" is the fellow's name.")
|
|
|
218
|
|
|
219 (defvar mail-extr-ignore-single-names t
|
|
|
220 "*Whether to ignore a name that is just a single word.
|
|
|
221 If true, then when we see an address like \"Idiot <dumb@stupid.com>\"
|
|
|
222 we will act as though we couldn't find a full name in the address.")
|
|
|
223
|
|
|
224 ;; Matches a leading title that is not part of the name (does not
|
|
|
225 ;; contribute to uniquely identifying the person).
|
|
|
226 (defvar mail-extr-full-name-prefixes
|
|
|
227 (purecopy
|
|
|
228 "\\(Prof\\|D[Rr]\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.?[ \t\n]")
|
|
|
229 "*Matches prefixes to the full name that identify a person's position.
|
|
|
230 These are stripped from the full name because they do not contribute to
|
|
|
231 uniquely identifying the person.")
|
|
|
232
|
|
|
233 (defvar mail-extr-@-binds-tighter-than-! nil
|
|
|
234 "*Whether the local mail transport agent looks at ! before @.")
|
|
|
235
|
|
|
236 (defvar mail-extr-mangle-uucp nil
|
|
|
237 "*Whether to throw away information in UUCP addresses
|
|
|
238 by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\".")
|
|
|
239
|
|
38
|
240 (defvar mail-extr-mailbox-match-case-fold t
|
|
|
241 "*Non-nil if mailbox and name matching should ignore case.")
|
|
|
242
|
|
0
|
243 ;;----------------------------------------------------------------------
|
|
|
244 ;; what orderings are meaningful?????
|
|
|
245 ;;(defvar mail-operator-precedence-list '(?! ?% ?@))
|
|
|
246 ;; Right operand of a % or a @ must be a domain name, period. No other
|
|
|
247 ;; operators allowed. Left operand of a @ is an address relative to that
|
|
|
248 ;; site.
|
|
|
249
|
|
|
250 ;; Left operand of a ! must be a domain name. Right operand is an
|
|
|
251 ;; arbitrary address.
|
|
|
252 ;;----------------------------------------------------------------------
|
|
|
253
|
|
|
254
|
|
|
255
|
|
|
256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
257 ;;
|
|
|
258 ;; Constant definitions.
|
|
|
259 ;;
|
|
|
260
|
|
|
261 ;; Codes in
|
|
|
262 ;; Names in ISO 8859-1 Name
|
|
|
263 ;; ISO 10XXX ISO 8859-2 in
|
|
|
264 ;; ISO 6937 ISO 10646 RFC Swedish
|
|
|
265 ;; etc. Hex Oct 1345 TeX Split ASCII Description
|
|
|
266 ;; --------- ---------- ---- --- ----- ----- -------------------------------
|
|
|
267 ;; %a E4 344 a: \"a ae { latin small a + diaeresis ä
|
|
|
268 ;; %o F6 366 o: \"o oe | latin small o + diaeresis ö
|
|
|
269 ;; @a E5 345 aa \oa aa } latin small a + ring above å
|
|
|
270 ;; %u FC 374 u: \"u ue ~ latin small u + diaeresis ü
|
|
|
271 ;; /e E9 351 e' \'e ` latin small e + acute é
|
|
|
272 ;; %A C4 304 A: \"A AE [ latin capital a + diaeresis Ä
|
|
|
273 ;; %O D6 326 O: \"O OE \ latin capital o + diaeresis Ö
|
|
|
274 ;; @A C5 305 AA \oA AA ] latin capital a + ring above Å
|
|
|
275 ;; %U DC 334 U: \"U UE ^ latin capital u + diaeresis Ü
|
|
|
276 ;; /E C9 311 E' \'E @ latin capital e + acute É
|
|
|
277
|
|
|
278 ;; NOTE: @a and @A are not in ISO 8859-2 (the codes mentioned above invoke
|
|
|
279 ;; /l and /L). Some of this data was retrieved from
|
|
|
280 ;; listserv@jhuvm.hcf.jhu.edu.
|
|
|
281
|
|
|
282 ;; Any character that can occur in a name, not counting characters that
|
|
|
283 ;; separate parts of a multipart name (hyphen and period).
|
|
|
284 ;; Yes, there are weird people with digits in their names.
|
|
|
285 ;; You will also notice the consideration for the
|
|
|
286 ;; Swedish/Finnish/Norwegian character set.
|
|
|
287 ;; #### (go to \376 instead of \377 to work around bug in search.c...)
|
|
|
288 (defconst mail-extr-all-letters-but-separators
|
|
|
289 (purecopy "][A-Za-z{|}'~0-9`\200-\376"))
|
|
|
290
|
|
|
291 ;; Any character that can occur in a name in an RFC822 address including
|
|
|
292 ;; the separator (hyphen and possibly period) for multipart names.
|
|
|
293 ;; #### should . be in here?
|
|
|
294 (defconst mail-extr-all-letters
|
|
|
295 (purecopy (concat mail-extr-all-letters-but-separators "---")))
|
|
|
296
|
|
|
297 ;; Any character that can start a name.
|
|
|
298 ;; Keep this set as minimal as possible.
|
|
|
299 (defconst mail-extr-first-letters (purecopy "A-Za-z"))
|
|
|
300
|
|
|
301 ;; Any character that can end a name.
|
|
|
302 ;; Keep this set as minimal as possible.
|
|
|
303 (defconst mail-extr-last-letters (purecopy "[A-Za-z`'."))
|
|
|
304
|
|
|
305 (defconst mail-extr-leading-garbage
|
|
|
306 (purecopy (format "[^%s]+" mail-extr-first-letters)))
|
|
|
307
|
|
|
308 ;; (defconst mail-extr-non-name-chars
|
|
|
309 ;; (purecopy (concat "^" mail-extr-all-letters ".")))
|
|
|
310 ;; (defconst mail-extr-non-begin-name-chars
|
|
|
311 ;; (purecopy (concat "^" mail-extr-first-letters)))
|
|
|
312 ;; (defconst mail-extr-non-end-name-chars
|
|
|
313 ;; (purecopy (concat "^" mail-extr-last-letters)))
|
|
|
314
|
|
|
315 ;; Matches an initial not followed by both a period and a space.
|
|
|
316 ;; (defconst mail-extr-bad-initials-pattern
|
|
|
317 ;; (purecopy
|
|
|
318 ;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
|
|
|
319 ;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))
|
|
|
320
|
|
|
321 ;; Matches periods used instead of spaces. Must not match the period
|
|
|
322 ;; following an initial.
|
|
|
323 (defconst mail-extr-bad-dot-pattern
|
|
|
324 (purecopy
|
|
|
325 (format "\\([%s][%s]\\)\\.+\\([%s]\\)"
|
|
|
326 mail-extr-all-letters
|
|
|
327 mail-extr-last-letters
|
|
|
328 mail-extr-first-letters)))
|
|
|
329
|
|
|
330 ;; Matches an embedded or leading nickname that should be removed.
|
|
|
331 ;; (defconst mail-extr-nickname-pattern
|
|
|
332 ;; (purecopy
|
|
|
333 ;; (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] "
|
|
|
334 ;; mail-extr-all-letters)))
|
|
|
335
|
|
|
336 ;; Matches the occurrence of a generational name suffix, and the last
|
|
|
337 ;; character of the preceding name. This is important because we want to
|
|
|
338 ;; keep such suffixes: they help to uniquely identify the person.
|
|
|
339 ;; *** Perhaps this should be a user-customizable variable. However, the
|
|
|
340 ;; *** regular expression is fairly tricky to alter, so maybe not.
|
|
|
341 (defconst mail-extr-full-name-suffix-pattern
|
|
|
342 (purecopy
|
|
|
343 (format
|
|
|
344 "\\(,? ?\\([JjSs][Rr]\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)"
|
|
|
345 mail-extr-all-letters mail-extr-all-letters)))
|
|
|
346
|
|
|
347 (defconst mail-extr-roman-numeral-pattern (purecopy "V?I+V?\\b"))
|
|
|
348
|
|
|
349 ;; Matches a trailing uppercase (with other characters possible) acronym.
|
|
|
350 ;; Must not match a trailing uppercase last name or trailing initial
|
|
|
351 (defconst mail-extr-weird-acronym-pattern
|
|
|
352 (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)"))
|
|
|
353
|
|
|
354 ;; Matches a mixed-case or lowercase name (not an initial).
|
|
|
355 ;; #### Match Latin1 lower case letters here too?
|
|
|
356 ;; (defconst mail-extr-mixed-case-name-pattern
|
|
|
357 ;; (purecopy
|
|
|
358 ;; (format
|
|
|
359 ;; "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)"
|
|
|
360 ;; mail-extr-all-letters mail-extr-last-letters
|
|
|
361 ;; mail-extr-first-letters mail-extr-all-letters mail-extr-all-letters
|
|
|
362 ;; mail-extr-last-letters mail-extr-first-letters mail-extr-all-letters)))
|
|
|
363
|
|
|
364 ;; Matches a trailing alternative address.
|
|
|
365 ;; #### Match Latin1 letters here too?
|
|
|
366 ;; #### Match _ before @ here too?
|
|
|
367 (defconst mail-extr-alternative-address-pattern
|
|
|
368 (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]"))
|
|
|
369
|
|
|
370 ;; Matches a variety of trailing comments not including comma-delimited
|
|
|
371 ;; comments.
|
|
|
372 (defconst mail-extr-trailing-comment-start-pattern
|
|
|
373 (purecopy " [-{]\\|--\\|[+@#></\;]"))
|
|
|
374
|
|
|
375 ;; Matches a name (not an initial).
|
|
|
376 ;; This doesn't force a word boundary at the end because sometimes a
|
|
|
377 ;; comment is separated by a `-' with no preceding space.
|
|
|
378 (defconst mail-extr-name-pattern
|
|
|
379 (purecopy (format "\\b[%s][%s]*[%s]"
|
|
|
380 mail-extr-first-letters
|
|
|
381 mail-extr-all-letters
|
|
|
382 mail-extr-last-letters)))
|
|
|
383
|
|
|
384 (defconst mail-extr-initial-pattern
|
|
|
385 (purecopy (format "\\b[%s]\\([. ]\\|\\b\\)" mail-extr-first-letters)))
|
|
|
386
|
|
|
387 ;; Matches a single name before a comma.
|
|
|
388 ;; (defconst mail-extr-last-name-first-pattern
|
|
|
389 ;; (purecopy (concat "\\`" mail-extr-name-pattern ",")))
|
|
|
390
|
|
|
391 ;; Matches telephone extensions.
|
|
|
392 (defconst mail-extr-telephone-extension-pattern
|
|
|
393 (purecopy
|
|
|
394 "\\(\\([Ee]xt\\|\\|[Tt]ph\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+"))
|
|
|
395
|
|
|
396 ;; Matches ham radio call signs.
|
|
|
397 ;; Help from: Mat Maessen N2NJZ <maessm@rpi.edu>, Mark Feit
|
|
|
398 ;; <mark@era.com>, Michael Covington <mcovingt@ai.uga.edu>.
|
|
|
399 ;; Examples: DX504 DX515 K5MRU K8DHK KA9WGN KA9WGN KD3FU KD6EUI KD6HBW
|
|
|
400 ;; KE9TV KF0NV N1API N3FU N3GZE N3IGS N4KCC N7IKQ N9HHU W4YHF W6ANK WA2SUH
|
|
|
401 ;; WB7VZI N2NJZ NR3G KJ4KK AB4UM AL7NI KH6OH WN3KBT N4TMI W1A N0NZO
|
|
|
402 (defconst mail-extr-ham-call-sign-pattern
|
|
|
403 (purecopy "\\b\\(DX[0-9]+\\|[AKNW][A-Z]?[0-9][A-Z][A-Z]?[A-Z]?\\)"))
|
|
|
404
|
|
|
405 ;; Possible trailing suffixes: "\\(/\\(KT\\|A[AEG]\\|[R0-9]\\)\\)?"
|
|
|
406 ;; /KT == Temporary Technician (has CSC but not "real" license)
|
|
|
407 ;; /AA == Temporary Advanced
|
|
|
408 ;; /AE == Temporary Extra
|
|
|
409 ;; /AG == Temporary General
|
|
|
410 ;; /R == repeater
|
|
|
411 ;; /# == stations operating out of home district
|
|
|
412 ;; I don't include these in the regexp above because I can't imagine
|
|
|
413 ;; anyone putting them with their name in an e-mail address.
|
|
|
414
|
|
|
415 ;; Matches normal single-part name
|
|
|
416 (defconst mail-extr-normal-name-pattern
|
|
|
417 (purecopy (format "\\b[%s][%s]+[%s]"
|
|
|
418 mail-extr-first-letters
|
|
|
419 mail-extr-all-letters-but-separators
|
|
|
420 mail-extr-last-letters)))
|
|
|
421
|
|
|
422 ;; Matches a single word name.
|
|
|
423 ;; (defconst mail-extr-one-name-pattern
|
|
|
424 ;; (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'")))
|
|
|
425
|
|
|
426 ;; Matches normal two names with missing middle initial
|
|
|
427 ;; The first name is not allowed to have a hyphen because this can cause
|
|
|
428 ;; false matches where the "middle initial" is actually the first letter
|
|
|
429 ;; of the second part of the first name.
|
|
|
430 (defconst mail-extr-two-name-pattern
|
|
|
431 (purecopy
|
|
|
432 (concat "\\`\\(" mail-extr-normal-name-pattern
|
|
|
433 "\\|" mail-extr-initial-pattern
|
|
|
434 "\\) +\\(" mail-extr-name-pattern "\\)\\(,\\|\\'\\)")))
|
|
|
435
|
|
|
436 (defconst mail-extr-listserv-list-name-pattern
|
|
|
437 (purecopy "Multiple recipients of list \\([-A-Z]+\\)"))
|
|
|
438
|
|
|
439 (defconst mail-extr-stupid-vms-date-stamp-pattern
|
|
|
440 (purecopy
|
|
|
441 "[0-9][0-9]-[JFMASOND][aepuco][nbrylgptvc]-[0-9][0-9][0-9][0-9] [0-9]+ *"))
|
|
|
442
|
|
|
443 ;;; HZ -- GB (PRC Chinese character encoding) in ASCII embedding protocol
|
|
|
444 ;;
|
|
|
445 ;; In ASCII mode, a byte is interpreted as an ASCII character, unless a '~' is
|
|
|
446 ;; encountered. The character '~' is an escape character. By convention, it
|
|
|
447 ;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the
|
|
|
448 ;; following special meaning.
|
|
|
449 ;;
|
|
|
450 ;; o The escape sequence '~~' is interpreted as a '~'.
|
|
|
451 ;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB.
|
|
|
452 ;; o The escape sequence '~\n' is a line-continuation marker to be consumed
|
|
|
453 ;; with no output produced.
|
|
|
454 ;;
|
|
|
455 ;; In GB mode, characters are interpreted two bytes at a time as (pure) GB
|
|
|
456 ;; codes until the escape-from-GB code '~}' is read. This code switches the
|
|
|
457 ;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}'
|
|
|
458 ;; ($7E7D) is outside the defined GB range.)
|
|
|
459 (defconst mail-extr-hz-embedded-gb-encoded-chinese-pattern
|
|
|
460 (purecopy "~{\\([^~].\\|~[^\}]\\)+~}"))
|
|
|
461
|
|
|
462 ;; The leading optional lowercase letters are for a bastardized version of
|
|
|
463 ;; the encoding, as is the optional nature of the final slash.
|
|
|
464 (defconst mail-extr-x400-encoded-address-pattern
|
|
|
465 (purecopy "[a-z]?[a-z]?\\(/[A-Za-z]+\\(\\.[A-Za-z]+\\)?=[^/]+\\)+/?\\'"))
|
|
|
466
|
|
|
467 (defconst mail-extr-x400-encoded-address-field-pattern-format
|
|
|
468 (purecopy "/%s=\\([^/]+\\)\\(/\\|\\'\\)"))
|
|
|
469
|
|
|
470 (defconst mail-extr-x400-encoded-address-surname-pattern
|
|
|
471 ;; S stands for Surname (family name).
|
|
|
472 (purecopy
|
|
|
473 (format mail-extr-x400-encoded-address-field-pattern-format "[Ss]")))
|
|
|
474
|
|
|
475 (defconst mail-extr-x400-encoded-address-given-name-pattern
|
|
|
476 ;; G stands for Given name.
|
|
|
477 (purecopy
|
|
|
478 (format mail-extr-x400-encoded-address-field-pattern-format "[Gg]")))
|
|
|
479
|
|
|
480 (defconst mail-extr-x400-encoded-address-full-name-pattern
|
|
|
481 ;; PN stands for Personal Name. When used it represents the combination
|
|
|
482 ;; of the G and S fields.
|
|
|
483 ;; "The one system I used having this field asked it with the prompt
|
|
|
484 ;; `Personal Name'. But they mapped it into G and S on outgoing real
|
|
|
485 ;; X.400 addresses. As they mapped G and S into PN on incoming..."
|
|
|
486 (purecopy
|
|
|
487 (format mail-extr-x400-encoded-address-field-pattern-format "[Pp][Nn]")))
|
|
|
488
|
|
|
489
|
|
|
490
|
|
|
491 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
492 ;;
|
|
|
493 ;; Syntax tables used for quick parsing.
|
|
|
494 ;;
|
|
|
495
|
|
|
496 (defconst mail-extr-address-syntax-table (make-syntax-table))
|
|
|
497 (defconst mail-extr-address-comment-syntax-table (make-syntax-table))
|
|
|
498 (defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table))
|
|
|
499 (defconst mail-extr-address-text-comment-syntax-table (make-syntax-table))
|
|
|
500 (defconst mail-extr-address-text-syntax-table (make-syntax-table))
|
|
|
501 (mapcar
|
|
|
502 (function
|
|
|
503 (lambda (pair)
|
|
|
504 (let ((syntax-table (symbol-value (car pair))))
|
|
|
505 (mapcar
|
|
|
506 (function
|
|
|
507 (lambda (item)
|
|
|
508 (if (eq 2 (length item))
|
|
|
509 ;; modifying syntax of a single character
|
|
|
510 (modify-syntax-entry (car item) (car (cdr item)) syntax-table)
|
|
|
511 ;; modifying syntax of a range of characters
|
|
|
512 (let ((char (nth 0 item))
|
|
|
513 (bound (nth 1 item))
|
|
|
514 (syntax (nth 2 item)))
|
|
|
515 (while (<= char bound)
|
|
|
516 (modify-syntax-entry char syntax syntax-table)
|
|
|
517 (setq char (1+ char)))))))
|
|
|
518 (cdr pair)))))
|
|
|
519 '((mail-extr-address-syntax-table
|
|
|
520 (?\000 ?\037 "w") ;control characters
|
|
|
521 (?\040 " ") ;SPC
|
|
|
522 (?! ?~ "w") ;printable characters
|
|
|
523 (?\177 "w") ;DEL
|
|
|
524 (?\200 ?\377 "w") ;high-bit-on characters
|
|
|
525 (?\240 " ") ;nobreakspace
|
|
|
526 (?\t " ")
|
|
|
527 (?\r " ")
|
|
|
528 (?\n " ")
|
|
|
529 (?\( ".")
|
|
|
530 (?\) ".")
|
|
|
531 (?< ".")
|
|
|
532 (?> ".")
|
|
|
533 (?@ ".")
|
|
|
534 (?, ".")
|
|
|
535 (?\; ".")
|
|
|
536 (?: ".")
|
|
|
537 (?\\ "\\")
|
|
|
538 (?\" "\"")
|
|
|
539 (?. ".")
|
|
|
540 (?\[ ".")
|
|
|
541 (?\] ".")
|
|
|
542 ;; % and ! aren't RFC822 characters, but it is convenient to pretend
|
|
|
543 (?% ".")
|
|
|
544 (?! ".") ;; this needs to be word-constituent when not in .UUCP mode
|
|
|
545 )
|
|
|
546 (mail-extr-address-comment-syntax-table
|
|
|
547 (?\000 ?\377 "w")
|
|
|
548 (?\040 " ")
|
|
|
549 (?\240 " ")
|
|
|
550 (?\t " ")
|
|
|
551 (?\r " ")
|
|
|
552 (?\n " ")
|
|
|
553 (?\( "\(\)")
|
|
|
554 (?\) "\)\(")
|
|
|
555 (?\\ "\\"))
|
|
|
556 (mail-extr-address-domain-literal-syntax-table
|
|
|
557 (?\000 ?\377 "w")
|
|
|
558 (?\040 " ")
|
|
|
559 (?\240 " ")
|
|
|
560 (?\t " ")
|
|
|
561 (?\r " ")
|
|
|
562 (?\n " ")
|
|
|
563 (?\[ "\(\]") ;??????
|
|
|
564 (?\] "\)\[") ;??????
|
|
|
565 (?\\ "\\"))
|
|
|
566 (mail-extr-address-text-comment-syntax-table
|
|
|
567 (?\000 ?\377 "w")
|
|
|
568 (?\040 " ")
|
|
|
569 (?\240 " ")
|
|
|
570 (?\t " ")
|
|
|
571 (?\r " ")
|
|
|
572 (?\n " ")
|
|
|
573 (?\( "\(\)")
|
|
|
574 (?\) "\)\(")
|
|
|
575 (?\[ "\(\]")
|
|
|
576 (?\] "\)\[")
|
|
|
577 (?\{ "\(\}")
|
|
|
578 (?\} "\)\{")
|
|
|
579 (?\\ "\\")
|
|
|
580 (?\" "\"")
|
|
|
581 ;; (?\' "\)\`")
|
|
|
582 ;; (?\` "\(\'")
|
|
|
583 )
|
|
|
584 (mail-extr-address-text-syntax-table
|
|
|
585 (?\000 ?\177 ".")
|
|
|
586 (?\200 ?\377 "w")
|
|
|
587 (?\040 " ")
|
|
|
588 (?\t " ")
|
|
|
589 (?\r " ")
|
|
|
590 (?\n " ")
|
|
|
591 (?A ?Z "w")
|
|
|
592 (?a ?z "w")
|
|
|
593 (?- "w")
|
|
|
594 (?\} "w")
|
|
|
595 (?\{ "w")
|
|
|
596 (?| "w")
|
|
|
597 (?\' "w")
|
|
|
598 (?~ "w")
|
|
|
599 (?0 ?9 "w"))
|
|
|
600 ))
|
|
|
601
|
|
|
602
|
|
|
603 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
604 ;;
|
|
|
605 ;; Utility functions and macros.
|
|
|
606 ;;
|
|
|
607
|
|
|
608 (defmacro mail-extr-delete-char (n)
|
|
|
609 ;; in v19, delete-char is compiled as a function call, but delete-region
|
|
|
610 ;; is byte-coded, so it's much much faster.
|
|
|
611 (list 'delete-region '(point) (list '+ '(point) n)))
|
|
|
612
|
|
|
613 (defmacro mail-extr-skip-whitespace-forward ()
|
|
|
614 ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
|
|
|
615 '(skip-chars-forward " \t\n\r\240"))
|
|
|
616
|
|
|
617 (defmacro mail-extr-skip-whitespace-backward ()
|
|
|
618 ;; v19 fn skip-syntax-backward is more tasteful, but not byte-coded.
|
|
|
619 '(skip-chars-backward " \t\n\r\240"))
|
|
|
620
|
|
|
621
|
|
|
622 (defmacro mail-extr-undo-backslash-quoting (beg end)
|
|
|
623 (`(save-excursion
|
|
|
624 (save-restriction
|
|
|
625 (narrow-to-region (, beg) (, end))
|
|
|
626 (goto-char (point-min))
|
|
|
627 ;; undo \ quoting
|
|
|
628 (while (search-forward "\\" nil t)
|
|
|
629 (mail-extr-delete-char -1)
|
|
|
630 (or (eobp)
|
|
|
631 (forward-char 1))
|
|
|
632 )))))
|
|
|
633
|
|
|
634 (defmacro mail-extr-nuke-char-at (pos)
|
|
|
635 (` (save-excursion
|
|
|
636 (goto-char (, pos))
|
|
|
637 (mail-extr-delete-char 1)
|
|
|
638 (insert ?\ ))))
|
|
|
639
|
|
|
640 (put 'mail-extr-nuke-outside-range
|
|
|
641 'edebug-form-spec '(symbolp &optional form form atom))
|
|
|
642
|
|
|
643 (defmacro mail-extr-nuke-outside-range (list-symbol
|
|
|
644 beg-symbol end-symbol
|
|
|
645 &optional no-replace)
|
|
|
646 ;; LIST-SYMBOL names a variable holding a list of buffer positions
|
|
|
647 ;; BEG-SYMBOL and END-SYMBOL name variables delimiting a range
|
|
|
648 ;; Each element of LIST-SYMBOL which lies outside of the range is
|
|
|
649 ;; deleted from the list.
|
|
|
650 ;; Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
|
|
|
651 ;; which lie outside of the range, one character at that position is
|
|
|
652 ;; replaced with a SPC.
|
|
|
653 (or (memq no-replace '(t nil))
|
|
|
654 (error "no-replace must be t or nil, evalable at macroexpand-time."))
|
|
|
655 (` (let ((temp (, list-symbol))
|
|
|
656 ch)
|
|
|
657 (while temp
|
|
|
658 (setq ch (car temp))
|
|
|
659 (cond ((or (> ch (, end-symbol))
|
|
|
660 (< ch (, beg-symbol)))
|
|
|
661 (,@ (if no-replace
|
|
|
662 nil
|
|
|
663 (` ((mail-extr-nuke-char-at ch)))))
|
|
|
664 (setcar temp nil)))
|
|
|
665 (setq temp (cdr temp)))
|
|
|
666 (setq (, list-symbol) (delq nil (, list-symbol))))))
|
|
|
667
|
|
|
668 (defun mail-extr-demarkerize (marker)
|
|
|
669 ;; if arg is a marker, destroys the marker, then returns the old value.
|
|
|
670 ;; otherwise returns the arg.
|
|
|
671 (if (markerp marker)
|
|
|
672 (let ((temp (marker-position marker)))
|
|
|
673 (set-marker marker nil)
|
|
|
674 temp)
|
|
|
675 marker))
|
|
|
676
|
|
|
677 (defun mail-extr-markerize (pos)
|
|
|
678 ;; coerces pos to a marker if non-nil.
|
|
|
679 (if (or (markerp pos) (null pos))
|
|
|
680 pos
|
|
|
681 (copy-marker pos)))
|
|
|
682
|
|
|
683 (defmacro mail-extr-last (list)
|
|
|
684 ;; Returns last element of LIST.
|
|
|
685 ;; Could be a subst.
|
|
|
686 (` (let ((list (, list)))
|
|
|
687 (while (not (null (cdr list)))
|
|
|
688 (setq list (cdr list)))
|
|
|
689 (car list))))
|
|
|
690
|
|
|
691 (defmacro mail-extr-safe-move-sexp (arg)
|
|
|
692 ;; Safely skip over one balanced sexp, if there is one. Return t if success.
|
|
|
693 (` (condition-case error
|
|
|
694 (progn
|
|
|
695 (goto-char (scan-sexps (point) (, arg)))
|
|
|
696 t)
|
|
|
697 (error
|
|
|
698 ;; #### kludge kludge kludge kludge kludge kludge kludge !!!
|
|
|
699 (if (string-equal (nth 1 error) "Unbalanced parentheses")
|
|
|
700 nil
|
|
|
701 (while t
|
|
|
702 (signal (car error) (cdr error))))))))
|
|
|
703
|
|
|
704 (or (fboundp 'buffer-disable-undo) ;; v18 compat
|
|
|
705 (fset 'buffer-disable-undo 'buffer-flush-undo))
|
|
|
706
|
|
|
707
|
|
|
708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
709 ;;
|
|
|
710 ;; The main function to grind addresses
|
|
|
711 ;;
|
|
|
712
|
|
|
713 (defvar disable-initial-guessing-flag) ; dynamic assignment
|
|
|
714 (defvar cbeg) ; dynamic assignment
|
|
|
715 (defvar cend) ; dynamic assignment
|
|
|
716
|
|
|
717 ;;;###autoload
|
|
|
718 (defun mail-extract-address-components (address)
|
|
|
719 "Given an RFC-822 ADDRESS, extract full name and canonical address.
|
|
|
720 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
|
|
|
721 If no name can be extracted, FULL-NAME will be nil.
|
|
|
722 ADDRESS may be a string or a buffer. If it is a buffer, the visible
|
|
|
723 (narrowed) portion of the buffer will be interpreted as the address.
|
|
|
724 (This feature exists so that the clever caller might be able to avoid
|
|
|
725 consing a string.)
|
|
|
726 If ADDRESS contains more than one RFC-822 address, only the first is
|
|
|
727 returned. Some day this function may be extended to extract multiple
|
|
|
728 addresses, or perhaps return the position at which parsing stopped."
|
|
|
729 (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
|
|
|
730 (extraction-buffer (get-buffer-create " *extract address components*"))
|
|
|
731 char
|
|
|
732 ;; multiple-addresses
|
|
|
733 <-pos >-pos @-pos colon-pos comma-pos !-pos %-pos \;-pos
|
|
|
734 group-colon-pos group-\;-pos route-addr-colon-pos
|
|
|
735 record-pos-symbol
|
|
|
736 first-real-pos last-real-pos
|
|
|
737 phrase-beg phrase-end
|
|
|
738 cbeg cend ; dynamically set from -voodoo
|
|
|
739 quote-beg quote-end
|
|
|
740 atom-beg atom-end
|
|
|
741 mbox-beg mbox-end
|
|
|
742 \.-ends-name
|
|
|
743 temp
|
|
|
744 ;; name-suffix
|
|
|
745 fi mi li ; first, middle, last initial
|
|
|
746 saved-%-pos saved-!-pos saved-@-pos
|
|
|
747 domain-pos \.-pos insert-point
|
|
|
748 ;; mailbox-name-processed-flag
|
|
|
749 disable-initial-guessing-flag ; dynamically set from -voodoo
|
|
|
750 )
|
|
|
751
|
|
|
752 (save-excursion
|
|
|
753 (set-buffer extraction-buffer)
|
|
|
754 (fundamental-mode)
|
|
|
755 (kill-all-local-variables)
|
|
|
756 (buffer-disable-undo extraction-buffer)
|
|
|
757 (set-syntax-table mail-extr-address-syntax-table)
|
|
|
758 (widen)
|
|
|
759 (erase-buffer)
|
|
|
760 (setq case-fold-search nil)
|
|
|
761
|
|
|
762 ;; Insert extra space at beginning to allow later replacement with <
|
|
|
763 ;; without having to move markers.
|
|
|
764 (insert ?\ )
|
|
|
765
|
|
|
766 ;; Insert the address itself.
|
|
|
767 (cond ((stringp address)
|
|
|
768 (insert address))
|
|
|
769 ((bufferp address)
|
|
|
770 (insert-buffer-substring address))
|
|
|
771 (t
|
|
|
772 (error "Illegal address: %s" address)))
|
|
|
773
|
|
|
774 ;; stolen from rfc822.el
|
|
|
775 ;; Unfold multiple lines.
|
|
|
776 (goto-char (point-min))
|
|
|
777 (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
|
|
|
778 (replace-match "\\1 " t))
|
|
|
779
|
|
|
780 ;; first pass grabs useful information about address
|
|
|
781 (goto-char (point-min))
|
|
|
782 (while (progn
|
|
|
783 (mail-extr-skip-whitespace-forward)
|
|
|
784 (not (eobp)))
|
|
|
785 (setq char (char-after (point)))
|
|
|
786 (or first-real-pos
|
|
|
787 (if (not (eq char ?\())
|
|
|
788 (setq first-real-pos (point))))
|
|
|
789 (cond
|
|
|
790 ;; comment
|
|
|
791 ((eq char ?\()
|
|
|
792 (set-syntax-table mail-extr-address-comment-syntax-table)
|
|
|
793 ;; only record the first non-empty comment's position
|
|
|
794 (if (and (not cbeg)
|
|
|
795 (save-excursion
|
|
|
796 (forward-char 1)
|
|
|
797 (mail-extr-skip-whitespace-forward)
|
|
|
798 (not (eq ?\) (char-after (point))))))
|
|
|
799 (setq cbeg (point)))
|
|
|
800 ;; TODO: don't record if unbalanced
|
|
|
801 (or (mail-extr-safe-move-sexp 1)
|
|
|
802 (forward-char 1))
|
|
|
803 (set-syntax-table mail-extr-address-syntax-table)
|
|
|
804 (if (and cbeg
|
|
|
805 (not cend))
|
|
|
806 (setq cend (point))))
|
|
|
807 ;; quoted text
|
|
|
808 ((eq char ?\")
|
|
|
809 ;; only record the first non-empty quote's position
|
|
|
810 (if (and (not quote-beg)
|
|
|
811 (save-excursion
|
|
|
812 (forward-char 1)
|
|
|
813 (mail-extr-skip-whitespace-forward)
|
|
|
814 (not (eq ?\" (char-after (point))))))
|
|
|
815 (setq quote-beg (point)))
|
|
|
816 ;; TODO: don't record if unbalanced
|
|
|
817 (or (mail-extr-safe-move-sexp 1)
|
|
|
818 (forward-char 1))
|
|
|
819 (if (and quote-beg
|
|
|
820 (not quote-end))
|
|
|
821 (setq quote-end (point))))
|
|
|
822 ;; domain literals
|
|
|
823 ((eq char ?\[)
|
|
|
824 (set-syntax-table mail-extr-address-domain-literal-syntax-table)
|
|
|
825 (or (mail-extr-safe-move-sexp 1)
|
|
|
826 (forward-char 1))
|
|
|
827 (set-syntax-table mail-extr-address-syntax-table))
|
|
|
828 ;; commas delimit addresses when outside < > pairs.
|
|
|
829 ((and (eq char ?,)
|
|
|
830 (or (and (null <-pos)
|
|
|
831 ;; Handle ROUTE-ADDR address that is missing its <.
|
|
|
832 (not (eq ?@ (char-after (1+ (point))))))
|
|
|
833 (and >-pos
|
|
|
834 ;; handle weird munged addresses
|
|
|
835 ;; BUG FIX: This test was reversed. Thanks to the
|
|
|
836 ;; brilliant Rod Whitby <rwhitby@research.canon.oz.au>
|
|
|
837 ;; for discovering this!
|
|
|
838 (< (mail-extr-last <-pos) (car >-pos)))))
|
|
|
839 ;; It'd be great if some day this worked, but for now, punt.
|
|
|
840 ;; (setq multiple-addresses t)
|
|
|
841 ;; ;; *** Why do I want this:
|
|
|
842 ;; (mail-extr-delete-char 1)
|
|
|
843 ;; (narrow-to-region (point-min) (point))
|
|
|
844 (delete-region (point) (point-max))
|
|
|
845 (setq char ?\() ; HAVE I NO SHAME??
|
|
|
846 )
|
|
|
847 ;; record the position of various interesting chars, determine
|
|
|
848 ;; legality later.
|
|
|
849 ((setq record-pos-symbol
|
|
|
850 (cdr (assq char
|
|
|
851 '((?< . <-pos) (?> . >-pos) (?@ . @-pos)
|
|
|
852 (?: . colon-pos) (?, . comma-pos) (?! . !-pos)
|
|
|
853 (?% . %-pos) (?\; . \;-pos)))))
|
|
|
854 (set record-pos-symbol
|
|
|
855 (cons (point) (symbol-value record-pos-symbol)))
|
|
|
856 (forward-char 1))
|
|
|
857 ((eq char ?.)
|
|
|
858 (forward-char 1))
|
|
|
859 ((memq char '(
|
|
|
860 ;; comment terminator illegal
|
|
|
861 ?\)
|
|
|
862 ;; domain literal terminator illegal
|
|
|
863 ?\]
|
|
|
864 ;; \ allowed only within quoted strings,
|
|
|
865 ;; domain literals, and comments
|
|
|
866 ?\\
|
|
|
867 ))
|
|
|
868 (mail-extr-nuke-char-at (point))
|
|
|
869 (forward-char 1))
|
|
|
870 (t
|
|
|
871 (forward-word 1)))
|
|
|
872 (or (eq char ?\()
|
|
|
873 ;; At the end of first address of a multiple address header.
|
|
|
874 (and (eq char ?,)
|
|
|
875 (eobp))
|
|
|
876 (setq last-real-pos (point))))
|
|
|
877
|
|
|
878 ;; Use only the leftmost <, if any. Replace all others with spaces.
|
|
|
879 (while (cdr <-pos)
|
|
|
880 (mail-extr-nuke-char-at (car <-pos))
|
|
|
881 (setq <-pos (cdr <-pos)))
|
|
|
882
|
|
|
883 ;; Use only the rightmost >, if any. Replace all others with spaces.
|
|
|
884 (while (cdr >-pos)
|
|
|
885 (mail-extr-nuke-char-at (nth 1 >-pos))
|
|
|
886 (setcdr >-pos (nthcdr 2 >-pos)))
|
|
|
887
|
|
|
888 ;; If multiple @s and a :, but no < and >, insert around buffer.
|
|
|
889 ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc
|
|
|
890 ;; This commonly happens on the UUCP "From " line. Ugh.
|
|
|
891 (cond ((and (> (length @-pos) 1)
|
|
|
892 (eq 1 (length colon-pos)) ;TODO: check if between last two @s
|
|
|
893 (not \;-pos)
|
|
|
894 (not <-pos))
|
|
|
895 (goto-char (point-min))
|
|
|
896 (mail-extr-delete-char 1)
|
|
|
897 (setq <-pos (list (point)))
|
|
|
898 (insert ?<)))
|
|
|
899
|
|
|
900 ;; If < but no >, insert > in rightmost possible position
|
|
|
901 (cond ((and <-pos
|
|
|
902 (null >-pos))
|
|
|
903 (goto-char (point-max))
|
|
|
904 (setq >-pos (list (point)))
|
|
|
905 (insert ?>)))
|
|
|
906
|
|
|
907 ;; If > but no <, replace > with space.
|
|
|
908 (cond ((and >-pos
|
|
|
909 (null <-pos))
|
|
|
910 (mail-extr-nuke-char-at (car >-pos))
|
|
|
911 (setq >-pos nil)))
|
|
|
912
|
|
|
913 ;; Turn >-pos and <-pos into non-lists
|
|
|
914 (setq >-pos (car >-pos)
|
|
|
915 <-pos (car <-pos))
|
|
|
916
|
|
|
917 ;; Trim other punctuation lists of items outside < > pair to handle
|
|
|
918 ;; stupid MTAs.
|
|
|
919 (cond (<-pos ; don't need to check >-pos also
|
|
|
920 ;; handle bozo software that violates RFC 822 by sticking
|
|
|
921 ;; punctuation marks outside of a < > pair
|
|
|
922 (mail-extr-nuke-outside-range @-pos <-pos >-pos t)
|
|
|
923 ;; RFC 822 says nothing about these two outside < >, but
|
|
|
924 ;; remove those positions from the lists to make things
|
|
|
925 ;; easier.
|
|
|
926 (mail-extr-nuke-outside-range !-pos <-pos >-pos t)
|
|
|
927 (mail-extr-nuke-outside-range %-pos <-pos >-pos t)))
|
|
|
928
|
|
|
929 ;; Check for : that indicates GROUP list and for : part of
|
|
|
930 ;; ROUTE-ADDR spec.
|
|
|
931 ;; Can't possibly be more than two :. Nuke any extra.
|
|
|
932 (while colon-pos
|
|
|
933 (setq temp (car colon-pos)
|
|
|
934 colon-pos (cdr colon-pos))
|
|
|
935 (cond ((and <-pos >-pos
|
|
|
936 (> temp <-pos)
|
|
|
937 (< temp >-pos))
|
|
|
938 (if (or route-addr-colon-pos
|
|
|
939 (< (length @-pos) 2)
|
|
|
940 (> temp (car @-pos))
|
|
|
941 (< temp (nth 1 @-pos)))
|
|
|
942 (mail-extr-nuke-char-at temp)
|
|
|
943 (setq route-addr-colon-pos temp)))
|
|
|
944 ((or (not <-pos)
|
|
|
945 (and <-pos
|
|
|
946 (< temp <-pos)))
|
|
|
947 (setq group-colon-pos temp))))
|
|
|
948
|
|
|
949 ;; Nuke any ; that is in or to the left of a < > pair or to the left
|
|
|
950 ;; of a GROUP starting :. Also, there may only be one ;.
|
|
|
951 (while \;-pos
|
|
|
952 (setq temp (car \;-pos)
|
|
|
953 \;-pos (cdr \;-pos))
|
|
|
954 (cond ((and <-pos >-pos
|
|
|
955 (> temp <-pos)
|
|
|
956 (< temp >-pos))
|
|
|
957 (mail-extr-nuke-char-at temp))
|
|
|
958 ((and (or (not group-colon-pos)
|
|
|
959 (> temp group-colon-pos))
|
|
|
960 (not group-\;-pos))
|
|
|
961 (setq group-\;-pos temp))))
|
|
|
962
|
|
|
963 ;; Nuke unmatched GROUP syntax characters.
|
|
|
964 (cond ((and group-colon-pos (not group-\;-pos))
|
|
|
965 ;; *** Do I really need to erase it?
|
|
|
966 (mail-extr-nuke-char-at group-colon-pos)
|
|
|
967 (setq group-colon-pos nil)))
|
|
|
968 (cond ((and group-\;-pos (not group-colon-pos))
|
|
|
969 ;; *** Do I really need to erase it?
|
|
|
970 (mail-extr-nuke-char-at group-\;-pos)
|
|
|
971 (setq group-\;-pos nil)))
|
|
|
972
|
|
|
973 ;; Handle junk like ";@host.company.dom" that sendmail adds.
|
|
|
974 ;; **** should I remember comment positions?
|
|
|
975 (cond
|
|
|
976 (group-\;-pos
|
|
|
977 ;; this is fine for now
|
|
|
978 (mail-extr-nuke-outside-range !-pos group-colon-pos group-\;-pos t)
|
|
|
979 (mail-extr-nuke-outside-range @-pos group-colon-pos group-\;-pos t)
|
|
|
980 (mail-extr-nuke-outside-range %-pos group-colon-pos group-\;-pos t)
|
|
|
981 (mail-extr-nuke-outside-range comma-pos group-colon-pos group-\;-pos t)
|
|
|
982 (and last-real-pos
|
|
|
983 (> last-real-pos (1+ group-\;-pos))
|
|
|
984 (setq last-real-pos (1+ group-\;-pos)))
|
|
|
985 ;; *** This may be wrong:
|
|
|
986 (and cend
|
|
|
987 (> cend group-\;-pos)
|
|
|
988 (setq cend nil
|
|
|
989 cbeg nil))
|
|
|
990 (and quote-end
|
|
|
991 (> quote-end group-\;-pos)
|
|
|
992 (setq quote-end nil
|
|
|
993 quote-beg nil))
|
|
|
994 ;; This was both wrong and unnecessary:
|
|
|
995 ;;(narrow-to-region (point-min) group-\;-pos)
|
|
|
996
|
|
|
997 ;; *** The entire handling of GROUP addresses seems rather lame.
|
|
|
998 ;; *** It deserves a complete rethink, except that these addresses
|
|
|
999 ;; *** are hardly ever seen.
|
|
|
1000 ))
|
|
|
1001
|
|
|
1002 ;; Any commas must be between < and : of ROUTE-ADDR. Nuke any
|
|
|
1003 ;; others.
|
|
|
1004 ;; Hell, go ahead an nuke all of the commas.
|
|
|
1005 ;; **** This will cause problems when we start handling commas in
|
|
|
1006 ;; the PHRASE part .... no it won't ... yes it will ... ?????
|
|
|
1007 (mail-extr-nuke-outside-range comma-pos 1 1)
|
|
|
1008
|
|
|
1009 ;; can only have multiple @s inside < >. The fact that some MTAs
|
|
|
1010 ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is
|
|
|
1011 ;; handled above.
|
|
|
1012
|
|
|
1013 ;; Locate PHRASE part of ROUTE-ADDR.
|
|
|
1014 (cond (<-pos
|
|
|
1015 (goto-char <-pos)
|
|
|
1016 (mail-extr-skip-whitespace-backward)
|
|
|
1017 (setq phrase-end (point))
|
|
|
1018 (goto-char (or ;;group-colon-pos
|
|
|
1019 (point-min)))
|
|
|
1020 (mail-extr-skip-whitespace-forward)
|
|
|
1021 (if (< (point) phrase-end)
|
|
|
1022 (setq phrase-beg (point))
|
|
|
1023 (setq phrase-end nil))))
|
|
|
1024
|
|
|
1025 ;; handle ROUTE-ADDRS with real ROUTEs.
|
|
|
1026 ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and
|
|
|
1027 ;; any % or ! must be semantically meaningless.
|
|
|
1028 ;; TODO: do this processing into canonicalization buffer
|
|
|
1029 (cond (route-addr-colon-pos
|
|
|
1030 (setq !-pos nil
|
|
|
1031 %-pos nil
|
|
|
1032 >-pos (copy-marker >-pos)
|
|
|
1033 route-addr-colon-pos (copy-marker route-addr-colon-pos))
|
|
|
1034 (goto-char >-pos)
|
|
|
1035 (insert-before-markers ?X)
|
|
|
1036 (goto-char (car @-pos))
|
|
|
1037 (while (setq @-pos (cdr @-pos))
|
|
|
1038 (mail-extr-delete-char 1)
|
|
|
1039 (setq %-pos (cons (point-marker) %-pos))
|
|
|
1040 (insert "%")
|
|
|
1041 (goto-char (1- >-pos))
|
|
|
1042 (save-excursion
|
|
|
1043 (insert-buffer-substring extraction-buffer
|
|
|
1044 (car @-pos) route-addr-colon-pos)
|
|
|
1045 (delete-region (car @-pos) route-addr-colon-pos))
|
|
|
1046 (or (cdr @-pos)
|
|
|
1047 (setq saved-@-pos (list (point)))))
|
|
|
1048 (setq @-pos saved-@-pos)
|
|
|
1049 (goto-char >-pos)
|
|
|
1050 (mail-extr-delete-char -1)
|
|
|
1051 (mail-extr-nuke-char-at route-addr-colon-pos)
|
|
|
1052 (mail-extr-demarkerize route-addr-colon-pos)
|
|
|
1053 (setq route-addr-colon-pos nil
|
|
|
1054 >-pos (mail-extr-demarkerize >-pos)
|
|
|
1055 %-pos (mapcar 'mail-extr-demarkerize %-pos))))
|
|
|
1056
|
|
|
1057 ;; de-listify @-pos
|
|
|
1058 (setq @-pos (car @-pos))
|
|
|
1059
|
|
|
1060 ;; TODO: remove comments in the middle of an address
|
|
|
1061
|
|
|
1062 (set-buffer canonicalization-buffer)
|
|
|
1063 (fundamental-mode)
|
|
|
1064 (kill-all-local-variables)
|
|
|
1065 (buffer-disable-undo canonicalization-buffer)
|
|
|
1066 (set-syntax-table mail-extr-address-syntax-table)
|
|
|
1067 (setq case-fold-search nil)
|
|
|
1068
|
|
|
1069 (widen)
|
|
|
1070 (erase-buffer)
|
|
|
1071 (insert-buffer-substring extraction-buffer)
|
|
|
1072
|
|
|
1073 (if <-pos
|
|
|
1074 (narrow-to-region (progn
|
|
|
1075 (goto-char (1+ <-pos))
|
|
|
1076 (mail-extr-skip-whitespace-forward)
|
|
|
1077 (point))
|
|
|
1078 >-pos)
|
|
|
1079 (if (and first-real-pos last-real-pos)
|
|
|
1080 (narrow-to-region first-real-pos last-real-pos)
|
|
|
1081 ;; ****** Oh no! What if the address is completely empty!
|
|
|
1082 ;; *** Is this correct?
|
|
|
1083 (narrow-to-region (point-max) (point-max))
|
|
|
1084 ))
|
|
|
1085
|
|
|
1086 (and @-pos %-pos
|
|
|
1087 (mail-extr-nuke-outside-range %-pos (point-min) @-pos))
|
|
|
1088 (and %-pos !-pos
|
|
|
1089 (mail-extr-nuke-outside-range !-pos (point-min) (car %-pos)))
|
|
|
1090 (and @-pos !-pos (not %-pos)
|
|
|
1091 (mail-extr-nuke-outside-range !-pos (point-min) @-pos))
|
|
|
1092
|
|
|
1093 ;; Error condition:?? (and %-pos (not @-pos))
|
|
|
1094
|
|
|
1095 ;; WARNING: THIS CODE IS DUPLICATED BELOW.
|
|
|
1096 (cond ((and %-pos
|
|
|
1097 (not @-pos))
|
|
|
1098 (goto-char (car %-pos))
|
|
|
1099 (mail-extr-delete-char 1)
|
|
|
1100 (setq @-pos (point))
|
|
|
1101 (insert "@")
|
|
|
1102 (setq %-pos (cdr %-pos))))
|
|
|
1103
|
|
|
1104 (if mail-extr-mangle-uucp
|
|
|
1105 (cond (!-pos
|
|
|
1106 ;; **** I don't understand this save-restriction and the
|
|
|
1107 ;; narrow-to-region inside it. Why did I do that?
|
|
|
1108 (save-restriction
|
|
|
1109 (cond ((and @-pos
|
|
|
1110 mail-extr-@-binds-tighter-than-!)
|
|
|
1111 (goto-char @-pos)
|
|
|
1112 (setq %-pos (cons (point) %-pos)
|
|
|
1113 @-pos nil)
|
|
|
1114 (mail-extr-delete-char 1)
|
|
|
1115 (insert "%")
|
|
|
1116 (setq insert-point (point-max)))
|
|
|
1117 (mail-extr-@-binds-tighter-than-!
|
|
|
1118 (setq insert-point (point-max)))
|
|
|
1119 (%-pos
|
|
|
1120 (setq insert-point (mail-extr-last %-pos)
|
|
|
1121 saved-%-pos (mapcar 'mail-extr-markerize %-pos)
|
|
|
1122 %-pos nil
|
|
|
1123 @-pos (mail-extr-markerize @-pos)))
|
|
|
1124 (@-pos
|
|
|
1125 (setq insert-point @-pos)
|
|
|
1126 (setq @-pos (mail-extr-markerize @-pos)))
|
|
|
1127 (t
|
|
|
1128 (setq insert-point (point-max))))
|
|
|
1129 (narrow-to-region (point-min) insert-point)
|
|
|
1130 (setq saved-!-pos (car !-pos))
|
|
|
1131 (while !-pos
|
|
|
1132 (goto-char (point-max))
|
|
|
1133 (cond ((and (not @-pos)
|
|
|
1134 (not (cdr !-pos)))
|
|
|
1135 (setq @-pos (point))
|
|
|
1136 (insert-before-markers "@ "))
|
|
|
1137 (t
|
|
|
1138 (setq %-pos (cons (point) %-pos))
|
|
|
1139 (insert-before-markers "% ")))
|
|
|
1140 (backward-char 1)
|
|
|
1141 (insert-buffer-substring
|
|
|
1142 (current-buffer)
|
|
|
1143 (if (nth 1 !-pos)
|
|
|
1144 (1+ (nth 1 !-pos))
|
|
|
1145 (point-min))
|
|
|
1146 (car !-pos))
|
|
|
1147 (mail-extr-delete-char 1)
|
|
|
1148 (or (save-excursion
|
|
|
1149 (mail-extr-safe-move-sexp -1)
|
|
|
1150 (mail-extr-skip-whitespace-backward)
|
|
|
1151 (eq ?. (preceding-char)))
|
|
|
1152 (insert-before-markers
|
|
|
1153 (if (save-excursion
|
|
|
1154 (mail-extr-skip-whitespace-backward)
|
|
|
1155 (eq ?. (preceding-char)))
|
|
|
1156 ""
|
|
|
1157 ".")
|
|
|
1158 "uucp"))
|
|
|
1159 (setq !-pos (cdr !-pos))))
|
|
|
1160 (and saved-%-pos
|
|
|
1161 (setq %-pos (append (mapcar 'mail-extr-demarkerize
|
|
|
1162 saved-%-pos)
|
|
|
1163 %-pos)))
|
|
|
1164 (setq @-pos (mail-extr-demarkerize @-pos))
|
|
|
1165 (narrow-to-region (1+ saved-!-pos) (point-max)))))
|
|
|
1166
|
|
|
1167 ;; WARNING: THIS CODE IS DUPLICATED ABOVE.
|
|
|
1168 (cond ((and %-pos
|
|
|
1169 (not @-pos))
|
|
|
1170 (goto-char (car %-pos))
|
|
|
1171 (mail-extr-delete-char 1)
|
|
|
1172 (setq @-pos (point))
|
|
|
1173 (insert "@")
|
|
|
1174 (setq %-pos (cdr %-pos))))
|
|
|
1175
|
|
|
1176 (setq %-pos (nreverse %-pos))
|
|
|
1177 ;; RFC 1034 doesn't approve of this, oh well:
|
|
6
|
1178 ;; Neither do we, sb/lmi
|
|
|
1179 ;; (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
|
|
0
|
1180 (cond (%-pos ; implies @-pos valid
|
|
|
1181 (setq temp %-pos)
|
|
|
1182 (catch 'truncated
|
|
|
1183 (while temp
|
|
|
1184 (goto-char (or (nth 1 temp)
|
|
|
1185 @-pos))
|
|
|
1186 (mail-extr-skip-whitespace-backward)
|
|
|
1187 (save-excursion
|
|
|
1188 (mail-extr-safe-move-sexp -1)
|
|
|
1189 (setq domain-pos (point))
|
|
|
1190 (mail-extr-skip-whitespace-backward)
|
|
|
1191 (setq \.-pos (eq ?. (preceding-char))))
|
|
|
1192 (cond ((and \.-pos
|
|
|
1193 ;; #### string consing
|
|
|
1194 (let ((s (intern-soft
|
|
|
1195 (buffer-substring domain-pos (point))
|
|
|
1196 all-top-level-domains)))
|
|
|
1197 (and s (get s 'domain-name))))
|
|
|
1198 (narrow-to-region (point-min) (point))
|
|
|
1199 (goto-char (car temp))
|
|
|
1200 (mail-extr-delete-char 1)
|
|
|
1201 (setq @-pos (point))
|
|
|
1202 (setcdr temp nil)
|
|
|
1203 (setq %-pos (delq @-pos %-pos))
|
|
|
1204 (insert "@")
|
|
|
1205 (throw 'truncated t)))
|
|
|
1206 (setq temp (cdr temp))))))
|
|
|
1207 (setq mbox-beg (point-min)
|
|
|
1208 mbox-end (if %-pos (car %-pos)
|
|
|
1209 (or @-pos
|
|
|
1210 (point-max))))
|
|
|
1211
|
|
|
1212 ;; Done canonicalizing address.
|
|
|
1213
|
|
|
1214 (set-buffer extraction-buffer)
|
|
|
1215
|
|
|
1216 ;; Decide what part of the address to search to find the full name.
|
|
|
1217 (cond (
|
|
|
1218 ;; Example: "First M. Last" <fml@foo.bar.dom>
|
|
|
1219 (and phrase-beg
|
|
|
1220 (eq quote-beg phrase-beg)
|
|
|
1221 (<= quote-end phrase-end))
|
|
|
1222 (narrow-to-region (1+ quote-beg) (1- quote-end))
|
|
|
1223 (mail-extr-undo-backslash-quoting (point-min) (point-max)))
|
|
|
1224
|
|
|
1225 ;; Example: First Last <fml@foo.bar.dom>
|
|
|
1226 (phrase-beg
|
|
|
1227 (narrow-to-region phrase-beg phrase-end))
|
|
|
1228
|
|
|
1229 ;; Example: fml@foo.bar.dom (First M. Last)
|
|
|
1230 (cbeg
|
|
|
1231 (narrow-to-region (1+ cbeg) (1- cend))
|
|
|
1232 (mail-extr-undo-backslash-quoting (point-min) (point-max))
|
|
|
1233
|
|
|
1234 ;; Deal with spacing problems
|
|
|
1235 (goto-char (point-min))
|
|
|
1236 ; (cond ((not (search-forward " " nil t))
|
|
|
1237 ; (goto-char (point-min))
|
|
|
1238 ; (cond ((search-forward "_" nil t)
|
|
|
1239 ; ;; Handle the *idiotic* use of underlines as spaces.
|
|
|
1240 ; ;; Example: fml@foo.bar.dom (First_M._Last)
|
|
|
1241 ; (goto-char (point-min))
|
|
|
1242 ; (while (search-forward "_" nil t)
|
|
|
1243 ; (replace-match " " t)))
|
|
|
1244 ; ((search-forward "." nil t)
|
|
|
1245 ; ;; Fix . used as space
|
|
|
1246 ; ;; Example: danj1@cb.att.com (daniel.jacobson)
|
|
|
1247 ; (goto-char (point-min))
|
|
|
1248 ; (while (re-search-forward mail-extr-bad-dot-pattern nil t)
|
|
|
1249 ; (replace-match "\\1 \\2" t))))))
|
|
|
1250 )
|
|
|
1251
|
|
|
1252 ;; Otherwise we try to get the name from the mailbox portion
|
|
|
1253 ;; of the address.
|
|
|
1254 ;; Example: First_M_Last@foo.bar.dom
|
|
|
1255 (t
|
|
|
1256 ;; *** Work in canon buffer instead? No, can't. Hmm.
|
|
|
1257 (goto-char (point-max))
|
|
|
1258 (narrow-to-region (point) (point))
|
|
|
1259 (insert-buffer-substring canonicalization-buffer
|
|
|
1260 mbox-beg mbox-end)
|
|
|
1261 (goto-char (point-min))
|
|
|
1262
|
|
|
1263 ;; Example: First_Last.XXX@foo.bar.dom
|
|
|
1264 (setq \.-ends-name (re-search-forward "[_0-9]" nil t))
|
|
|
1265
|
|
|
1266 (goto-char (point-min))
|
|
|
1267
|
|
|
1268 (if (not mail-extr-mangle-uucp)
|
|
|
1269 (modify-syntax-entry ?! "w" (syntax-table)))
|
|
|
1270
|
|
|
1271 (while (progn
|
|
|
1272 (mail-extr-skip-whitespace-forward)
|
|
|
1273 (not (eobp)))
|
|
|
1274 (setq char (char-after (point)))
|
|
|
1275 (cond
|
|
|
1276 ((eq char ?\")
|
|
|
1277 (setq quote-beg (point))
|
|
|
1278 (or (mail-extr-safe-move-sexp 1)
|
|
|
1279 ;; TODO: handle this error condition!!!!!
|
|
|
1280 (forward-char 1))
|
|
|
1281 ;; take into account deletions
|
|
|
1282 (setq quote-end (- (point) 2))
|
|
|
1283 (save-excursion
|
|
|
1284 (backward-char 1)
|
|
|
1285 (mail-extr-delete-char 1)
|
|
|
1286 (goto-char quote-beg)
|
|
|
1287 (mail-extr-delete-char 1))
|
|
|
1288 (mail-extr-undo-backslash-quoting quote-beg quote-end)
|
|
|
1289 (or (eq ?\ (char-after (point)))
|
|
|
1290 (insert " "))
|
|
|
1291 ;; (setq mailbox-name-processed-flag t)
|
|
|
1292 (setq \.-ends-name t))
|
|
|
1293 ((eq char ?.)
|
|
|
1294 (if (memq (char-after (1+ (point))) '(?_ ?=))
|
|
|
1295 (progn
|
|
|
1296 (forward-char 1)
|
|
|
1297 (mail-extr-delete-char 1)
|
|
|
1298 (insert ?\ ))
|
|
|
1299 (if \.-ends-name
|
|
|
1300 (narrow-to-region (point-min) (point))
|
|
|
1301 (mail-extr-delete-char 1)
|
|
|
1302 (insert " ")))
|
|
|
1303 ;; (setq mailbox-name-processed-flag t)
|
|
|
1304 )
|
|
|
1305 ((memq (char-syntax char) '(?. ?\\))
|
|
|
1306 (mail-extr-delete-char 1)
|
|
|
1307 (insert " ")
|
|
|
1308 ;; (setq mailbox-name-processed-flag t)
|
|
|
1309 )
|
|
|
1310 (t
|
|
|
1311 (setq atom-beg (point))
|
|
|
1312 (forward-word 1)
|
|
|
1313 (setq atom-end (point))
|
|
|
1314 (goto-char atom-beg)
|
|
|
1315 (save-restriction
|
|
|
1316 (narrow-to-region atom-beg atom-end)
|
|
|
1317 (cond
|
|
|
1318
|
|
|
1319 ;; Handle X.400 addresses encoded in RFC-822.
|
|
|
1320 ;; *** Shit! This has to handle the case where it is
|
|
|
1321 ;; *** embedded in a quote too!
|
|
|
1322 ;; *** Shit! The input is being broken up into atoms
|
|
|
1323 ;; *** by periods!
|
|
|
1324 ((looking-at mail-extr-x400-encoded-address-pattern)
|
|
|
1325
|
|
|
1326 ;; Copy the contents of the individual fields that
|
|
|
1327 ;; might hold name data to the beginning.
|
|
|
1328 (mapcar
|
|
|
1329 (function
|
|
|
1330 (lambda (field-pattern)
|
|
|
1331 (cond
|
|
|
1332 ((save-excursion
|
|
|
1333 (re-search-forward field-pattern nil t))
|
|
|
1334 (insert-buffer-substring (current-buffer)
|
|
|
1335 (match-beginning 1)
|
|
|
1336 (match-end 1))
|
|
|
1337 (insert " ")))))
|
|
|
1338 (list mail-extr-x400-encoded-address-given-name-pattern
|
|
|
1339 mail-extr-x400-encoded-address-surname-pattern
|
|
|
1340 mail-extr-x400-encoded-address-full-name-pattern))
|
|
|
1341
|
|
|
1342 ;; Discard the rest, since it contains stuff like
|
|
|
1343 ;; routing information, not part of a name.
|
|
|
1344 (mail-extr-skip-whitespace-backward)
|
|
|
1345 (delete-region (point) (point-max))
|
|
|
1346
|
|
|
1347 ;; Handle periods used for spacing.
|
|
|
1348 (while (re-search-forward mail-extr-bad-dot-pattern nil t)
|
|
|
1349 (replace-match "\\1 \\2" t))
|
|
|
1350
|
|
|
1351 ;; (setq mailbox-name-processed-flag t)
|
|
|
1352 )
|
|
|
1353
|
|
|
1354 ;; Handle normal addresses.
|
|
|
1355 (t
|
|
|
1356 (goto-char (point-min))
|
|
|
1357 ;; Handle _ and = used for spacing.
|
|
|
1358 (while (re-search-forward "\\([^_=]+\\)[_=]" nil t)
|
|
|
1359 (replace-match "\\1 " t)
|
|
|
1360 ;; (setq mailbox-name-processed-flag t)
|
|
|
1361 )
|
|
|
1362 (goto-char (point-max))))))))
|
|
|
1363
|
|
|
1364 ;; undo the dirty deed
|
|
|
1365 (if (not mail-extr-mangle-uucp)
|
|
|
1366 (modify-syntax-entry ?! "." (syntax-table)))
|
|
|
1367 ;;
|
|
|
1368 ;; If we derived the name from the mailbox part of the address,
|
|
|
1369 ;; and we only got one word out of it, don't treat that as a
|
|
|
1370 ;; name. "foo@bar" --> (nil "foo@bar"), not ("foo" "foo@bar")
|
|
|
1371 ;; (if (not mailbox-name-processed-flag)
|
|
|
1372 ;; (delete-region (point-min) (point-max)))
|
|
|
1373 ))
|
|
|
1374
|
|
|
1375 (set-syntax-table mail-extr-address-text-syntax-table)
|
|
|
1376
|
|
|
1377 (mail-extr-voodoo mbox-beg mbox-end canonicalization-buffer)
|
|
|
1378 (goto-char (point-min))
|
|
|
1379
|
|
|
1380 ;; If name is "First Last" and userid is "F?L", then assume
|
|
|
1381 ;; the middle initial is the second letter in the userid.
|
|
|
1382 ;; Initial code by Jamie Zawinski <jwz@netscape.com>
|
|
|
1383 ;; *** Make it work when there's a suffix as well.
|
|
|
1384 (goto-char (point-min))
|
|
|
1385 (cond ((and mail-extr-guess-middle-initial
|
|
|
1386 (not disable-initial-guessing-flag)
|
|
|
1387 (eq 3 (- mbox-end mbox-beg))
|
|
|
1388 (progn
|
|
|
1389 (goto-char (point-min))
|
|
|
1390 (looking-at mail-extr-two-name-pattern)))
|
|
|
1391 (setq fi (char-after (match-beginning 0))
|
|
|
1392 li (char-after (match-beginning 3)))
|
|
|
1393 (save-excursion
|
|
|
1394 (set-buffer canonicalization-buffer)
|
|
|
1395 ;; char-equal is ignoring case here, so no need to upcase
|
|
|
1396 ;; or downcase.
|
|
|
1397 (let ((case-fold-search t))
|
|
|
1398 (and (char-equal fi (char-after mbox-beg))
|
|
|
1399 (char-equal li (char-after (1- mbox-end)))
|
|
|
1400 (setq mi (char-after (1+ mbox-beg))))))
|
|
|
1401 (cond ((and mi
|
|
|
1402 ;; TODO: use better table than syntax table
|
|
|
1403 (eq ?w (char-syntax mi)))
|
|
|
1404 (goto-char (match-beginning 3))
|
|
|
1405 (insert (upcase mi) ". ")))))
|
|
|
1406
|
|
|
1407 ;; Nuke name if it is the same as mailbox name.
|
|
|
1408 (let ((buffer-length (- (point-max) (point-min)))
|
|
|
1409 (i 0)
|
|
|
1410 (names-match-flag t))
|
|
|
1411 (cond ((and (> buffer-length 0)
|
|
|
1412 (eq buffer-length (- mbox-end mbox-beg)))
|
|
|
1413 (goto-char (point-max))
|
|
|
1414 (insert-buffer-substring canonicalization-buffer
|
|
|
1415 mbox-beg mbox-end)
|
|
|
1416 (while (and names-match-flag
|
|
|
1417 (< i buffer-length))
|
|
38
|
1418 (or (eq (let ((c (char-after (+ i (point-min)))))
|
|
|
1419 (if mail-extr-mailbox-match-case-fold
|
|
|
1420 (downcase c)
|
|
|
1421 c))
|
|
0
|
1422 (downcase
|
|
|
1423 (char-after (+ i buffer-length (point-min)))))
|
|
|
1424 (setq names-match-flag nil))
|
|
|
1425 (setq i (1+ i)))
|
|
|
1426 (delete-region (+ (point-min) buffer-length) (point-max))
|
|
|
1427 (if names-match-flag
|
|
|
1428 (narrow-to-region (point) (point))))))
|
|
|
1429
|
|
|
1430 ;; Nuke name if it's just one word.
|
|
|
1431 (goto-char (point-min))
|
|
|
1432 (and mail-extr-ignore-single-names
|
|
|
1433 (not (re-search-forward "[- ]" nil t))
|
|
|
1434 (narrow-to-region (point) (point)))
|
|
|
1435
|
|
|
1436 ;; Result
|
|
|
1437 (list (if (not (= (point-min) (point-max)))
|
|
|
1438 (buffer-string))
|
|
|
1439 (progn
|
|
|
1440 (set-buffer canonicalization-buffer)
|
|
|
1441 (if (not (= (point-min) (point-max)))
|
|
|
1442 (buffer-string))))
|
|
|
1443 )))
|
|
|
1444
|
|
|
1445 (defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
|
|
|
1446 (let ((word-count 0)
|
|
|
1447 (case-fold-search nil)
|
|
|
1448 mixed-case-flag lower-case-flag ;;upper-case-flag
|
|
|
1449 suffix-flag last-name-comma-flag
|
|
|
1450 ;;cbeg cend
|
|
|
1451 initial
|
|
|
1452 begin-again-flag
|
|
|
1453 drop-this-word-if-trailing-flag
|
|
|
1454 drop-last-word-if-trailing-flag
|
|
|
1455 word-found-flag
|
|
|
1456 this-word-beg last-word-beg
|
|
|
1457 name-beg name-end
|
|
|
1458 name-done-flag
|
|
|
1459 )
|
|
|
1460 (save-excursion
|
|
|
1461 (set-syntax-table mail-extr-address-text-syntax-table)
|
|
|
1462
|
|
|
1463 ;; This was moved above.
|
|
|
1464 ;; Fix . used as space
|
|
|
1465 ;; But it belongs here because it occurs not only as
|
|
|
1466 ;; rypens@reks.uia.ac.be (Piet.Rypens)
|
|
|
1467 ;; but also as
|
|
|
1468 ;; "Piet.Rypens" <rypens@reks.uia.ac.be>
|
|
|
1469 ;;(goto-char (point-min))
|
|
|
1470 ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
|
|
|
1471 ;; (replace-match "\\1 \\2" t))
|
|
|
1472
|
|
|
1473 (cond ((not (search-forward " " nil t))
|
|
|
1474 (goto-char (point-min))
|
|
|
1475 (cond ((search-forward "_" nil t)
|
|
|
1476 ;; Handle the *idiotic* use of underlines as spaces.
|
|
|
1477 ;; Example: fml@foo.bar.dom (First_M._Last)
|
|
|
1478 (goto-char (point-min))
|
|
|
1479 (while (search-forward "_" nil t)
|
|
|
1480 (replace-match " " t)))
|
|
|
1481 ((search-forward "." nil t)
|
|
|
1482 ;; Fix . used as space
|
|
|
1483 ;; Example: danj1@cb.att.com (daniel.jacobson)
|
|
|
1484 (goto-char (point-min))
|
|
|
1485 (while (re-search-forward mail-extr-bad-dot-pattern nil t)
|
|
|
1486 (replace-match "\\1 \\2" t))))))
|
|
|
1487
|
|
|
1488
|
|
|
1489 ;; Loop over the words (and other junk) in the name.
|
|
|
1490 (goto-char (point-min))
|
|
|
1491 (while (not name-done-flag)
|
|
|
1492
|
|
|
1493 (cond (word-found-flag
|
|
|
1494 ;; Last time through this loop we skipped over a word.
|
|
|
1495 (setq last-word-beg this-word-beg)
|
|
|
1496 (setq drop-last-word-if-trailing-flag
|
|
|
1497 drop-this-word-if-trailing-flag)
|
|
|
1498 (setq word-found-flag nil)))
|
|
|
1499
|
|
|
1500 (cond (begin-again-flag
|
|
|
1501 ;; Last time through the loop we found something that
|
|
|
1502 ;; indicates we should pretend we are beginning again from
|
|
|
1503 ;; the start.
|
|
|
1504 (setq word-count 0)
|
|
|
1505 (setq last-word-beg nil)
|
|
|
1506 (setq drop-last-word-if-trailing-flag nil)
|
|
|
1507 (setq mixed-case-flag nil)
|
|
|
1508 (setq lower-case-flag nil)
|
|
|
1509 ;; (setq upper-case-flag nil)
|
|
|
1510 (setq begin-again-flag nil)
|
|
|
1511 ))
|
|
|
1512
|
|
|
1513 ;; Initialize for this iteration of the loop.
|
|
|
1514 (mail-extr-skip-whitespace-forward)
|
|
|
1515 (if (eq word-count 0) (narrow-to-region (point) (point-max)))
|
|
|
1516 (setq this-word-beg (point))
|
|
|
1517 (setq drop-this-word-if-trailing-flag nil)
|
|
|
1518
|
|
|
1519 ;; Decide what to do based on what we are looking at.
|
|
|
1520 (cond
|
|
|
1521
|
|
|
1522 ;; Delete title
|
|
|
1523 ((and (eq word-count 0)
|
|
|
1524 (looking-at mail-extr-full-name-prefixes))
|
|
|
1525 (goto-char (match-end 0))
|
|
|
1526 (narrow-to-region (point) (point-max)))
|
|
|
1527
|
|
|
1528 ;; Stop after name suffix
|
|
|
1529 ((and (>= word-count 2)
|
|
|
1530 (looking-at mail-extr-full-name-suffix-pattern))
|
|
|
1531 (mail-extr-skip-whitespace-backward)
|
|
|
1532 (setq suffix-flag (point))
|
|
|
1533 (if (eq ?, (following-char))
|
|
|
1534 (forward-char 1)
|
|
|
1535 (insert ?,))
|
|
|
1536 ;; Enforce at least one space after comma
|
|
|
1537 (or (eq ?\ (following-char))
|
|
|
1538 (insert ?\ ))
|
|
|
1539 (mail-extr-skip-whitespace-forward)
|
|
|
1540 (cond ((memq (following-char) '(?j ?J ?s ?S))
|
|
|
1541 (capitalize-word 1)
|
|
|
1542 (if (eq (following-char) ?.)
|
|
|
1543 (forward-char 1)
|
|
|
1544 (insert ?.)))
|
|
|
1545 (t
|
|
|
1546 (upcase-word 1)))
|
|
|
1547 (setq word-found-flag t)
|
|
|
1548 (setq name-done-flag t))
|
|
|
1549
|
|
|
1550 ;; Handle SCA names
|
|
|
1551 ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As"
|
|
|
1552 (goto-char (match-beginning 1))
|
|
|
1553 (narrow-to-region (point) (point-max))
|
|
|
1554 (setq begin-again-flag t))
|
|
|
1555
|
|
|
1556 ;; Check for initial last name followed by comma
|
|
|
1557 ((and (eq ?, (following-char))
|
|
|
1558 (eq word-count 1))
|
|
|
1559 (forward-char 1)
|
|
|
1560 (setq last-name-comma-flag t)
|
|
|
1561 (or (eq ?\ (following-char))
|
|
|
1562 (insert ?\ )))
|
|
|
1563
|
|
|
1564 ;; Stop before trailing comma-separated comment
|
|
|
1565 ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
|
|
|
1566 ;; *** This case is redundant???
|
|
|
1567 ;;((eq ?, (following-char))
|
|
|
1568 ;; (setq name-done-flag t))
|
|
|
1569
|
|
|
1570 ;; Delete parenthesized/quoted comment/nickname
|
|
|
1571 ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
|
|
|
1572 (setq cbeg (point))
|
|
|
1573 (set-syntax-table mail-extr-address-text-comment-syntax-table)
|
|
|
1574 (cond ((memq (following-char) '(?\' ?\`))
|
|
|
1575 (or (search-forward "'" nil t
|
|
|
1576 (if (eq ?\' (following-char)) 2 1))
|
|
|
1577 (mail-extr-delete-char 1)))
|
|
|
1578 (t
|
|
|
1579 (or (mail-extr-safe-move-sexp 1)
|
|
|
1580 (goto-char (point-max)))))
|
|
|
1581 (set-syntax-table mail-extr-address-text-syntax-table)
|
|
|
1582 (setq cend (point))
|
|
|
1583 (cond
|
|
|
1584 ;; Handle case of entire name being quoted
|
|
|
1585 ((and (eq word-count 0)
|
|
|
1586 (looking-at " *\\'")
|
|
|
1587 (>= (- cend cbeg) 2))
|
|
|
1588 (narrow-to-region (1+ cbeg) (1- cend))
|
|
|
1589 (goto-char (point-min)))
|
|
|
1590 (t
|
|
|
1591 ;; Handle case of quoted initial
|
|
|
1592 (if (and (or (= 3 (- cend cbeg))
|
|
|
1593 (and (= 4 (- cend cbeg))
|
|
|
1594 (eq ?. (char-after (+ 2 cbeg)))))
|
|
|
1595 (not (looking-at " *\\'")))
|
|
|
1596 (setq initial (char-after (1+ cbeg)))
|
|
|
1597 (setq initial nil))
|
|
|
1598 (delete-region cbeg cend)
|
|
|
1599 (if initial
|
|
|
1600 (insert initial ". ")))))
|
|
|
1601
|
|
|
1602 ;; Handle & substitution
|
|
|
1603 ((and (or (bobp)
|
|
|
1604 (eq ?\ (preceding-char)))
|
|
|
1605 (looking-at "&\\( \\|\\'\\)"))
|
|
|
1606 (mail-extr-delete-char 1)
|
|
|
1607 (capitalize-region
|
|
|
1608 (point)
|
|
|
1609 (progn
|
|
|
1610 (insert-buffer-substring canonicalization-buffer
|
|
|
1611 mbox-beg mbox-end)
|
|
|
1612 (point)))
|
|
|
1613 (setq disable-initial-guessing-flag t)
|
|
|
1614 (setq word-found-flag t))
|
|
|
1615
|
|
|
1616 ;; Handle *Stupid* VMS date stamps
|
|
|
1617 ((looking-at mail-extr-stupid-vms-date-stamp-pattern)
|
|
|
1618 (replace-match "" t))
|
|
|
1619
|
|
|
1620 ;; Handle Chinese characters.
|
|
|
1621 ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern)
|
|
|
1622 (goto-char (match-end 0))
|
|
|
1623 (setq word-found-flag t))
|
|
|
1624
|
|
|
1625 ;; Skip initial garbage characters.
|
|
|
1626 ;; THIS CASE MUST BE AFTER THE PRECEDING CASES.
|
|
|
1627 ((and (eq word-count 0)
|
|
|
1628 (looking-at mail-extr-leading-garbage))
|
|
|
1629 (goto-char (match-end 0))
|
|
|
1630 ;; *** Skip backward over these???
|
|
|
1631 ;; (skip-chars-backward "& \"")
|
|
|
1632 (narrow-to-region (point) (point-max)))
|
|
|
1633
|
|
|
1634 ;; Various stopping points
|
|
|
1635 ((or
|
|
|
1636
|
|
|
1637 ;; Stop before ALL CAPS acronyms, if preceded by mixed-case
|
|
|
1638 ;; words. Example: XT-DEM.
|
|
|
1639 (and (>= word-count 2)
|
|
|
1640 mixed-case-flag
|
|
|
1641 (looking-at mail-extr-weird-acronym-pattern)
|
|
|
1642 (not (looking-at mail-extr-roman-numeral-pattern)))
|
|
|
1643
|
|
|
1644 ;; Stop before trailing alternative address
|
|
|
1645 (looking-at mail-extr-alternative-address-pattern)
|
|
|
1646
|
|
|
1647 ;; Stop before trailing comment not introduced by comma
|
|
|
1648 ;; THIS CASE MUST BE AFTER AN EARLIER CASE.
|
|
|
1649 (looking-at mail-extr-trailing-comment-start-pattern)
|
|
|
1650
|
|
|
1651 ;; Stop before telephone numbers
|
|
|
1652 (looking-at mail-extr-telephone-extension-pattern))
|
|
|
1653 (setq name-done-flag t))
|
|
|
1654
|
|
|
1655 ;; Delete ham radio call signs
|
|
|
1656 ((looking-at mail-extr-ham-call-sign-pattern)
|
|
|
1657 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
1658
|
|
|
1659 ;; Fixup initials
|
|
|
1660 ((looking-at mail-extr-initial-pattern)
|
|
|
1661 (or (eq (following-char) (upcase (following-char)))
|
|
|
1662 (setq lower-case-flag t))
|
|
|
1663 (forward-char 1)
|
|
|
1664 (if (eq ?. (following-char))
|
|
|
1665 (forward-char 1)
|
|
|
1666 (insert ?.))
|
|
|
1667 (or (eq ?\ (following-char))
|
|
|
1668 (insert ?\ ))
|
|
|
1669 (setq word-found-flag t))
|
|
|
1670
|
|
|
1671 ;; Handle BITNET LISTSERV list names.
|
|
|
1672 ((and (eq word-count 0)
|
|
|
1673 (looking-at mail-extr-listserv-list-name-pattern))
|
|
|
1674 (narrow-to-region (match-beginning 1) (match-end 1))
|
|
|
1675 (setq word-found-flag t)
|
|
|
1676 (setq name-done-flag t))
|
|
|
1677
|
|
|
1678 ;; Regular name words
|
|
|
1679 ((looking-at mail-extr-name-pattern)
|
|
|
1680 (setq name-beg (point))
|
|
|
1681 (setq name-end (match-end 0))
|
|
|
1682
|
|
|
1683 ;; Certain words will be dropped if they are at the end.
|
|
|
1684 (and (>= word-count 2)
|
|
|
1685 (not lower-case-flag)
|
|
|
1686 (or
|
|
|
1687 ;; A trailing 4-or-more letter lowercase words preceded by
|
|
|
1688 ;; mixed case or uppercase words will be dropped.
|
|
|
1689 (looking-at "[a-z][a-z][a-z][a-z]+[ \t]*\\'")
|
|
|
1690 ;; Drop a trailing word which is terminated with a period.
|
|
|
1691 (eq ?. (char-after (1- name-end))))
|
|
|
1692 (setq drop-this-word-if-trailing-flag t))
|
|
|
1693
|
|
|
1694 ;; Set the flags that indicate whether we have seen a lowercase
|
|
|
1695 ;; word, a mixed case word, and an uppercase word.
|
|
|
1696 (if (re-search-forward "[a-z]" name-end t)
|
|
|
1697 (if (progn
|
|
|
1698 (goto-char name-beg)
|
|
|
1699 (re-search-forward "[A-Z]" name-end t))
|
|
|
1700 (setq mixed-case-flag t)
|
|
|
1701 (setq lower-case-flag t))
|
|
|
1702 ;; (setq upper-case-flag t)
|
|
|
1703 )
|
|
|
1704
|
|
|
1705 (goto-char name-end)
|
|
|
1706 (setq word-found-flag t))
|
|
|
1707
|
|
|
1708 (t
|
|
|
1709 (setq name-done-flag t)
|
|
|
1710 ))
|
|
|
1711
|
|
|
1712 ;; Count any word that we skipped over.
|
|
|
1713 (if word-found-flag
|
|
|
1714 (setq word-count (1+ word-count))))
|
|
|
1715
|
|
|
1716 ;; If the last thing in the name is 2 or more periods, or one or more
|
|
|
1717 ;; other sentence terminators (but not a single period) then keep them
|
|
30
|
1718 ;; and the preceding word. This is for the benefit of whole sentences
|
|
0
|
1719 ;; in the name field: it's better behavior than dropping the last word
|
|
|
1720 ;; of the sentence...
|
|
|
1721 (if (and (not suffix-flag)
|
|
|
1722 (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'"))
|
|
|
1723 (goto-char (setq suffix-flag (point-max))))
|
|
|
1724
|
|
|
1725 ;; Drop everything after point and certain trailing words.
|
|
|
1726 (narrow-to-region (point-min)
|
|
|
1727 (or (and drop-last-word-if-trailing-flag
|
|
|
1728 last-word-beg)
|
|
|
1729 (point)))
|
|
|
1730
|
|
|
1731 ;; Xerox's mailers SUCK!!!!!!
|
|
|
1732 ;; We simply refuse to believe that any last name is PARC or ADOC.
|
|
|
1733 ;; If it looks like that is the last name, that there is no meaningful
|
|
|
1734 ;; here at all. Actually I guess it would be best to map patterns
|
|
|
1735 ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't
|
|
|
1736 ;; actually know that that is what's going on.
|
|
|
1737 (cond ((not suffix-flag)
|
|
|
1738 (goto-char (point-min))
|
|
|
1739 (let ((case-fold-search t))
|
|
|
1740 (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
|
|
|
1741 (erase-buffer)))))
|
|
|
1742
|
|
|
1743 ;; If last name first put it at end (but before suffix)
|
|
|
1744 (cond (last-name-comma-flag
|
|
|
1745 (goto-char (point-min))
|
|
|
1746 (search-forward ",")
|
|
|
1747 (setq name-end (1- (point)))
|
|
|
1748 (goto-char (or suffix-flag (point-max)))
|
|
|
1749 (or (eq ?\ (preceding-char))
|
|
|
1750 (insert ?\ ))
|
|
|
1751 (insert-buffer-substring (current-buffer) (point-min) name-end)
|
|
|
1752 (goto-char name-end)
|
|
|
1753 (skip-chars-forward "\t ,")
|
|
|
1754 (narrow-to-region (point) (point-max))))
|
|
|
1755
|
|
|
1756 ;; Delete leading and trailing junk characters.
|
|
|
1757 ;; *** This is probably completly unneeded now.
|
|
|
1758 ;;(goto-char (point-max))
|
|
|
1759 ;;(skip-chars-backward mail-extr-non-end-name-chars)
|
|
|
1760 ;;(if (eq ?. (following-char))
|
|
|
1761 ;; (forward-char 1))
|
|
|
1762 ;;(narrow-to-region (point)
|
|
|
1763 ;; (progn
|
|
|
1764 ;; (goto-char (point-min))
|
|
|
1765 ;; (skip-chars-forward mail-extr-non-begin-name-chars)
|
|
|
1766 ;; (point)))
|
|
|
1767
|
|
|
1768 ;; Compress whitespace
|
|
|
1769 (goto-char (point-min))
|
|
|
1770 (while (re-search-forward "[ \t\n]+" nil t)
|
|
|
1771 (replace-match (if (eobp) "" " ") t))
|
|
|
1772 )))
|
|
|
1773
|
|
|
1774
|
|
|
1775
|
|
|
1776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1777 ;;
|
|
|
1778 ;; Table of top-level domain names.
|
|
|
1779 ;;
|
|
|
1780 ;; This is used during address canonicalization; be careful of format changes.
|
|
|
1781 ;; Keep in mind that the country abbreviations follow ISO-3166. There is
|
|
|
1782 ;; a U.S. FIPS that specifies a different set of two-letter country
|
|
|
1783 ;; abbreviations.
|
|
|
1784
|
|
|
1785 (defconst all-top-level-domains
|
|
|
1786 (let ((ob (make-vector 509 0)))
|
|
|
1787 (mapcar
|
|
|
1788 (function
|
|
|
1789 (lambda (x)
|
|
|
1790 (put (intern (downcase (car x)) ob)
|
|
|
1791 'domain-name
|
|
|
1792 (if (nth 2 x)
|
|
|
1793 (format (nth 2 x) (nth 1 x))
|
|
|
1794 (nth 1 x)))))
|
|
|
1795 '(("ag" "Antigua")
|
|
|
1796 ("ar" "Argentina" "Argentine Republic")
|
|
|
1797 ("arpa" t "Advanced Projects Research Agency")
|
|
|
1798 ("at" "Austria" "The Republic of %s")
|
|
|
1799 ("au" "Australia")
|
|
|
1800 ("bb" "Barbados")
|
|
|
1801 ("be" "Belgium" "The Kingdom of %s")
|
|
|
1802 ("bg" "Bulgaria")
|
|
|
1803 ("bitnet" t "Because It's Time NET")
|
|
|
1804 ("bo" "Bolivia" "Republic of %s")
|
|
|
1805 ("br" "Brazil" "The Federative Republic of %s")
|
|
|
1806 ("bs" "Bahamas")
|
|
|
1807 ("bz" "Belize")
|
|
|
1808 ("ca" "Canada")
|
|
|
1809 ("ch" "Switzerland" "The Swiss Confederation")
|
|
|
1810 ("cl" "Chile" "The Republic of %s")
|
|
|
1811 ("cn" "China" "The People's Republic of %s")
|
|
|
1812 ("co" "Columbia")
|
|
|
1813 ("com" t "Commercial")
|
|
|
1814 ("cr" "Costa Rica" "The Republic of %s")
|
|
|
1815 ("cs" "Czechoslovakia")
|
|
|
1816 ("de" "Germany")
|
|
|
1817 ("dk" "Denmark")
|
|
|
1818 ("dm" "Dominica")
|
|
|
1819 ("do" "Dominican Republic" "The %s")
|
|
|
1820 ("ec" "Ecuador" "The Republic of %s")
|
|
|
1821 ("edu" t "Educational")
|
|
|
1822 ("eg" "Egypt" "The Arab Republic of %s")
|
|
|
1823 ("es" "Spain" "The Kingdom of %s")
|
|
|
1824 ("fi" "Finland" "The Republic of %s")
|
|
|
1825 ("fj" "Fiji")
|
|
|
1826 ("fr" "France")
|
|
|
1827 ("gov" t "Government (U.S.A.)")
|
|
|
1828 ("gr" "Greece" "The Hellenic Republic (%s)")
|
|
|
1829 ("hk" "Hong Kong")
|
|
28
|
1830 ("hr" "Croatia" "The Republic of %s")
|
|
0
|
1831 ("hu" "Hungary" "The Hungarian People's Republic") ;???
|
|
|
1832 ("ie" "Ireland")
|
|
|
1833 ("il" "Israel" "The State of %s")
|
|
|
1834 ("in" "India" "The Republic of %s")
|
|
|
1835 ("int" t "(something British, don't know what)")
|
|
|
1836 ("is" "Iceland" "The Republic of %s")
|
|
|
1837 ("it" "Italy" "The Italian Republic")
|
|
|
1838 ("jm" "Jamaica")
|
|
|
1839 ("jp" "Japan")
|
|
|
1840 ("kn" "St. Kitts and Nevis")
|
|
|
1841 ("kr" "South Korea")
|
|
|
1842 ("lc" "St. Lucia")
|
|
|
1843 ("lk" "Sri Lanka" "The Democratic Socialist Republic of %s")
|
|
|
1844 ("mil" t "Military (U.S.A.)")
|
|
|
1845 ("mx" "Mexico" "The United Mexican States")
|
|
|
1846 ("my" "Malaysia" "%s (changed to Myanmar?)") ;???
|
|
|
1847 ("na" "Namibia")
|
|
|
1848 ("nato" t "North Atlantic Treaty Organization")
|
|
|
1849 ("net" t "Network")
|
|
|
1850 ("ni" "Nicaragua" "The Republic of %s")
|
|
|
1851 ("nl" "Netherlands" "The Kingdom of the %s")
|
|
|
1852 ("no" "Norway" "The Kingdom of %s")
|
|
|
1853 ("nz" "New Zealand")
|
|
|
1854 ("org" t "Organization")
|
|
|
1855 ("pe" "Peru")
|
|
|
1856 ("pg" "Papua New Guinea")
|
|
|
1857 ("ph" "Philippines" "The Republic of the %s")
|
|
|
1858 ("pl" "Poland")
|
|
|
1859 ("pr" "Puerto Rico")
|
|
|
1860 ("pt" "Portugal" "The Portugese Republic")
|
|
|
1861 ("py" "Paraguay")
|
|
|
1862 ("se" "Sweden" "The Kingdom of %s")
|
|
|
1863 ("sg" "Singapore" "The Republic of %s")
|
|
|
1864 ("sr" "Suriname")
|
|
|
1865 ("su" "Soviet Union")
|
|
|
1866 ("th" "Thailand" "The Kingdom of %s")
|
|
|
1867 ("tn" "Tunisia")
|
|
|
1868 ("tr" "Turkey" "The Republic of %s")
|
|
|
1869 ("tt" "Trinidad and Tobago")
|
|
|
1870 ("tw" "Taiwan")
|
|
|
1871 ("uk" "United Kingdom" "The %s of Great Britain")
|
|
|
1872 ("unter-dom" t "(something German)")
|
|
|
1873 ("us" "U.S.A." "The United States of America")
|
|
|
1874 ("uucp" t "Unix to Unix CoPy")
|
|
|
1875 ("uy" "Uruguay" "The Eastern Republic of %s")
|
|
|
1876 ("vc" "St. Vincent and the Grenadines")
|
|
|
1877 ("ve" "Venezuela" "The Republic of %s")
|
|
|
1878 ("yu" "Yugoslavia" "The Socialist Federal Republic of %s")
|
|
|
1879 ;; Also said to be Zambia ... (why not Zaire???)
|
|
|
1880 ("za" "South Africa" "The Republic of %s (or Zambia? Zaire?)")
|
|
|
1881 ("zw" "Zimbabwe" "Republic of %s")
|
|
|
1882 ;; fipnet
|
|
|
1883 ))
|
|
|
1884 ob))
|
|
|
1885
|
|
|
1886 ;;;###autoload
|
|
|
1887 (defun what-domain (x)
|
|
|
1888 "Prompts for a mail domain, and prints the country it corresponds to
|
|
|
1889 in the minibuffer."
|
|
|
1890 (interactive
|
|
|
1891 (let ((completion-ignore-case t))
|
|
|
1892 (list (completing-read "Domain: " all-top-level-domains nil t))))
|
|
|
1893 (or (setq x (intern-soft (downcase x) all-top-level-domains))
|
|
|
1894 (error "no such domain"))
|
|
|
1895 (message "%s: %s" (upcase (symbol-name x)) (get x 'domain-name)))
|
|
|
1896
|
|
|
1897
|
|
|
1898 ;(let ((all nil))
|
|
|
1899 ; (mapatoms #'(lambda (x)
|
|
|
1900 ; (if (and (boundp x)
|
|
|
1901 ; (string-match "^mail-extr-" (symbol-name x)))
|
|
|
1902 ; (setq all (cons x all)))))
|
|
|
1903 ; (setq all (sort all #'string-lessp))
|
|
|
1904 ; (cons 'setq
|
|
|
1905 ; (apply 'nconc (mapcar #'(lambda (x)
|
|
|
1906 ; (list x (symbol-value x)))
|
|
|
1907 ; all))))
|
|
|
1908
|
|
|
1909
|
|
|
1910 (provide 'mail-extr)
|
|
|
1911
|
|
|
1912 ;;; mail-extr.el ends here
|
