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