X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f98b752f204fbcd2a3ae8e57678e026470b34b27..6a7250d806dadd555a9a22c42b0bb51c73327dba:/lisp/mail/mail-extr.el diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index ab3545b66d..d891a031e5 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1,6 +1,7 @@ -;;; mail-extr.el --- extract full name and address from RFC 822 mail header. +;;; mail-extr.el --- extract full name and address from RFC 822 mail header -*- coding: utf-8 -*- -;; Copyright (C) 1991, 1992, 1993, 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Joe Wells ;; Maintainer: FSF @@ -20,19 +21,19 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; The entry point of this code is ;; ;; mail-extract-address-components: (address &optional all) -;; +;; ;; Given an RFC-822 ADDRESS, extract full name and canonical address. ;; Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). ;; If no name can be extracted, FULL-NAME will be nil. -;; ADDRESS may be a string or a buffer. If it is a buffer, the visible +;; ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; (narrowed) portion of the buffer will be interpreted as the address. ;; (This feature exists so that the clever caller might be able to avoid ;; consing a string.) @@ -60,10 +61,10 @@ ;; make sure you're not breaking functionality. The test cases aren't included ;; because they are over 100K. ;; -;; If you find an address that mail-extr fails on, please send it to the +;; If you find an address that mail-extr fails on, please send it to the ;; maintainer along with what you think the correct results should be. We do ;; not consider it a bug if mail-extr mangles a comment that does not -;; correspond to a real human full name, although we would prefer that +;; correspond to a real human full name, although we would prefer that ;; mail-extr would return the comment as-is. ;; ;; Features: @@ -120,8 +121,8 @@ ;; * insert documentation strings! ;; * handle X.400-gatewayed addresses according to RFC 1148. -;;; Change Log: -;; +;;; Change Log: +;; ;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@lucid.com) ;; ;; * merged with jbw's latest version @@ -139,26 +140,26 @@ ;; * some more cleanup, doc, added provide ;; ;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu) -;; +;; ;; * Made mail-full-name-prefixes a user-customizable variable. -;; Allow passing the address as a buffer as well as as a string. +;; Allow passing the address as a buffer as well as a string. ;; Allow [ and ] as name characters (Finnish character set). -;; +;; ;; Mon Mar 22 21:20:56 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Handle "null" addresses. Handle = used for spacing in mailbox ;; name. Fix bug in handling of ROUTE-ADDR-type addresses that are ;; missing their brackets. Handle uppercase "JR". Extract full ;; names from X.400 addresses encoded in RFC-822. Fix bug in ;; handling of multiple addresses where first has trailing comment. ;; Handle more kinds of telephone extension lead-ins. -;; +;; ;; Mon Mar 22 20:16:57 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Handle HZ encoding for embedding GB encoded chinese characters. -;; +;; ;; Mon Mar 22 00:46:12 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Fixed too broad matching of ham radio call signs. Fixed bug in ;; handling an unmatched ' in a name string. Enhanced recognition ;; of when . in the mailbox name terminates the name portion. @@ -168,40 +169,40 @@ ;; introduced in switching last name order. Fixed bug in handling ;; address with ! and % but no @. Narrowed the cases in which ;; certain trailing words are discarded. -;; +;; ;; Sun Mar 21 21:41:06 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Fixed bugs in handling GROUP addresses. Certain words in the ;; middle of a name no longer terminate it. Handle LISTSERV list ;; names. Ignore comment field containing mailbox name. -;; +;; ;; Sun Mar 21 14:39:38 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Moved variant-method code back into main function. Handle ;; underscores as spaces in comments. Handle leading nickname. Add ;; flag to ignore single-word names. Other changes. -;; +;; ;; Mon Feb 1 22:23:31 1993 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Added in changes by Rod Whitby and Jamie Zawinski. This ;; includes the flag mail-extr-guess-middle-initial and the fix for ;; handling multiple addresses correctly. (Whitby just changed ;; a > to a <.) -;; +;; ;; Mon Apr 6 23:59:09 1992 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Cleaned up some more. Release version 1.0 to world. -;; +;; ;; Sun Apr 5 19:39:08 1992 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Cleaned up full name extraction extensively. -;; +;; ;; Sun Feb 2 14:45:24 1992 Joe Wells (jbw at bigbird.bu.edu) -;; +;; ;; * Total rewrite. Integrated mail-canonicalize-address into ;; mail-extract-address-components. Now handles GROUP addresses more ;; or less correctly. Better handling of lots of different cases. -;; +;; ;; Fri Jun 14 19:39:50 1991 ;; * Created. @@ -225,9 +226,17 @@ we will assume that \"John Q. Smith\" is the fellow's name." :type 'boolean :group 'mail-extr) -(defcustom mail-extr-ignore-single-names t +(defcustom mail-extr-ignore-single-names nil "*Whether to ignore a name that is just a single word. If true, then when we see an address like \"Idiot \" +we will act as though we couldn't find a full name in the address." + :type 'boolean + :version "22.1" + :group 'mail-extr) + +(defcustom mail-extr-ignore-realname-equals-mailbox-name t +"*Whether to ignore a name that is equal to the mailbox name. +If true, then when the address is like \"Single \" we will act as though we couldn't find a full name in the address." :type 'boolean :group 'mail-extr) @@ -272,34 +281,13 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Constant definitions. ;; -;; Codes in -;; Names in ISO 8859-1 Name -;; ISO 10XXX ISO 8859-2 in -;; ISO 6937 ISO 10646 RFC Swedish -;; etc. Hex Oct 1345 TeX Split ASCII Description -;; --------- ---------- ---- --- ----- ----- ------------------------------- -;; %a E4 344 a: \"a ae { latin small a + diaeresis d -;; %o F6 366 o: \"o oe | latin small o + diaeresis v -;; @a E5 345 aa \oa aa } latin small a + ring above e -;; %u FC 374 u: \"u ue ~ latin small u + diaeresis | -;; /e E9 351 e' \'e ` latin small e + acute i -;; %A C4 304 A: \"A AE [ latin capital a + diaeresis D -;; %O D6 326 O: \"O OE \ latin capital o + diaeresis V -;; @A C5 305 AA \oA AA ] latin capital a + ring above E -;; %U DC 334 U: \"U UE ^ latin capital u + diaeresis \ -;; /E C9 311 E' \'E @ latin capital e + acute I - -;; NOTE: @a and @A are not in ISO 8859-2 (the codes mentioned above invoke -;; /l and /L). Some of this data was retrieved from -;; listserv@jhuvm.hcf.jhu.edu. - ;; Any character that can occur in a name, not counting characters that ;; separate parts of a multipart name (hyphen and period). ;; Yes, there are weird people with digits in their names. ;; You will also notice the consideration for the ;; Swedish/Finnish/Norwegian character set. (defconst mail-extr-all-letters-but-separators - (purecopy "][A-Za-z{|}'~0-9`\240-\377")) + (purecopy "][[:alnum:]{|}'~`")) ;; Any character that can occur in a name in an RFC822 address including ;; the separator (hyphen and possibly period) for multipart names. @@ -309,25 +297,24 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Any character that can start a name. ;; Keep this set as minimal as possible. -(defconst mail-extr-first-letters (purecopy "A-Za-z\240-\377")) +(defconst mail-extr-first-letters (purecopy "[:alpha:]")) ;; Any character that can end a name. ;; Keep this set as minimal as possible. -(defconst mail-extr-last-letters (purecopy "A-Za-z\240-\377`'.")) +(defconst mail-extr-last-letters (purecopy "[:alpha:]`'.")) -(defconst mail-extr-leading-garbage - (purecopy (format "[^%s]+" mail-extr-first-letters))) +(defconst mail-extr-leading-garbage "\\W+") -;; (defconst mail-extr-non-name-chars +;; (defconst mail-extr-non-name-chars ;; (purecopy (concat "^" mail-extr-all-letters "."))) ;; (defconst mail-extr-non-begin-name-chars ;; (purecopy (concat "^" mail-extr-first-letters))) ;; (defconst mail-extr-non-end-name-chars ;; (purecopy (concat "^" mail-extr-last-letters))) -;; Matches an initial not followed by both a period and a space. +;; Matches an initial not followed by both a period and a space. ;; (defconst mail-extr-bad-initials-pattern -;; (purecopy +;; (purecopy ;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)" ;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters))) @@ -363,7 +350,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Must not match a trailing uppercase last name or trailing initial (defconst mail-extr-weird-acronym-pattern (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)")) - + ;; Matches a mixed-case or lowercase name (not an initial). ;; #### Match Latin1 lower case letters here too? ;; (defconst mail-extr-mixed-case-name-pattern @@ -376,7 +363,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Matches a trailing alternative address. ;; #### Match Latin1 letters here too? -;; #### Match _ before @ here too? +;; #### Match _ before @ here too? (defconst mail-extr-alternative-address-pattern (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]")) @@ -435,7 +422,7 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Matches a single word name. ;; (defconst mail-extr-one-name-pattern ;; (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'"))) - + ;; Matches normal two names with missing middle initial ;; The first name is not allowed to have a hyphen because this can cause ;; false matches where the "middle initial" is actually the first letter @@ -459,12 +446,12 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; encountered. The character '~' is an escape character. By convention, it ;; must be immediately followed ONLY by '~', '{' or '\n' (), with the ;; following special meaning. -;; +;; ;; o The escape sequence '~~' is interpreted as a '~'. ;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB. ;; o The escape sequence '~\n' is a line-continuation marker to be consumed ;; with no output produced. -;; +;; ;; In GB mode, characters are interpreted two bytes at a time as (pure) GB ;; codes until the escape-from-GB code '~}' is read. This code switches the ;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}' @@ -511,31 +498,25 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." (defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table)) (defconst mail-extr-address-text-comment-syntax-table (make-syntax-table)) (defconst mail-extr-address-text-syntax-table (make-syntax-table)) -(mapcar - (function - (lambda (pair) - (let ((syntax-table (symbol-value (car pair)))) - (mapcar - (function - (lambda (item) - (if (eq 2 (length item)) - ;; modifying syntax of a single character - (modify-syntax-entry (car item) (car (cdr item)) syntax-table) - ;; modifying syntax of a range of characters - (let ((char (nth 0 item)) - (bound (nth 1 item)) - (syntax (nth 2 item))) - (while (<= char bound) - (modify-syntax-entry char syntax syntax-table) - (setq char (1+ char))))))) - (cdr pair))))) +(mapc + (lambda (pair) + (let ((syntax-table (symbol-value (car pair)))) + (dolist (item (cdr pair)) + (if (eq 2 (length item)) + ;; modifying syntax of a single character + (modify-syntax-entry (car item) (car (cdr item)) syntax-table) + ;; modifying syntax of a range of characters + (let ((char (nth 0 item)) + (bound (nth 1 item)) + (syntax (nth 2 item))) + (while (<= char bound) + (modify-syntax-entry char syntax syntax-table) + (setq char (1+ char)))))))) '((mail-extr-address-syntax-table (?\000 ?\037 "w") ;control characters (?\040 " ") ;SPC (?! ?~ "w") ;printable characters (?\177 "w") ;DEL - (?\200 ?\377 "w") ;high-bit-on characters - (?\240 " ") ;nobreakspace (?\t " ") (?\r " ") (?\n " ") @@ -618,37 +599,35 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." ;; Utility functions and macros. ;; -(defmacro mail-extr-delete-char (n) - ;; in v19, delete-char is compiled as a function call, but delete-region - ;; is byte-coded, so it's much much faster. - (list 'delete-region '(point) (list '+ '(point) n))) +;; Fixme: There are Latin-1 nbsp below. If such characters should be +;; included, this is the wrong thing to do -- it should use syntax (or +;; regexp char classes). -(defmacro mail-extr-skip-whitespace-forward () +(defsubst mail-extr-skip-whitespace-forward () ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded. - '(skip-chars-forward " \t\n\r\240")) + (skip-chars-forward " \t\n\r ")) -(defmacro mail-extr-skip-whitespace-backward () +(defsubst mail-extr-skip-whitespace-backward () ;; v19 fn skip-syntax-backward is more tasteful, but not byte-coded. - '(skip-chars-backward " \t\n\r\240")) + (skip-chars-backward " \t\n\r ")) -(defmacro mail-extr-undo-backslash-quoting (beg end) - (`(save-excursion - (save-restriction - (narrow-to-region (, beg) (, end)) - (goto-char (point-min)) - ;; undo \ quoting - (while (search-forward "\\" nil t) - (mail-extr-delete-char -1) - (or (eobp) - (forward-char 1)) - ))))) - -(defmacro mail-extr-nuke-char-at (pos) - (` (save-excursion - (goto-char (, pos)) - (mail-extr-delete-char 1) - (insert ?\ )))) +(defsubst mail-extr-undo-backslash-quoting (beg end) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + ;; undo \ quoting + (while (search-forward "\\" nil t) + (delete-char -1) + (or (eobp) + (forward-char 1)))))) + +(defsubst mail-extr-nuke-char-at (pos) + (save-excursion + (goto-char pos) + (delete-char 1) + (insert ?\ ))) (put 'mail-extr-nuke-outside-range 'edebug-form-spec '(symbolp &optional form form atom)) @@ -656,27 +635,28 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." (defmacro mail-extr-nuke-outside-range (list-symbol beg-symbol end-symbol &optional no-replace) - ;; LIST-SYMBOL names a variable holding a list of buffer positions - ;; BEG-SYMBOL and END-SYMBOL name variables delimiting a range - ;; Each element of LIST-SYMBOL which lies outside of the range is - ;; deleted from the list. - ;; Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL - ;; which lie outside of the range, one character at that position is - ;; replaced with a SPC. + "Delete all elements outside BEG..END in LIST. +LIST-SYMBOL names a variable holding a list of buffer positions +BEG-SYMBOL and END-SYMBOL name variables delimiting a range +Each element of LIST-SYMBOL which lies outside of the range is + deleted from the list. +Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL + which lie outside of the range, one character at that position is + replaced with a SPC." (or (memq no-replace '(t nil)) (error "no-replace must be t or nil, evaluable at macroexpand-time")) - (` (let ((temp (, list-symbol)) + `(let ((temp ,list-symbol) ch) (while temp (setq ch (car temp)) - (cond ((or (> ch (, end-symbol)) - (< ch (, beg-symbol))) - (,@ (if no-replace - nil - (` ((mail-extr-nuke-char-at ch))))) - (setcar temp nil))) + (when (or (> ch ,end-symbol) + (< ch ,beg-symbol)) + ,@(if no-replace + nil + `((mail-extr-nuke-char-at ch))) + (setcar temp nil)) (setq temp (cdr temp))) - (setq (, list-symbol) (delq nil (, list-symbol)))))) + (setq ,list-symbol (delq nil ,list-symbol)))) (defun mail-extr-demarkerize (marker) ;; if arg is a marker, destroys the marker, then returns the old value. @@ -693,26 +673,18 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." pos (copy-marker pos))) -(defmacro mail-extr-last (list) - ;; Returns last element of LIST. - ;; Could be a subst. - (` (let ((list (, list))) - (while (not (null (cdr list))) - (setq list (cdr list))) - (car list)))) - -(defmacro mail-extr-safe-move-sexp (arg) +(defsubst mail-extr-safe-move-sexp (arg) ;; Safely skip over one balanced sexp, if there is one. Return t if success. - (` (condition-case error - (progn - (goto-char (or (scan-sexps (point) (, arg)) (point))) - t) - (error - ;; #### kludge kludge kludge kludge kludge kludge kludge !!! - (if (string-equal (nth 1 error) "Unbalanced parentheses") - nil - (while t - (signal (car error) (cdr error)))))))) + (condition-case error + (progn + (goto-char (or (scan-sexps (point) arg) (point))) + t) + (error + ;; #### kludge kludge kludge kludge kludge kludge kludge !!! + (if (string-equal (nth 1 error) "Unbalanced parentheses") + nil + (while t + (signal (car error) (cdr error))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -722,12 +694,15 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\"." (defvar disable-initial-guessing-flag) ; dynamic assignment (defvar cbeg) ; dynamic assignment (defvar cend) ; dynamic assignment +(defvar mail-extr-all-top-level-domains) ; Defined below. ;;;###autoload (defun mail-extract-address-components (address &optional all) "Given an RFC-822 address ADDRESS, extract full name and canonical address. -Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). If no +name can be extracted, FULL-NAME will be nil. Also see +`mail-extr-ignore-single-names' and +`mail-extr-ignore-realname-equals-mailbox-name'. If the optional argument ALL is non-nil, then ADDRESS can contain zero or more recipients, separated by commas, and we return a list of @@ -735,23 +710,22 @@ the form ((FULL-NAME CANONICAL-ADDRESS) ...) with one element for each recipient. If ALL is nil, then if ADDRESS contains more than one recipients, all but the first is ignored. -ADDRESS may be a string or a buffer. If it is a buffer, the visible - (narrowed) portion of the buffer will be interpreted as the address. - (This feature exists so that the clever caller might be able to avoid - consing a string.)" +ADDRESS may be a string or a buffer. If it is a buffer, the visible +\(narrowed) portion of the buffer will be interpreted as the address. +\(This feature exists so that the clever caller might be able to avoid +consing a string.)" (let ((canonicalization-buffer (get-buffer-create " *canonical address*")) (extraction-buffer (get-buffer-create " *extract address components*")) value-list) - (save-excursion - (set-buffer extraction-buffer) + (with-current-buffer (get-buffer-create extraction-buffer) (fundamental-mode) (buffer-disable-undo extraction-buffer) (set-syntax-table mail-extr-address-syntax-table) (widen) (erase-buffer) (setq case-fold-search nil) - + ;; Insert extra space at beginning to allow later replacement with < ;; without having to move markers. (insert ?\ ) @@ -766,19 +740,17 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (set-text-properties (point-min) (point-max) nil) - (save-excursion - (set-buffer canonicalization-buffer) + (with-current-buffer (get-buffer-create canonicalization-buffer) (fundamental-mode) (buffer-disable-undo canonicalization-buffer) - (set-syntax-table mail-extr-address-syntax-table) (setq case-fold-search nil)) - + ;; Unfold multiple lines. (goto-char (point-min)) (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t) (replace-match "\\1 " t)) - + ;; Loop over addresses until we have as many as we want. (while (and (or all (null value-list)) (progn (goto-char (point-min)) @@ -804,6 +776,7 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; mailbox-name-processed-flag disable-initial-guessing-flag) ; dynamically set from -voodoo + (set-syntax-table mail-extr-address-syntax-table) (goto-char (point-min)) ;; Insert extra space at beginning to allow later replacement with < @@ -868,12 +841,12 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; BUG FIX: This test was reversed. Thanks to the ;; brilliant Rod Whitby ;; for discovering this! - (< (mail-extr-last <-pos) (car >-pos))))) + (< (car (last <-pos)) (car >-pos))))) ;; The argument contains more than one address. ;; Temporarily hide everything after this one. - (setq end-of-address (copy-marker (1+ (point)))) + (setq end-of-address (copy-marker (1+ (point)) t)) (narrow-to-region (point-min) (1+ (point))) - (mail-extr-delete-char 1) + (delete-char 1) (setq char ?\() ; HAVE I NO SHAME?? ) ;; record the position of various interesting chars, determine @@ -920,27 +893,25 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; If multiple @s and a :, but no < and >, insert around buffer. ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc ;; This commonly happens on the UUCP "From " line. Ugh. - (cond ((and (> (length @-pos) 1) + (when (and (> (length @-pos) 1) (eq 1 (length colon-pos)) ;TODO: check if between last two @s (not \;-pos) (not <-pos)) - (goto-char (point-min)) - (mail-extr-delete-char 1) - (setq <-pos (list (point))) - (insert ?<))) + (goto-char (point-min)) + (delete-char 1) + (setq <-pos (list (point))) + (insert ?<)) ;; If < but no >, insert > in rightmost possible position - (cond ((and <-pos - (null >-pos)) - (goto-char (point-max)) - (setq >-pos (list (point))) - (insert ?>))) + (when (and <-pos (null >-pos)) + (goto-char (point-max)) + (setq >-pos (list (point))) + (insert ?>)) ;; If > but no <, replace > with space. - (cond ((and >-pos - (null <-pos)) - (mail-extr-nuke-char-at (car >-pos)) - (setq >-pos nil))) + (when (and >-pos (null <-pos)) + (mail-extr-nuke-char-at (car >-pos)) + (setq >-pos nil)) ;; Turn >-pos and <-pos into non-lists (setq >-pos (car >-pos) @@ -948,15 +919,15 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; Trim other punctuation lists of items outside < > pair to handle ;; stupid MTAs. - (cond (<-pos ; don't need to check >-pos also - ;; handle bozo software that violates RFC 822 by sticking - ;; punctuation marks outside of a < > pair - (mail-extr-nuke-outside-range @-pos <-pos >-pos t) - ;; RFC 822 says nothing about these two outside < >, but - ;; remove those positions from the lists to make things - ;; easier. - (mail-extr-nuke-outside-range !-pos <-pos >-pos t) - (mail-extr-nuke-outside-range %-pos <-pos >-pos t))) + (when <-pos ; don't need to check >-pos also + ;; handle bozo software that violates RFC 822 by sticking + ;; punctuation marks outside of a < > pair + (mail-extr-nuke-outside-range @-pos <-pos >-pos t) + ;; RFC 822 says nothing about these two outside < >, but + ;; remove those positions from the lists to make things + ;; easier. + (mail-extr-nuke-outside-range !-pos <-pos >-pos t) + (mail-extr-nuke-outside-range %-pos <-pos >-pos t)) ;; Check for : that indicates GROUP list and for : part of ;; ROUTE-ADDR spec. @@ -993,19 +964,18 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (setq group-\;-pos temp)))) ;; Nuke unmatched GROUP syntax characters. - (cond ((and group-:-pos (not group-\;-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-:-pos) - (setq group-:-pos nil))) - (cond ((and group-\;-pos (not group-:-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-\;-pos) - (setq group-\;-pos nil))) + (when (and group-:-pos (not group-\;-pos)) + ;; *** Do I really need to erase it? + (mail-extr-nuke-char-at group-:-pos) + (setq group-:-pos nil)) + (when (and group-\;-pos (not group-:-pos)) + ;; *** Do I really need to erase it? + (mail-extr-nuke-char-at group-\;-pos) + (setq group-\;-pos nil)) ;; Handle junk like ";@host.company.dom" that sendmail adds. ;; **** should I remember comment positions? - (cond - (group-\;-pos + (when group-\;-pos ;; this is fine for now (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t) (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t) @@ -1029,11 +999,11 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; *** The entire handling of GROUP addresses seems rather lame. ;; *** It deserves a complete rethink, except that these addresses ;; *** are hardly ever seen. - )) + ) ;; Any commas must be between < and : of ROUTE-ADDR. Nuke any ;; others. - ;; Hell, go ahead an nuke all of the commas. + ;; Hell, go ahead and nuke all of the commas. ;; **** This will cause problems when we start handling commas in ;; the PHRASE part .... no it won't ... yes it will ... ????? (mail-extr-nuke-outside-range comma-pos 1 1) @@ -1043,57 +1013,55 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; handled above. ;; Locate PHRASE part of ROUTE-ADDR. - (cond (<-pos - (goto-char <-pos) - (mail-extr-skip-whitespace-backward) - (setq phrase-end (point)) - (goto-char (or ;;group-:-pos - (point-min))) - (mail-extr-skip-whitespace-forward) - (if (< (point) phrase-end) - (setq phrase-beg (point)) - (setq phrase-end nil)))) + (when <-pos + (goto-char <-pos) + (mail-extr-skip-whitespace-backward) + (setq phrase-end (point)) + (goto-char (or ;;group-:-pos + (point-min))) + (mail-extr-skip-whitespace-forward) + (if (< (point) phrase-end) + (setq phrase-beg (point)) + (setq phrase-end nil))) ;; handle ROUTE-ADDRS with real ROUTEs. ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and ;; any % or ! must be semantically meaningless. ;; TODO: do this processing into canonicalization buffer - (cond (route-addr-:-pos - (setq !-pos nil - %-pos nil - >-pos (copy-marker >-pos) - route-addr-:-pos (copy-marker route-addr-:-pos)) - (goto-char >-pos) - (insert-before-markers ?X) - (goto-char (car @-pos)) - (while (setq @-pos (cdr @-pos)) - (mail-extr-delete-char 1) - (setq %-pos (cons (point-marker) %-pos)) - (insert "%") - (goto-char (1- >-pos)) - (save-excursion - (insert-buffer-substring extraction-buffer - (car @-pos) route-addr-:-pos) - (delete-region (car @-pos) route-addr-:-pos)) - (or (cdr @-pos) - (setq saved-@-pos (list (point))))) - (setq @-pos saved-@-pos) - (goto-char >-pos) - (mail-extr-delete-char -1) - (mail-extr-nuke-char-at route-addr-:-pos) - (mail-extr-demarkerize route-addr-:-pos) - (setq route-addr-:-pos nil - >-pos (mail-extr-demarkerize >-pos) - %-pos (mapcar 'mail-extr-demarkerize %-pos)))) + (when route-addr-:-pos + (setq !-pos nil + %-pos nil + >-pos (copy-marker >-pos) + route-addr-:-pos (copy-marker route-addr-:-pos)) + (goto-char >-pos) + (insert-before-markers ?X) + (goto-char (car @-pos)) + (while (setq @-pos (cdr @-pos)) + (delete-char 1) + (setq %-pos (cons (point-marker) %-pos)) + (insert "%") + (goto-char (1- >-pos)) + (save-excursion + (insert-buffer-substring extraction-buffer + (car @-pos) route-addr-:-pos) + (delete-region (car @-pos) route-addr-:-pos)) + (or (cdr @-pos) + (setq saved-@-pos (list (point))))) + (setq @-pos saved-@-pos) + (goto-char >-pos) + (delete-char -1) + (mail-extr-nuke-char-at route-addr-:-pos) + (mail-extr-demarkerize route-addr-:-pos) + (setq route-addr-:-pos nil + >-pos (mail-extr-demarkerize >-pos) + %-pos (mapcar 'mail-extr-demarkerize %-pos))) ;; de-listify @-pos (setq @-pos (car @-pos)) ;; TODO: remove comments in the middle of an address - (save-excursion - (set-buffer canonicalization-buffer) - + (with-current-buffer canonicalization-buffer (widen) (erase-buffer) (insert-buffer-substring extraction-buffer) @@ -1108,8 +1076,7 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (narrow-to-region first-real-pos last-real-pos) ;; ****** Oh no! What if the address is completely empty! ;; *** Is this correct? - (narrow-to-region (point-max) (point-max)) - )) + (narrow-to-region (point-max) (point-max)))) (and @-pos %-pos (mail-extr-nuke-outside-range %-pos (point-min) @-pos)) @@ -1121,118 +1088,119 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; Error condition:?? (and %-pos (not @-pos)) ;; WARNING: THIS CODE IS DUPLICATED BELOW. - (cond ((and %-pos - (not @-pos)) - (goto-char (car %-pos)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (insert "@") - (setq %-pos (cdr %-pos)))) - - (if mail-extr-mangle-uucp - (cond (!-pos - ;; **** I don't understand this save-restriction and the - ;; narrow-to-region inside it. Why did I do that? - (save-restriction - (cond ((and @-pos - mail-extr-@-binds-tighter-than-!) - (goto-char @-pos) - (setq %-pos (cons (point) %-pos) - @-pos nil) - (mail-extr-delete-char 1) - (insert "%") - (setq insert-point (point-max))) - (mail-extr-@-binds-tighter-than-! - (setq insert-point (point-max))) - (%-pos - (setq insert-point (mail-extr-last %-pos) - saved-%-pos (mapcar 'mail-extr-markerize %-pos) - %-pos nil - @-pos (mail-extr-markerize @-pos))) - (@-pos - (setq insert-point @-pos) - (setq @-pos (mail-extr-markerize @-pos))) - (t - (setq insert-point (point-max)))) - (narrow-to-region (point-min) insert-point) - (setq saved-!-pos (car !-pos)) - (while !-pos - (goto-char (point-max)) - (cond ((and (not @-pos) - (not (cdr !-pos))) - (setq @-pos (point)) - (insert-before-markers "@ ")) - (t - (setq %-pos (cons (point) %-pos)) - (insert-before-markers "% "))) - (backward-char 1) - (insert-buffer-substring - (current-buffer) - (if (nth 1 !-pos) - (1+ (nth 1 !-pos)) - (point-min)) - (car !-pos)) - (mail-extr-delete-char 1) - (or (save-excursion - (mail-extr-safe-move-sexp -1) - (mail-extr-skip-whitespace-backward) - (eq ?. (preceding-char))) - (insert-before-markers - (if (save-excursion - (mail-extr-skip-whitespace-backward) - (eq ?. (preceding-char))) - "" - ".") - "uucp")) - (setq !-pos (cdr !-pos)))) - (and saved-%-pos - (setq %-pos (append (mapcar 'mail-extr-demarkerize - saved-%-pos) - %-pos))) - (setq @-pos (mail-extr-demarkerize @-pos)) - (narrow-to-region (1+ saved-!-pos) (point-max))))) + (when (and %-pos (not @-pos)) + (goto-char (car %-pos)) + (delete-char 1) + (setq @-pos (point)) + (insert "@") + (setq %-pos (cdr %-pos))) + + (when (and mail-extr-mangle-uucp !-pos) + ;; **** I don't understand this save-restriction and the + ;; narrow-to-region inside it. Why did I do that? + (save-restriction + (cond ((and @-pos + mail-extr-@-binds-tighter-than-!) + (goto-char @-pos) + (setq %-pos (cons (point) %-pos) + @-pos nil) + (delete-char 1) + (insert "%") + (setq insert-point (point-max))) + (mail-extr-@-binds-tighter-than-! + (setq insert-point (point-max))) + (%-pos + (setq insert-point (car (last %-pos)) + saved-%-pos (mapcar 'mail-extr-markerize %-pos) + %-pos nil + @-pos (mail-extr-markerize @-pos))) + (@-pos + (setq insert-point @-pos) + (setq @-pos (mail-extr-markerize @-pos))) + (t + (setq insert-point (point-max)))) + (narrow-to-region (point-min) insert-point) + (setq saved-!-pos (car !-pos)) + (while !-pos + (goto-char (point-max)) + (cond ((and (not @-pos) + (not (cdr !-pos))) + (setq @-pos (point)) + (insert-before-markers "@ ")) + (t + (setq %-pos (cons (point) %-pos)) + (insert-before-markers "% "))) + (backward-char 1) + (insert-buffer-substring + (current-buffer) + (if (nth 1 !-pos) + (1+ (nth 1 !-pos)) + (point-min)) + (car !-pos)) + (delete-char 1) + (or (save-excursion + (mail-extr-safe-move-sexp -1) + (mail-extr-skip-whitespace-backward) + (eq ?. (preceding-char))) + (insert-before-markers + (if (save-excursion + (mail-extr-skip-whitespace-backward) + (eq ?. (preceding-char))) + "" + ".") + "uucp")) + (setq !-pos (cdr !-pos)))) + (and saved-%-pos + (setq %-pos (append (mapcar 'mail-extr-demarkerize + saved-%-pos) + %-pos))) + (setq @-pos (mail-extr-demarkerize @-pos)) + (narrow-to-region (1+ saved-!-pos) (point-max))) ;; WARNING: THIS CODE IS DUPLICATED ABOVE. - (cond ((and %-pos - (not @-pos)) - (goto-char (car %-pos)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (insert "@") - (setq %-pos (cdr %-pos)))) - - (setq %-pos (nreverse %-pos)) - (cond (%-pos ; implies @-pos valid - (setq temp %-pos) - (catch 'truncated - (while temp - (goto-char (or (nth 1 temp) - @-pos)) - (mail-extr-skip-whitespace-backward) - (save-excursion - (mail-extr-safe-move-sexp -1) - (setq domain-pos (point)) - (mail-extr-skip-whitespace-backward) - (setq \.-pos (eq ?. (preceding-char)))) - (cond ((and \.-pos - ;; #### string consing - (let ((s (intern-soft - (buffer-substring domain-pos (point)) - mail-extr-all-top-level-domains))) - (and s (get s 'domain-name)))) - (narrow-to-region (point-min) (point)) - (goto-char (car temp)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (setcdr temp nil) - (setq %-pos (delq @-pos %-pos)) - (insert "@") - (throw 'truncated t))) - (setq temp (cdr temp)))))) + (when (and %-pos (not @-pos)) + (goto-char (car %-pos)) + (delete-char 1) + (setq @-pos (point)) + (insert "@") + (setq %-pos (cdr %-pos))) + + (when (setq %-pos (nreverse %-pos)) ; implies @-pos valid + (setq temp %-pos) + (catch 'truncated + (while temp + (goto-char (or (nth 1 temp) + @-pos)) + (mail-extr-skip-whitespace-backward) + (save-excursion + (mail-extr-safe-move-sexp -1) + (setq domain-pos (point)) + (mail-extr-skip-whitespace-backward) + (setq \.-pos (eq ?. (preceding-char)))) + (when (and \.-pos + ;; #### string consing + (let ((s (intern-soft + (buffer-substring domain-pos (point)) + mail-extr-all-top-level-domains))) + (and s (get s 'domain-name)))) + (narrow-to-region (point-min) (point)) + (goto-char (car temp)) + (delete-char 1) + (setq @-pos (point)) + (setcdr temp nil) + (setq %-pos (delq @-pos %-pos)) + (insert "@") + (throw 'truncated t)) + (setq temp (cdr temp))))) (setq mbox-beg (point-min) mbox-end (if %-pos (car %-pos) (or @-pos - (point-max))))) + (point-max)))) + + (when @-pos + ;; Make the domain-name part lowercase since it's case + ;; insensitive anyway. + (downcase-region (1+ @-pos) (point-max)))) ;; Done canonicalizing address. ;; We are now back in extraction-buffer. @@ -1306,10 +1274,10 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (setq quote-end (- (point) 2)) (save-excursion (backward-char 1) - (mail-extr-delete-char 1) + (delete-char 1) (goto-char quote-beg) (or (eobp) - (mail-extr-delete-char 1))) + (delete-char 1))) (mail-extr-undo-backslash-quoting quote-beg quote-end) (or (eq ?\ (char-after (point))) (insert " ")) @@ -1319,16 +1287,16 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (if (memq (char-after (1+ (point))) '(?_ ?=)) (progn (forward-char 1) - (mail-extr-delete-char 1) + (delete-char 1) (insert ?\ )) (if \.-ends-name (narrow-to-region (point-min) (point)) - (mail-extr-delete-char 1) + (delete-char 1) (insert " "))) ;; (setq mailbox-name-processed-flag t) ) ((memq (char-syntax char) '(?. ?\\)) - (mail-extr-delete-char 1) + (delete-char 1) (insert " ") ;; (setq mailbox-name-processed-flag t) ) @@ -1350,16 +1318,15 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; Copy the contents of the individual fields that ;; might hold name data to the beginning. - (mapcar - (function - (lambda (field-pattern) - (cond - ((save-excursion - (re-search-forward field-pattern nil t)) - (insert-buffer-substring (current-buffer) - (match-beginning 1) - (match-end 1)) - (insert " "))))) + (mapc + (lambda (field-pattern) + (when + (save-excursion + (re-search-forward field-pattern nil t)) + (insert-buffer-substring (current-buffer) + (match-beginning 1) + (match-end 1)) + (insert " "))) (list mail-extr-x400-encoded-address-given-name-pattern mail-extr-x400-encoded-address-surname-pattern mail-extr-x400-encoded-address-full-name-pattern)) @@ -1407,47 +1374,47 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; Initial code by Jamie Zawinski ;; *** Make it work when there's a suffix as well. (goto-char (point-min)) - (cond ((and mail-extr-guess-middle-initial - (not disable-initial-guessing-flag) - (eq 3 (- mbox-end mbox-beg)) - (progn - (goto-char (point-min)) - (looking-at mail-extr-two-name-pattern))) - (setq fi (char-after (match-beginning 0)) - li (char-after (match-beginning 3))) - (save-excursion - (set-buffer canonicalization-buffer) - ;; char-equal is ignoring case here, so no need to upcase - ;; or downcase. - (let ((case-fold-search t)) - (and (char-equal fi (char-after mbox-beg)) - (char-equal li (char-after (1- mbox-end))) - (setq mi (char-after (1+ mbox-beg)))))) - (cond ((and mi - ;; TODO: use better table than syntax table - (eq ?w (char-syntax mi))) - (goto-char (match-beginning 3)) - (insert (upcase mi) ". "))))) + (when (and mail-extr-guess-middle-initial + (not disable-initial-guessing-flag) + (eq 3 (- mbox-end mbox-beg)) + (progn + (goto-char (point-min)) + (looking-at mail-extr-two-name-pattern))) + (setq fi (char-after (match-beginning 0)) + li (char-after (match-beginning 3))) + (with-current-buffer canonicalization-buffer + ;; char-equal is ignoring case here, so no need to upcase + ;; or downcase. + (let ((case-fold-search t)) + (and (char-equal fi (char-after mbox-beg)) + (char-equal li (char-after (1- mbox-end))) + (setq mi (char-after (1+ mbox-beg)))))) + (when (and mi + ;; TODO: use better table than syntax table + (eq ?w (char-syntax mi))) + (goto-char (match-beginning 3)) + (insert (upcase mi) ". "))) ;; Nuke name if it is the same as mailbox name. (let ((buffer-length (- (point-max) (point-min))) (i 0) (names-match-flag t)) - (cond ((and (> buffer-length 0) - (eq buffer-length (- mbox-end mbox-beg))) - (goto-char (point-max)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (while (and names-match-flag - (< i buffer-length)) - (or (eq (downcase (char-after (+ i (point-min)))) - (downcase - (char-after (+ i buffer-length (point-min))))) - (setq names-match-flag nil)) - (setq i (1+ i))) - (delete-region (+ (point-min) buffer-length) (point-max)) - (if names-match-flag - (narrow-to-region (point) (point)))))) + (when (and (> buffer-length 0) + (eq buffer-length (- mbox-end mbox-beg))) + (goto-char (point-max)) + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (while (and names-match-flag + (< i buffer-length)) + (or (eq (downcase (char-after (+ i (point-min)))) + (downcase + (char-after (+ i buffer-length (point-min))))) + (setq names-match-flag nil)) + (setq i (1+ i))) + (delete-region (+ (point-min) buffer-length) (point-max)) + (and names-match-flag + mail-extr-ignore-realname-equals-mailbox-name + (narrow-to-region (point) (point))))) ;; Nuke name if it's just one word. (goto-char (point-min)) @@ -1459,8 +1426,7 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (setq value-list (cons (list (if (not (= (point-min) (point-max))) (buffer-string)) - (save-excursion - (set-buffer canonicalization-buffer) + (with-current-buffer canonicalization-buffer (if (not (= (point-min) (point-max))) (buffer-string)))) value-list)) @@ -1478,368 +1444,388 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (if all (nreverse value-list) (car value-list)) )) +(defcustom mail-extr-disable-voodoo "\\cj" + "*If it is a regexp, names matching it will never be modified. +If it is neither nil nor a string, modifying of names will never take +place. It affects how `mail-extract-address-components' works." + :type '(choice (regexp :size 0) + (const :tag "Always enabled" nil) + (const :tag "Always disabled" t)) + :group 'mail-extr) + (defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer) - (let ((word-count 0) - (case-fold-search nil) - mixed-case-flag lower-case-flag ;;upper-case-flag - suffix-flag last-name-comma-flag - ;;cbeg cend - initial - begin-again-flag - drop-this-word-if-trailing-flag - drop-last-word-if-trailing-flag - word-found-flag - this-word-beg last-word-beg - name-beg name-end - name-done-flag - ) - (save-excursion - (set-syntax-table mail-extr-address-text-syntax-table) - - ;; Get rid of comments. - (goto-char (point-min)) - (while (not (eobp)) - ;; Initialize for this iteration of the loop. - (skip-chars-forward "^({[\"'`") - (let ((cbeg (point))) - (set-syntax-table mail-extr-address-text-comment-syntax-table) - (cond ((memq (following-char) '(?\' ?\`)) - (search-forward "'" nil 'move - (if (eq ?\' (following-char)) 2 1))) - (t - (or (mail-extr-safe-move-sexp 1) - (goto-char (point-max))))) - (set-syntax-table mail-extr-address-text-syntax-table) - (when (eq (char-after cbeg) ?\() - ;; Delete the comment itself. - (delete-region cbeg (point)) - ;; Canonicalize whitespace where the comment was. - (skip-chars-backward " \t") - (if (looking-at "\\([ \t]+$\\|[ \t]+,\\)") - (replace-match "") - (setq cbeg (point)) - (skip-chars-forward " \t") - (if (bobp) - (delete-region (point) cbeg) - (just-one-space)))))) - - ;; This was moved above. - ;; Fix . used as space - ;; But it belongs here because it occurs not only as - ;; rypens@reks.uia.ac.be (Piet.Rypens) - ;; but also as - ;; "Piet.Rypens" - ;;(goto-char (point-min)) - ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) - ;; (replace-match "\\1 \\2" t)) - - (cond ((not (search-forward " " nil t)) - (goto-char (point-min)) - (cond ((search-forward "_" nil t) - ;; Handle the *idiotic* use of underlines as spaces. - ;; Example: fml@foo.bar.dom (First_M._Last) - (goto-char (point-min)) - (while (search-forward "_" nil t) - (replace-match " " t))) - ((search-forward "." nil t) - ;; Fix . used as space - ;; Example: danj1@cb.att.com (daniel.jacobson) - (goto-char (point-min)) - (while (re-search-forward mail-extr-bad-dot-pattern nil t) - (replace-match "\\1 \\2" t)))))) - - ;; Loop over the words (and other junk) in the name. - (goto-char (point-min)) - (while (not name-done-flag) - - (cond (word-found-flag - ;; Last time through this loop we skipped over a word. - (setq last-word-beg this-word-beg) - (setq drop-last-word-if-trailing-flag - drop-this-word-if-trailing-flag) - (setq word-found-flag nil))) - - (cond (begin-again-flag - ;; Last time through the loop we found something that - ;; indicates we should pretend we are beginning again from - ;; the start. - (setq word-count 0) - (setq last-word-beg nil) - (setq drop-last-word-if-trailing-flag nil) - (setq mixed-case-flag nil) - (setq lower-case-flag nil) -;; (setq upper-case-flag nil) - (setq begin-again-flag nil) - )) - - ;; Initialize for this iteration of the loop. - (mail-extr-skip-whitespace-forward) - (if (eq word-count 0) (narrow-to-region (point) (point-max))) - (setq this-word-beg (point)) - (setq drop-this-word-if-trailing-flag nil) - - ;; Decide what to do based on what we are looking at. - (cond - - ;; Delete title - ((and (eq word-count 0) - (looking-at mail-extr-full-name-prefixes)) - (goto-char (match-end 0)) - (narrow-to-region (point) (point-max))) - - ;; Stop after name suffix - ((and (>= word-count 2) - (looking-at mail-extr-full-name-suffix-pattern)) - (mail-extr-skip-whitespace-backward) - (setq suffix-flag (point)) - (if (eq ?, (following-char)) - (forward-char 1) - (insert ?,)) - ;; Enforce at least one space after comma - (or (eq ?\ (following-char)) - (insert ?\ )) + (unless (and mail-extr-disable-voodoo + (or (not (stringp mail-extr-disable-voodoo)) + (progn + (goto-char (point-min)) + (re-search-forward mail-extr-disable-voodoo nil t)))) + (let ((word-count 0) + (case-fold-search nil) + mixed-case-flag lower-case-flag ;;upper-case-flag + suffix-flag last-name-comma-flag + ;;cbeg cend + initial + begin-again-flag + drop-this-word-if-trailing-flag + drop-last-word-if-trailing-flag + word-found-flag + this-word-beg last-word-beg + name-beg name-end + name-done-flag + ) + (save-excursion + (set-syntax-table mail-extr-address-text-syntax-table) + + ;; Get rid of comments. + (goto-char (point-min)) + (while (not (eobp)) + ;; Initialize for this iteration of the loop. + (skip-chars-forward "^({[\"'`") + (let ((cbeg (point))) + (set-syntax-table mail-extr-address-text-comment-syntax-table) + (if (memq (following-char) '(?\' ?\`)) + (search-forward "'" nil 'move + (if (eq ?\' (following-char)) 2 1)) + (or (mail-extr-safe-move-sexp 1) + (goto-char (point-max)))) + (set-syntax-table mail-extr-address-text-syntax-table) + (when (eq (char-after cbeg) ?\() + ;; Delete the comment itself. + (delete-region cbeg (point)) + ;; Canonicalize whitespace where the comment was. + (skip-chars-backward " \t") + (if (looking-at "\\([ \t]+$\\|[ \t]+,\\)") + (replace-match "") + (setq cbeg (point)) + (skip-chars-forward " \t") + (if (bobp) + (delete-region (point) cbeg) + (just-one-space)))))) + + ;; This was moved above. + ;; Fix . used as space + ;; But it belongs here because it occurs not only as + ;; rypens@reks.uia.ac.be (Piet.Rypens) + ;; but also as + ;; "Piet.Rypens" + ;;(goto-char (point-min)) + ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) + ;; (replace-match "\\1 \\2" t)) + + (unless (search-forward " " nil t) + (goto-char (point-min)) + (cond ((search-forward "_" nil t) + ;; Handle the *idiotic* use of underlines as spaces. + ;; Example: fml@foo.bar.dom (First_M._Last) + (goto-char (point-min)) + (while (search-forward "_" nil t) + (replace-match " " t))) + ((search-forward "." nil t) + ;; Fix . used as space + ;; Example: danj1@cb.att.com (daniel.jacobson) + (goto-char (point-min)) + (while (re-search-forward mail-extr-bad-dot-pattern nil t) + (replace-match "\\1 \\2" t))))) + + ;; Loop over the words (and other junk) in the name. + (goto-char (point-min)) + (while (not name-done-flag) + + (when word-found-flag + ;; Last time through this loop we skipped over a word. + (setq last-word-beg this-word-beg) + (setq drop-last-word-if-trailing-flag + drop-this-word-if-trailing-flag) + (setq word-found-flag nil)) + + (when begin-again-flag + ;; Last time through the loop we found something that + ;; indicates we should pretend we are beginning again from + ;; the start. + (setq word-count 0) + (setq last-word-beg nil) + (setq drop-last-word-if-trailing-flag nil) + (setq mixed-case-flag nil) + (setq lower-case-flag nil) + ;; (setq upper-case-flag nil) + (setq begin-again-flag nil)) + + ;; Initialize for this iteration of the loop. (mail-extr-skip-whitespace-forward) - (cond ((memq (following-char) '(?j ?J ?s ?S)) - (capitalize-word 1) - (if (eq (following-char) ?.) - (forward-char 1) - (insert ?.))) - (t - (upcase-word 1))) - (setq word-found-flag t) - (setq name-done-flag t)) - - ;; Handle SCA names - ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" - (goto-char (match-beginning 1)) - (narrow-to-region (point) (point-max)) - (setq begin-again-flag t)) - - ;; Check for initial last name followed by comma - ((and (eq ?, (following-char)) - (eq word-count 1)) - (forward-char 1) - (setq last-name-comma-flag t) - (or (eq ?\ (following-char)) - (insert ?\ ))) - - ;; Stop before trailing comma-separated comment - ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. - ;; *** This case is redundant??? - ;;((eq ?, (following-char)) - ;; (setq name-done-flag t)) - - ;; Delete parenthesized/quoted comment/nickname - ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) - (setq cbeg (point)) - (set-syntax-table mail-extr-address-text-comment-syntax-table) - (cond ((memq (following-char) '(?\' ?\`)) - (or (search-forward "'" nil t - (if (eq ?\' (following-char)) 2 1)) - (mail-extr-delete-char 1))) - (t - (or (mail-extr-safe-move-sexp 1) - (goto-char (point-max))))) - (set-syntax-table mail-extr-address-text-syntax-table) - (setq cend (point)) + (if (eq word-count 0) (narrow-to-region (point) (point-max))) + (setq this-word-beg (point)) + (setq drop-this-word-if-trailing-flag nil) + + ;; Decide what to do based on what we are looking at. (cond - ;; Handle case of entire name being quoted + + ;; Delete title + ((and (eq word-count 0) + (looking-at mail-extr-full-name-prefixes)) + (goto-char (match-end 0)) + (narrow-to-region (point) (point-max))) + + ;; Stop after name suffix + ((and (>= word-count 2) + (looking-at mail-extr-full-name-suffix-pattern)) + (mail-extr-skip-whitespace-backward) + (setq suffix-flag (point)) + (if (eq ?, (following-char)) + (forward-char 1) + (insert ?,)) + ;; Enforce at least one space after comma + (or (eq ?\ (following-char)) + (insert ?\ )) + (mail-extr-skip-whitespace-forward) + (cond ((memq (following-char) '(?j ?J ?s ?S)) + (capitalize-word 1) + (if (eq (following-char) ?.) + (forward-char 1) + (insert ?.))) + (t + (upcase-word 1))) + (setq word-found-flag t) + (setq name-done-flag t)) + + ;; Handle SCA names + ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" + (goto-char (match-beginning 1)) + (narrow-to-region (point) (point-max)) + (setq begin-again-flag t)) + + ;; Check for initial last name followed by comma + ((and (eq ?, (following-char)) + (eq word-count 1)) + (forward-char 1) + (setq last-name-comma-flag t) + (or (eq ?\ (following-char)) + (insert ?\ ))) + + ;; Stop before trailing comma-separated comment + ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. + ;; *** This case is redundant??? + ;;((eq ?, (following-char)) + ;; (setq name-done-flag t)) + + ;; Delete parenthesized/quoted comment/nickname + ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) + (setq cbeg (point)) + (set-syntax-table mail-extr-address-text-comment-syntax-table) + (cond ((memq (following-char) '(?\' ?\`)) + (or (search-forward "'" nil t + (if (eq ?\' (following-char)) 2 1)) + (delete-char 1))) + (t + (or (mail-extr-safe-move-sexp 1) + (goto-char (point-max))))) + (set-syntax-table mail-extr-address-text-syntax-table) + (setq cend (point)) + (cond + ;; Handle case of entire name being quoted + ((and (eq word-count 0) + (looking-at " *\\'") + (>= (- cend cbeg) 2)) + (narrow-to-region (1+ cbeg) (1- cend)) + (goto-char (point-min))) + (t + ;; Handle case of quoted initial + (if (and (or (= 3 (- cend cbeg)) + (and (= 4 (- cend cbeg)) + (eq ?. (char-after (+ 2 cbeg))))) + (not (looking-at " *\\'"))) + (setq initial (char-after (1+ cbeg))) + (setq initial nil)) + (delete-region cbeg cend) + (if initial + (insert initial ". "))))) + + ;; Handle *Stupid* VMS date stamps + ((looking-at mail-extr-stupid-vms-date-stamp-pattern) + (replace-match "" t)) + + ;; Handle Chinese characters. + ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) + (goto-char (match-end 0)) + (setq word-found-flag t)) + + ;; Skip initial garbage characters. + ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. ((and (eq word-count 0) - (looking-at " *\\'") - (>= (- cend cbeg) 2)) - (narrow-to-region (1+ cbeg) (1- cend)) - (goto-char (point-min))) + (looking-at mail-extr-leading-garbage)) + (goto-char (match-end 0)) + ;; *** Skip backward over these??? + ;; (skip-chars-backward "& \"") + (narrow-to-region (point) (point-max))) + + ;; Various stopping points + ((or + + ;; Stop before ALL CAPS acronyms, if preceded by mixed-case + ;; words. Example: XT-DEM. + (and (>= word-count 2) + mixed-case-flag + (looking-at mail-extr-weird-acronym-pattern) + (not (looking-at mail-extr-roman-numeral-pattern))) + + ;; Stop before trailing alternative address + (looking-at mail-extr-alternative-address-pattern) + + ;; Stop before trailing comment not introduced by comma + ;; THIS CASE MUST BE AFTER AN EARLIER CASE. + (looking-at mail-extr-trailing-comment-start-pattern) + + ;; Stop before telephone numbers + (and (>= word-count 1) + (looking-at mail-extr-telephone-extension-pattern))) + (setq name-done-flag t)) + + ;; Delete ham radio call signs + ((looking-at mail-extr-ham-call-sign-pattern) + (delete-region (match-beginning 0) (match-end 0))) + + ;; Fixup initials + ((looking-at mail-extr-initial-pattern) + (or (eq (following-char) (upcase (following-char))) + (setq lower-case-flag t)) + (forward-char 1) + (if (eq ?. (following-char)) + (forward-char 1) + (insert ?.)) + (or (eq ?\ (following-char)) + (insert ?\ )) + (setq word-found-flag t)) + + ;; Handle BITNET LISTSERV list names. + ((and (eq word-count 0) + (looking-at mail-extr-listserv-list-name-pattern)) + (narrow-to-region (match-beginning 1) (match-end 1)) + (setq word-found-flag t) + (setq name-done-flag t)) + + ;; Handle & substitution, when & is last and is not first. + ((and (> word-count 0) + (eq ?\ (preceding-char)) + (eq (following-char) ?&) + (eq (1+ (point)) (point-max))) + (delete-char 1) + (capitalize-region + (point) + (progn + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (point))) + (setq disable-initial-guessing-flag t) + (setq word-found-flag t)) + + ;; Handle & between names, as in "Bob & Susie". + ((and (> word-count 0) (eq (following-char) ?\&)) + (setq name-beg (point)) + (setq name-end (1+ name-beg)) + (setq word-found-flag t) + (goto-char name-end)) + + ;; Regular name words + ((looking-at mail-extr-name-pattern) + (setq name-beg (point)) + (setq name-end (match-end 0)) + + ;; Certain words will be dropped if they are at the end. + (and (>= word-count 2) + (not lower-case-flag) + (or + ;; Trailing 4-or-more letter lowercase words preceded by + ;; mixed case or uppercase words will be dropped. + (looking-at "[[:lower:]]\\{4,\\}[ \t]*\\'") + ;; Drop a trailing word which is terminated with a period. + (eq ?. (char-after (1- name-end)))) + (setq drop-this-word-if-trailing-flag t)) + + ;; Set the flags that indicate whether we have seen a lowercase + ;; word, a mixed case word, and an uppercase word. + (if (re-search-forward "[[:lower:]]" name-end t) + (if (progn + (goto-char name-beg) + (re-search-forward "[[:upper:]]" name-end t)) + (setq mixed-case-flag t) + (setq lower-case-flag t)) + ;; (setq upper-case-flag t) + ) + + (goto-char name-end) + (setq word-found-flag t)) + + ;; Allow a number as a word, if it doesn't mean anything else. + ((looking-at "[0-9]+\\>") + (setq name-beg (point)) + (setq name-end (match-end 0)) + (goto-char name-end) + (setq word-found-flag t)) + (t - ;; Handle case of quoted initial - (if (and (or (= 3 (- cend cbeg)) - (and (= 4 (- cend cbeg)) - (eq ?. (char-after (+ 2 cbeg))))) - (not (looking-at " *\\'"))) - (setq initial (char-after (1+ cbeg))) - (setq initial nil)) - (delete-region cbeg cend) - (if initial - (insert initial ". "))))) - - ;; Handle *Stupid* VMS date stamps - ((looking-at mail-extr-stupid-vms-date-stamp-pattern) - (replace-match "" t)) - - ;; Handle Chinese characters. - ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) - (goto-char (match-end 0)) - (setq word-found-flag t)) - - ;; Skip initial garbage characters. - ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. - ((and (eq word-count 0) - (looking-at mail-extr-leading-garbage)) - (goto-char (match-end 0)) - ;; *** Skip backward over these??? - ;; (skip-chars-backward "& \"") - (narrow-to-region (point) (point-max))) - - ;; Various stopping points - ((or - - ;; Stop before ALL CAPS acronyms, if preceded by mixed-case - ;; words. Example: XT-DEM. - (and (>= word-count 2) - mixed-case-flag - (looking-at mail-extr-weird-acronym-pattern) - (not (looking-at mail-extr-roman-numeral-pattern))) - - ;; Stop before trailing alternative address - (looking-at mail-extr-alternative-address-pattern) - - ;; Stop before trailing comment not introduced by comma - ;; THIS CASE MUST BE AFTER AN EARLIER CASE. - (looking-at mail-extr-trailing-comment-start-pattern) - - ;; Stop before telephone numbers - (looking-at mail-extr-telephone-extension-pattern)) - (setq name-done-flag t)) - - ;; Delete ham radio call signs - ((looking-at mail-extr-ham-call-sign-pattern) - (delete-region (match-beginning 0) (match-end 0))) - - ;; Fixup initials - ((looking-at mail-extr-initial-pattern) - (or (eq (following-char) (upcase (following-char))) - (setq lower-case-flag t)) - (forward-char 1) - (if (eq ?. (following-char)) - (forward-char 1) - (insert ?.)) - (or (eq ?\ (following-char)) + (setq name-done-flag t) + )) + + ;; Count any word that we skipped over. + (if word-found-flag + (setq word-count (1+ word-count)))) + + ;; If the last thing in the name is 2 or more periods, or one or more + ;; other sentence terminators (but not a single period) then keep them + ;; and the preceding word. This is for the benefit of whole sentences + ;; in the name field: it's better behavior than dropping the last word + ;; of the sentence... + (if (and (not suffix-flag) + (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) + (goto-char (setq suffix-flag (point-max)))) + + ;; Drop everything after point and certain trailing words. + (narrow-to-region (point-min) + (or (and drop-last-word-if-trailing-flag + last-word-beg) + (point))) + + ;; Xerox's mailers SUCK!!!!!! + ;; We simply refuse to believe that any last name is PARC or ADOC. + ;; If it looks like that is the last name, that there is no meaningful + ;; here at all. Actually I guess it would be best to map patterns + ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't + ;; actually know that that is what's going on. + (unless suffix-flag + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") + (erase-buffer)))) + + ;; If last name first put it at end (but before suffix) + (when last-name-comma-flag + (goto-char (point-min)) + (search-forward ",") + (setq name-end (1- (point))) + (goto-char (or suffix-flag (point-max))) + (or (eq ?\ (preceding-char)) (insert ?\ )) - (setq word-found-flag t)) - - ;; Handle BITNET LISTSERV list names. - ((and (eq word-count 0) - (looking-at mail-extr-listserv-list-name-pattern)) - (narrow-to-region (match-beginning 1) (match-end 1)) - (setq word-found-flag t) - (setq name-done-flag t)) - - ;; Handle & substitution, when & is last and is not first. - ((and (> word-count 0) - (eq ?\ (preceding-char)) - (eq (following-char) ?&) - (eq (1+ (point)) (point-max))) - (mail-extr-delete-char 1) - (capitalize-region - (point) - (progn - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (point))) - (setq disable-initial-guessing-flag t) - (setq word-found-flag t)) - - ;; Handle & between names, as in "Bob & Susie". - ((and (> word-count 0) (eq (following-char) ?\&)) - (setq name-beg (point)) - (setq name-end (1+ name-beg)) - (setq word-found-flag t) - (goto-char name-end)) - - ;; Regular name words - ((looking-at mail-extr-name-pattern) - (setq name-beg (point)) - (setq name-end (match-end 0)) - - ;; Certain words will be dropped if they are at the end. - (and (>= word-count 2) - (not lower-case-flag) - (or - ;; A trailing 4-or-more letter lowercase words preceded by - ;; mixed case or uppercase words will be dropped. - (looking-at "[a-z][a-z][a-z][a-z]+[ \t]*\\'") - ;; Drop a trailing word which is terminated with a period. - (eq ?. (char-after (1- name-end)))) - (setq drop-this-word-if-trailing-flag t)) - - ;; Set the flags that indicate whether we have seen a lowercase - ;; word, a mixed case word, and an uppercase word. - (if (re-search-forward "[a-z]" name-end t) - (if (progn - (goto-char name-beg) - (re-search-forward "[A-Z]" name-end t)) - (setq mixed-case-flag t) - (setq lower-case-flag t)) -;; (setq upper-case-flag t) - ) - + (insert-buffer-substring (current-buffer) (point-min) name-end) (goto-char name-end) - (setq word-found-flag t)) - - (t - (setq name-done-flag t) - )) - - ;; Count any word that we skipped over. - (if word-found-flag - (setq word-count (1+ word-count)))) - - ;; If the last thing in the name is 2 or more periods, or one or more - ;; other sentence terminators (but not a single period) then keep them - ;; and the preceding word. This is for the benefit of whole sentences - ;; in the name field: it's better behavior than dropping the last word - ;; of the sentence... - (if (and (not suffix-flag) - (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) - (goto-char (setq suffix-flag (point-max)))) - - ;; Drop everything after point and certain trailing words. - (narrow-to-region (point-min) - (or (and drop-last-word-if-trailing-flag - last-word-beg) - (point))) - - ;; Xerox's mailers SUCK!!!!!! - ;; We simply refuse to believe that any last name is PARC or ADOC. - ;; If it looks like that is the last name, that there is no meaningful - ;; here at all. Actually I guess it would be best to map patterns - ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't - ;; actually know that that is what's going on. - (cond ((not suffix-flag) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") - (erase-buffer))))) - - ;; If last name first put it at end (but before suffix) - (cond (last-name-comma-flag - (goto-char (point-min)) - (search-forward ",") - (setq name-end (1- (point))) - (goto-char (or suffix-flag (point-max))) - (or (eq ?\ (preceding-char)) - (insert ?\ )) - (insert-buffer-substring (current-buffer) (point-min) name-end) - (goto-char name-end) - (skip-chars-forward "\t ,") - (narrow-to-region (point) (point-max)))) - - ;; Delete leading and trailing junk characters. - ;; *** This is probably completely unneeded now. - ;;(goto-char (point-max)) - ;;(skip-chars-backward mail-extr-non-end-name-chars) - ;;(if (eq ?. (following-char)) - ;; (forward-char 1)) - ;;(narrow-to-region (point) - ;; (progn - ;; (goto-char (point-min)) - ;; (skip-chars-forward mail-extr-non-begin-name-chars) - ;; (point))) - - ;; Compress whitespace - (goto-char (point-min)) - (while (re-search-forward "[ \t\n]+" nil t) - (replace-match (if (eobp) "" " ") t)) - ))) + (skip-chars-forward "\t ,") + (narrow-to-region (point) (point-max))) + + ;; Delete leading and trailing junk characters. + ;; *** This is probably completely unneeded now. + ;;(goto-char (point-max)) + ;;(skip-chars-backward mail-extr-non-end-name-chars) + ;;(if (eq ?. (following-char)) + ;; (forward-char 1)) + ;;(narrow-to-region (point) + ;; (progn + ;; (goto-char (point-min)) + ;; (skip-chars-forward mail-extr-non-begin-name-chars) + ;; (point))) + + ;; Compress whitespace + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]+" nil t) + (replace-match (if (eobp) "" " ") t)) + )))) @@ -1851,29 +1837,41 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;; Keep in mind that the country abbreviations follow ISO-3166. There is ;; a U.S. FIPS that specifies a different set of two-letter country ;; abbreviations. +;; +;; Updated by the RIPE Network Coordination Centre. +;; +;; Source: ISO 3166 Maintenance Agency +;; http://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1-semic.txt +;; http://www.iana.org/domain-names.htm +;; http://www.iana.org/cctld/cctld-whois.htm +;; Latest change: Mon Jul 8 14:21:59 CEST 2002 (defconst mail-extr-all-top-level-domains - (let ((ob (make-vector 509 0))) - (mapcar - (function - (lambda (x) - (put (intern (downcase (car x)) ob) - 'domain-name - (if (nth 2 x) - (format (nth 2 x) (nth 1 x)) - (nth 1 x))))) + (let ((ob (make-vector 739 0))) + (mapc + (lambda (x) + (put (intern (downcase (car x)) ob) + 'domain-name + (if (nth 2 x) + (format (nth 2 x) (nth 1 x)) + (nth 1 x)))) '( ;; ISO 3166 codes: ("ad" "Andorra") ("ae" "United Arab Emirates") + ("af" "Afghanistan") ("ag" "Antigua and Barbuda") + ("ai" "Anguilla") ("al" "Albania") ("am" "Armenia") + ("an" "Netherlands Antilles") ("ao" "Angola") ("aq" "Antarctica") ; continent ("ar" "Argentina" "Argentine Republic") + ("as" "American Samoa") ("at" "Austria" "The Republic of %s") ("au" "Australia") + ("aw" "Aruba") ("az" "Azerbaijan") ("ba" "Bosnia-Herzegovina") ("bb" "Barbados") @@ -1882,27 +1880,38 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ("bf" "Burkina Faso") ("bg" "Bulgaria") ("bh" "Bahrain") + ("bi" "Burundi") + ("bj" "Benin") ("bm" "Bermuda") + ("bn" "Brunei Darussalam") ("bo" "Bolivia" "Republic of %s") ("br" "Brazil" "The Federative Republic of %s") ("bs" "Bahamas") + ("bt" "Bhutan") + ("bv" "Bouvet Island") ("bw" "Botswana") ("by" "Belarus") ("bz" "Belize") ("ca" "Canada") + ("cc" "Cocos (Keeling) Islands") + ("cd" "Congo" "The Democratic Republic of the %s") + ("cf" "Central African Republic") ("cg" "Congo") ("ch" "Switzerland" "The Swiss Confederation") - ("ci" "Ivory Coast") + ("ci" "Ivory Coast") ; Cote D'ivoire + ("ck" "Cook Islands") ("cl" "Chile" "The Republic of %s") ("cm" "Cameroon") ; In .fr domain ("cn" "China" "The People's Republic of %s") ("co" "Colombia") ("cr" "Costa Rica" "The Republic of %s") - ("cs" "Czechoslovakia") ("cu" "Cuba") + ("cv" "Cape Verde") + ("cx" "Christmas Island") ("cy" "Cyprus") ("cz" "Czech Republic") ("de" "Germany") + ("dj" "Djibouti") ("dk" "Denmark") ("dm" "Dominica") ("do" "Dominican Republic" "The %s") @@ -1910,25 +1919,36 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ("ec" "Ecuador" "The Republic of %s") ("ee" "Estonia") ("eg" "Egypt" "The Arab Republic of %s") + ("eh" "Western Sahara") ("er" "Eritrea") ("es" "Spain" "The Kingdom of %s") ("et" "Ethiopia") ("fi" "Finland" "The Republic of %s") + ("fj" "Fiji") + ("fk" "Falkland Islands (Malvinas)") + ("fm" "Micronesia" "Federated States of %s") ("fo" "Faroe Islands") ("fr" "France") ("ga" "Gabon") ("gb" "United Kingdom") ("gd" "Grenada") ("ge" "Georgia") - ("gf" "Guyana (Fr.)") - ("gj" "Fiji") + ("gf" "French Guiana") + ("gh" "Ghana") + ("gi" "Gibraltar") ("gl" "Greenland") ("gm" "Gambia") + ("gn" "Guinea") ("gp" "Guadeloupe (Fr.)") + ("gq" "Equatorial Guinea") ("gr" "Greece" "The Hellenic Republic (%s)") + ("gs" "South Georgia and The South Sandwich Islands") ("gt" "Guatemala") ("gu" "Guam (U.S.)") + ("gw" "Guinea-Bissau") + ("gy" "Guyana") ("hk" "Hong Kong") + ("hm" "Heard Island and Mcdonald Islands") ("hn" "Honduras") ("hr" "Croatia" "Croatia (Hrvatska)") ("ht" "Haiti") @@ -1936,112 +1956,170 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ("id" "Indonesia") ("ie" "Ireland") ("il" "Israel" "The State of %s") - ("im" "Isle of Man" "The %s") + ("im" "Isle of Man" "The %s") ; NOT in ISO 3166-1 of 2001-02-26 ("in" "India" "The Republic of %s") - ("ir" "Iran") + ("io" "British Indian Ocean Territory") + ("iq" "Iraq") + ("ir" "Iran" "Islamic Republic of %s") ("is" "Iceland" "The Republic of %s") ("it" "Italy" "The Italian Republic") ("jm" "Jamaica") ("jo" "Jordan") ("jp" "Japan") ("ke" "Kenya") - ("kn" "St. Kitts, Nevis, and Anguilla") - ("kp" "Korea (North)") - ("kr" "Korea (South)") + ("kg" "Kyrgyzstan") + ("kh" "Cambodia") + ("ki" "Kiribati") + ("km" "Comoros") + ("kn" "Saint Kitts and Nevis") + ("kp" "Korea (North)" "Democratic People's Republic of Korea") + ("kr" "Korea (South)" "Republic of Korea") ("kw" "Kuwait") + ("ky" "Cayman Islands") ("kz" "Kazakhstan") + ("la" "Lao People's Democratic Republic") ("lb" "Lebanon") - ("lc" "St. Lucia") + ("lc" "Saint Lucia") ("li" "Liechtenstein") ("lk" "Sri Lanka" "The Democratic Socialist Republic of %s") + ("lr" "Liberia") ("ls" "Lesotho") ("lt" "Lithuania") ("lu" "Luxembourg") ("lv" "Latvia") + ("ly" "Libyan Arab Jamahiriya") ("ma" "Morocco") ("mc" "Monaco") ("md" "Moldova" "The Republic of %s") ("mg" "Madagascar") - ("mk" "Macedonia") + ("mh" "Marshall Islands") + ("mk" "Macedonia" "The Former Yugoslav Republic of %s") ("ml" "Mali") - ("mo" "Macau") + ("mm" "Myanmar") + ("mn" "Mongolia") + ("mo" "Macao") + ("mp" "Northern Mariana Islands") + ("mq" "Martinique") + ("mr" "Mauritania") + ("ms" "Montserrat") ("mt" "Malta") ("mu" "Mauritius") ("mv" "Maldives") ("mw" "Malawi") ("mx" "Mexico" "The United Mexican States") - ("my" "Malaysia" "%s (changed to Myanmar?)") ;??? + ("my" "Malaysia") ("mz" "Mozambique") ("na" "Namibia") ("nc" "New Caledonia (Fr.)") ("ne" "Niger") ; In .fr domain + ("nf" "Norfolk Island") + ("ng" "Nigeria") ("ni" "Nicaragua" "The Republic of %s") ("nl" "Netherlands" "The Kingdom of the %s") ("no" "Norway" "The Kingdom of %s") ("np" "Nepal") ; Via .in domain + ("nr" "Nauru") ("nu" "Niue") ("nz" "New Zealand") + ("om" "Oman") ("pa" "Panama") ("pe" "Peru") - ("pf" "Polynesia (Fr.)") + ("pf" "French Polynesia") ("pg" "Papua New Guinea") ("ph" "Philippines" "The Republic of the %s") ("pk" "Pakistan") ("pl" "Poland") + ("pm" "Saint Pierre and Miquelon") + ("pn" "Pitcairn") ("pr" "Puerto Rico (U.S.)") + ("ps" "Palestinian Territory, Occupied") ("pt" "Portugal" "The Portuguese Republic") + ("pw" "Palau") ("py" "Paraguay") ("qa" "Qatar") ("re" "Reunion (Fr.)") ; In .fr domain ("ro" "Romania") - ("ru" "Russian Federation") + ("ru" "Russia" "Russian Federation") + ("rw" "Rwanda") ("sa" "Saudi Arabia") + ("sb" "Solomon Islands") ("sc" "Seychelles") ("sd" "Sudan") ("se" "Sweden" "The Kingdom of %s") ("sg" "Singapore" "The Republic of %s") + ("sh" "Saint Helena") ("si" "Slovenia") - ("sj" "Svalbard and Jan Mayen Is.") ; In .no domain + ("sj" "Svalbard and Jan Mayen") ; In .no domain ("sk" "Slovakia" "The Slovak Republic") + ("sl" "Sierra Leone") ("sm" "San Marino") ("sn" "Senegal") + ("so" "Somalia") ("sr" "Suriname") - ("su" "U.S.S.R." "The Union of Soviet Socialist Republics") + ("st" "Sao Tome and Principe") + ("su" "U.S.S.R." "The Union of Soviet Socialist Republics") + ("sv" "El Salvador") + ("sy" "Syrian Arab Republic") ("sz" "Swaziland") + ("tc" "Turks and Caicos Islands") + ("td" "Chad") + ("tf" "French Southern Territories") ("tg" "Togo") ("th" "Thailand" "The Kingdom of %s") - ("tm" "Turkmenistan") ; In .su domain + ("tj" "Tajikistan") + ("tk" "Tokelau") + ("tl" "East Timor") + ("tm" "Turkmenistan") ("tn" "Tunisia") ("to" "Tonga") + ("tp" "East Timor") ("tr" "Turkey" "The Republic of %s") ("tt" "Trinidad and Tobago") - ("tw" "Taiwan") + ("tv" "Tuvalu") + ("tw" "Taiwan" "%s, Province of China") + ("tz" "Tanzania" "United Republic of %s") ("ua" "Ukraine") + ("ug" "Uganda") ("uk" "United Kingdom" "The %s of Great Britain and Northern Ireland") + ("um" "United States Minor Outlying Islands") ("us" "United States" "The %s of America") ("uy" "Uruguay" "The Eastern Republic of %s") - ("vc" "St. Vincent and the Grenadines") + ("uz" "Uzbekistan") + ("va" "Holy See (Vatican City State)") + ("vc" "Saint Vincent and the Grenadines") ("ve" "Venezuela" "The Republic of %s") - ("vi" "Virgin Islands (U.S.)") + ("vg" "Virgin Islands, British") + ("vi" "Virgin Islands, U.S.") ("vn" "Vietnam") ("vu" "Vanuatu") + ("wf" "Wallis and Futuna") + ("ws" "Samoa") + ("ye" "Yemen") + ("yt" "Mayotte") ("yu" "Yugoslavia" "Yugoslavia, AKA Serbia-Montenegro") ("za" "South Africa" "The Republic of %s") + ("zm" "Zambia") ("zw" "Zimbabwe" "Republic of %s") - ;; Special top-level domains: - ("arpa" t "Advanced Research Projects Agency (U.S. DoD)") - ("bitnet" t "Because It's Time NET") + ;; Generic Domains: + ("aero" t "Air Transport Industry") + ("biz" t "Businesses") ("com" t "Commercial") - ("edu" t "Educational") - ("gov" t "Government (U.S.)") - ("int" t "International (NATO)") - ("mil" t "Military (U.S.)") - ("nato" t "North Atlantic Treaty Organization") + ("coop" t "Cooperative Associations") + ("info" t "Info") + ("museum" t "Museums") + ("name" t "Individuals") ("net" t "Network") ("org" t "Non-profit Organization") - ;;("unter-dom" t "? (Ger.)") + ;;("pro" t "Credentialed professionals") + ;;("bitnet" t "Because It's Time NET") + ("gov" t "United States Government") + ("edu" t "Educational") + ("mil" t "United States Military") + ("int" t "International Treaties") + ;;("nato" t "North Atlantic Treaty Organization") ("uucp" t "Unix to Unix CoPy") - ;;("fipnet" nil "?") + ;; Infrastructure Domains: + ("arpa" t "Advanced Research Projects Agency (U.S. DoD)") )) ob)) @@ -2060,7 +2138,7 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible ;(let ((all nil)) ; (mapatoms #'(lambda (x) -; (if (and (boundp x) +; (if (and (boundp x) ; (string-match "^mail-extr-" (symbol-name x))) ; (setq all (cons x all))))) ; (setq all (sort all #'string-lessp)) @@ -2072,4 +2150,5 @@ ADDRESS may be a string or a buffer. If it is a buffer, the visible (provide 'mail-extr) +;;; arch-tag: 7785fade-1073-4ed6-b4f6-28db34a7982d ;;; mail-extr.el ends here