;;; mail-extr.el --- extract full name and address from RFC 822 mail header.

;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.

;; Author: Joe Wells <jbw@cs.bu.edu>
;; Maintainer: Jamie Zawinski <jwz@lucid.com>
;; Version: 1.2
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; The entry point of this code is
;;
;;    mail-extract-address-components: (address)
;;  
;;    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 
;;     (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.)
;;    If ADDRESS contains more than one RFC-822 address, only the first is
;;     returned.
;;
;; This code is more correct (and more heuristic) parser than the code in
;; rfc822.el.  And despite its size, it's fairly fast.
;;
;; There are two main benefits:
;;
;; 1. Higher probability of getting the correct full name for a human than
;;    any other package we know of.  (On the other hand, it will cheerfully
;;    mangle non-human names/comments.)
;; 2. Address part is put in a canonical form.
;;
;; The interface is not yet carved in stone; please give us suggestions.
;;
;; We have an extensive test-case collection of funny addresses if you want to
;; work with the code.  Developing this code requires frequent testing to
;; 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 
;; 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 
;; mail-extr would return the comment as-is.
;;
;; Features:
;;
;; * Full name handling:
;;
;;   * knows where full names can be found in an address.
;;   * avoids using empty comments and quoted text.
;;   * extracts full names from mailbox names.
;;   * recognizes common formats for comments after a full name.
;;   * puts a period and a space after each initial.
;;   * understands & referring to the mailbox name, capitalized.
;;   * strips name prefixes like "Prof.", etc.
;;   * understands what characters can occur in names (not just letters).
;;   * figures out middle initial from mailbox name.
;;   * removes funny nicknames.
;;   * keeps suffixes such as Jr., Sr., III, etc.
;;   * reorders "Last, First" type names.
;;
;; * Address handling:
;;
;;   * parses rfc822 quoted text, comments, and domain literals.
;;   * parses rfc822 multi-line headers.
;;   * does something reasonable with rfc822 GROUP addresses.
;;   * handles many rfc822 noncompliant and garbage addresses.
;;   * canonicalizes addresses (after stripping comments/phrases outside <>).
;;     * converts ! addresses into .UUCP and %-style addresses.
;;     * converts rfc822 ROUTE addresses to %-style addresses.
;;     * truncates %-style addresses at leftmost fully qualified domain name.
;;     * handles local relative precedence of ! vs. % and @ (untested).
;;
;; It does almost no string creation.  It primarily uses the built-in
;; parsing routines with the appropriate syntax tables.  This should
;; result in greater speed.
;;
;; TODO:
;;
;; * handle all test cases.  (This will take forever.)
;; * software to pick the correct header to use (eg., "Senders-Name:").
;; * multiple addresses in the "From:" header (almost all of the necessary
;;   code is there).
;; * flag to not treat `,' as an address separator.  (This is useful when
;;   there is a "From:" header but no "Sender:" header, because then there
;;   is only allowed to be one address.)
;; * mailbox name does not necessarily contain full name.
;; * fixing capitalization when it's all upper or lowercase.  (Hard!)
;; * some of the domain literal handling is missing.  (But I've never even
;;   seen one of these in a mail address, so maybe no big deal.)
;; * arrange to have syntax tables byte-compiled.
;; * speed hacks.
;; * delete unused variables.
;; * arrange for testing with different relative precedences of ! vs. @
;;   and %.
;; * insert documentation strings!
;; * handle X.400-gatewayed addresses according to RFC 1148.

;;; Change Log: 
;; 
;; Thu Dec 16 21:56:45 1993  Jamie Zawinski (jwz@lucid.com)
;;
;;      * some more cleanup, doc, added provide
;;
;; Fri Apr 24 23:35:56 1992  Jamie Zawinski (jwz@lucid.com)
;;
;;      * fixed a bunch of bugs, minor cleanup
;;
;; 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.

;;; Code:

;; Variable definitions.

(defvar mail-extr-guess-middle-initial nil
  "*If true, then when we see an address like \"John Smith <jqs@host.com>\"
we will assume that \"John Q. Smith\" is the fellow's name.")

(defvar mail-extr-mangle-uucp nil
  "*If true, then bang-paths like \"foo!bar!baz@host\" will be turned 
into \"baz@bar.UUCP\".")


(defvar mail-extr-@-binds-tighter-than-! nil)

;;----------------------------------------------------------------------
;; what orderings are meaningful?????
;;(defvar mail-operator-precedence-list '(?! ?% ?@))
;; Right operand of a % or a @ must be a domain name, period.  No other
;; operators allowed.  Left operand of a @ is an address relative to that
;; site.

;; Left operand of a ! must be a domain name.  Right operand is an
;; arbitrary address.
;;----------------------------------------------------------------------


;; Characters which can compose names in RFC822 addresses:
;; Though it is not strictly RFC822-legal, we also accept any character with
;; the high bit set, in deference to Latin1 and other sundry character sets.

;; Any character that can start a name
;; #### (go to \376 instead of \377 to work around bug in search.c...)
(defconst mail-extr-first-letters (purecopy "A-Za-z\200-\376"))

;; Any character that can end a name.
(defconst mail-extr-last-letters
  (purecopy (concat mail-extr-first-letters "`'.")))

;; Any character that can occur in a name, not counting characters that
;; separate parts of a multipart name.  (Yes, there are weird people with
;; digits in their names.)
(defconst mail-extr-all-letters-but-separators
  (purecopy (concat mail-extr-first-letters "`'{|}~0-9")))

;; Any character that can occur in a name.
(defconst mail-extr-all-letters
  (purecopy (concat mail-extr-all-letters-but-separators ".---")))

;; Matches an initial not followed by both a period and a space. 
;(defconst mail-extr-bad-initials-pattern
;  (purecopy
;   (format
;    "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)"
;    mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters)))

;(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 periods used instead of spaces.  Must not match the period
;; following an initial.
(defconst mail-extr-bad-dot-pattern
  (purecopy
   (format "\\([%s][%s]\\)\\.+\\([%s]\\)"
	   mail-extr-all-letters
	   mail-extr-last-letters
	   mail-extr-first-letters)))

;; Matches an embedded or leading nickname that should be removed.
;(defconst mail-extr-nickname-pattern
;  (purecopy
;   (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] "
;	   mail-extr-all-letters)))

;; Matches a leading title that is not part of the name (does not
;; contribute to uniquely identifying the person).
(defconst mail-extr-full-name-prefixes
  (purecopy
   '"\\` *\\(Prof\\|Dr\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.? "))

;; Matches the occurrence of a generational name suffix, and the last
;; character of the preceding name.
(defconst mail-extr-full-name-suffix-pattern
  (purecopy
   (format
    "\\(,? ?\\([JjSs]r\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)"
    mail-extr-all-letters mail-extr-all-letters)))

(defconst mail-extr-roman-numeral-pattern
  (purecopy "V?I+V?\\b"))

;; Matches a trailing uppercase (with other characters possible) acronym.
;; Must not match a trailing uppercase last name or trailing initial
;; #### Match Latin1 upper case letters here too?
(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
;  (purecopy
;   (format
;    "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)"
;    mail-extr-all-letters mail-extr-last-letters
;    mail-extr-first-letters mail-extr-all-letters mail-extr-all-letters
;    mail-extr-last-letters
;    mail-extr-first-letters mail-extr-all-letters)))

;; Matches a trailing alternative address.
;; #### Match Latin1 letters here too?
;; #### Match _ before @ here too?  
(defconst mail-extr-alternative-address-pattern
  (purecopy "[a-zA-Z.]+[!@][a-zA-Z.]"))

;; Matches a variety of trailing comments not including comma-delimited
;; comments.
(defconst mail-extr-trailing-comment-start-pattern
  (purecopy " [-{]\\|--\\|[+@#></\;]"))

;; Matches a name (not an initial).
;; This doesn't force a word boundary at the end because sometimes a
;; comment is separated by a `-' with no preceding space.
(defconst mail-extr-name-pattern
  (purecopy (format "\\b[%s][%s]*[%s]"
		    mail-extr-first-letters
		    mail-extr-all-letters
		    mail-extr-last-letters)))

(defconst mail-extr-initial-pattern
  (purecopy (format "\\b[%s]\\([. ]\\|\\b\\)" mail-extr-first-letters)))

;; Matches a single name before a comma.
;(defconst mail-extr-last-name-first-pattern
;  (purecopy (concat "\\`" mail-extr-name-pattern ",")))

;; Matches telephone extensions.
(defconst mail-extr-telephone-extension-pattern
  (purecopy "\\(\\([Ee]xt\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+"))

;; Matches ham radio call signs.
(defconst mail-extr-ham-call-sign-pattern
  (purecopy "\\b[A-Z]+[0-9][A-Z0-9]*"))

;; Matches normal single-part name
(defconst mail-extr-normal-name-pattern
  (purecopy (format "\\b[%s][%s]+[%s]"
		    mail-extr-first-letters
		    mail-extr-all-letters-but-separators
		    mail-extr-last-letters)))

;; Matches normal two names with missing middle initial
(defconst mail-extr-two-name-pattern
  (purecopy
   (format "\\`\\(%s\\|%s\\) +\\(%s\\)\\(,\\|\\'\\)"
	   mail-extr-normal-name-pattern
	   mail-extr-initial-pattern
	   mail-extr-normal-name-pattern)))

(defconst mail-extr-address-syntax-table (make-syntax-table))
(defconst mail-extr-address-comment-syntax-table (make-syntax-table))
(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)))))
 '((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
    (?\t " ")
    (?\r " ")
    (?\n " ")
    (?\( ".")
    (?\) ".")
    (?<  ".")
    (?>  ".")
    (?@  ".")
    (?,  ".")
    (?\; ".")
    (?:  ".")
    (?\\ "\\")
    (?\" "\"")
    (?.  ".")
    (?\[ ".")
    (?\] ".")
    ;; % and ! aren't RFC822 characters, but it is convenient to pretend
    (?%  ".")
    (?!  ".") ;; this needs to be word-constituent when not in .UUCP mode
    )
   (mail-extr-address-comment-syntax-table
    (?\000 ?\377 "w")
    (?\040 " ")
    (?\t " ")
    (?\r " ")
    (?\n " ")
    (?\( "\(\)")
    (?\) "\)\(")
    (?\\ "\\"))
   (mail-extr-address-domain-literal-syntax-table
    (?\000 ?\377 "w")
    (?\040 " ")
    (?\t " ")
    (?\r " ")
    (?\n " ")
    (?\[ "\(\]")			;??????
    (?\] "\)\[")			;??????
    (?\\ "\\"))
   (mail-extr-address-text-comment-syntax-table
    (?\000 ?\377 "w")
    (?\040 " ")
    (?\t " ")
    (?\r " ")
    (?\n " ")
    (?\( "\(\)")
    (?\) "\)\(")
    (?\[ "\(\]")
    (?\] "\)\[")
    (?\{ "\(\}")
    (?\} "\)\{")
    (?\\ "\\")
    (?\" "\"")
    ;; (?\' "\)\`")
    ;; (?\` "\(\'")
    )
   (mail-extr-address-text-syntax-table
    (?\000 ?\377 ".")
    (?\040 " ")
    (?\t " ")
    (?\r " ")
    (?\n " ")
    (?A ?Z "w")
    (?a ?z "w")
    (?-    "w")
    (?\}   "w")
    (?\{   "w")
    (?|    "w")
    (?\'   "w")
    (?~    "w")
    (?0 ?9 "w"))
   ))


;; 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)))

(defmacro mail-extr-skip-whitespace-forward ()
  ;; #### compile-time dependence on v18/v19
  (if (fboundp 'skip-syntax-forward)
      '(skip-syntax-forward " ")
    '(skip-chars-forward " \t\n")))

(defmacro mail-extr-skip-whitespace-backward ()
  ;; #### compile-time dependence on v18/v19
  (if (fboundp 'skip-syntax-backward)
      '(skip-syntax-backward " ")
    '(skip-chars-backward " \t\n")))


(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))
       (delete-region (point) (1+ (point)))
       (insert ?\ ))))

(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.
  (or (memq no-replace '(t nil))
      (error "no-replace must be t or nil, evalable at macroexpand-time."))
  (` (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)))
	 (setq temp (cdr temp)))
       (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.
  ;; otherwise returns the arg.
  (if (markerp marker)
      (let ((temp (marker-position marker)))
	(set-marker marker nil)
	temp)
    marker))

(defun mail-extr-markerize (pos)
  ;; coerces pos to a marker if non-nil.
  (if (or (markerp pos) (null pos))
      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)
  ;; Safely skip over one balanced sexp, if there is one.  Return t if success.
  (` (condition-case error
	 (progn
	   (goto-char (scan-sexps (point) (, arg)))
	   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))))))))

(or (fboundp 'buffer-disable-undo) ;; v18 compat
    (fset 'buffer-disable-undo 'buffer-flush-undo))


;; The main function to grind addresses

;;;###autoload
(defun mail-extract-address-components (address)
  "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 
 (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.)
If ADDRESS contains more than one RFC-822 address, only the first is
 returned.  Some day this function may be extended to extract multiple
 addresses, or perhaps return the position at which parsing stopped."
  (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
	(extraction-buffer (get-buffer-create " *extract address components*"))
	char
;;	multiple-addresses
	<-pos >-pos @-pos :-pos ,-pos !-pos %-pos \;-pos
	group-:-pos group-\;-pos route-addr-:-pos
	record-pos-symbol
	first-real-pos last-real-pos
	phrase-beg phrase-end
	comment-beg comment-end
	quote-beg quote-end
	atom-beg atom-end
	mbox-beg mbox-end
	\.-ends-name
	temp
;;	name-suffix
	fi mi li
	saved-%-pos saved-!-pos saved-@-pos
	domain-pos \.-pos insert-point)
    
    (save-excursion
      (set-buffer extraction-buffer)
      (fundamental-mode)
      (kill-all-local-variables)
      (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 ?\ )
      (cond ((bufferp address)
	     (insert-buffer address))
	    (t (insert address)))
      
      ;; stolen from rfc822.el
      ;; Unfold multiple lines.
      (goto-char (point-min))
      (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
	(replace-match "\\1 " t))
      
      ;; first pass grabs useful information about address
      (goto-char (point-min))
      (while (progn
	       (mail-extr-skip-whitespace-forward)
	       (not (eobp)))
	(setq char (char-after (point)))
	(or first-real-pos
	    (if (not (eq char ?\())
		(setq first-real-pos (point))))
	(cond
	 ;; comment
	 ((eq char ?\()
	  (set-syntax-table mail-extr-address-comment-syntax-table)
	  ;; only record the first non-empty comment's position
	  (if (and (not comment-beg)
		   (save-excursion
		     (forward-char 1)
		     (mail-extr-skip-whitespace-forward)
		     (not (eq ?\) (char-after (point))))))
	      (setq comment-beg (point)))
	  ;; TODO: don't record if unbalanced
	  (or (mail-extr-safe-move-sexp 1)
	      (forward-char 1))
	  (set-syntax-table mail-extr-address-syntax-table)
	  (if (and comment-beg
		   (not comment-end))
	      (setq comment-end (point))))
	 ;; quoted text
	 ((eq char ?\")
	  ;; only record the first non-empty quote's position
	  (if (and (not quote-beg)
		   (save-excursion
		     (forward-char 1)
		     (mail-extr-skip-whitespace-forward)
		     (not (eq ?\" (char-after (point))))))
	      (setq quote-beg (point)))
	  ;; TODO: don't record if unbalanced
	  (or (mail-extr-safe-move-sexp 1)
	      (forward-char 1))
	  (if (and quote-beg
		   (not quote-end))
	      (setq quote-end (point))))
	 ;; domain literals
	 ((eq char ?\[)
	  (set-syntax-table mail-extr-address-domain-literal-syntax-table)
	  (or (mail-extr-safe-move-sexp 1)
	      (forward-char 1))
	  (set-syntax-table mail-extr-address-syntax-table))
	 ;; commas delimit addresses when outside < > pairs.
	 ((and (eq char ?,)
	       (or (null <-pos)
		   (and >-pos
			;; handle weird munged addresses
			(< (mail-extr-last <-pos) (car >-pos)))))
;; It'd be great if some day this worked, but for now, punt.
;;	  (setq multiple-addresses t)
;;	  (mail-extr-delete-char 1)
;;	  (narrow-to-region (point-min) (point))
	  (delete-region (point) (point-max))
	  (setq char ?\() ; HAVE I NO SHAME??
	  )
	 ;; record the position of various interesting chars, determine
	 ;; legality later.
	 ((setq record-pos-symbol
		(cdr (assq char
			   '((?< . <-pos) (?> . >-pos) (?@ . @-pos)
			     (?: . :-pos) (?, . ,-pos) (?! . !-pos)
			     (?% . %-pos) (?\; . \;-pos)))))
	  (set record-pos-symbol
	       (cons (point) (symbol-value record-pos-symbol)))
	  (forward-char 1))
	 ((eq char ?.)
	  (forward-char 1))
	 ((memq char '(
		       ;; comment terminator illegal
		       ?\)
		       ;; domain literal terminator illegal
		       ?\]
		       ;; \ allowed only within quoted strings,
		       ;; domain literals, and comments
		       ?\\
		       ))
	  (mail-extr-nuke-char-at (point))
	  (forward-char 1))
	 (t
	  (forward-word 1)))
	(or (eq char ?\()
	    (setq last-real-pos (point))))
      
      ;; Use only the leftmost <, if any.  Replace all others with spaces.
      (while (cdr <-pos)
	(mail-extr-nuke-char-at (car <-pos))
	(setq <-pos (cdr <-pos)))
      
      ;; Use only the rightmost >, if any.  Replace all others with spaces.
      (while (cdr >-pos)
	(mail-extr-nuke-char-at (nth 1 >-pos))
	(setcdr >-pos (nthcdr 2 >-pos)))
      
      ;; If multiple @s and a :, but no < and >, insert around buffer.
      ;; This commonly happens on the UUCP "From " line.  Ugh.
      (cond ((and (> (length @-pos) 1)
		  :-pos			;TODO: check if between @s
		  (not <-pos))
	     (goto-char (point-min))
	     (mail-extr-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 ?>)))
      
      ;; If > but no <, replace > with space.
      (cond ((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)
	    <-pos (car <-pos))
      
      ;; 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)))
      
      ;; Check for : that indicates GROUP list and for : part of
      ;; ROUTE-ADDR spec.
      ;; Can't possibly be more than two :.  Nuke any extra.
      (while :-pos
	(setq temp (car :-pos)
	      :-pos (cdr :-pos))
	(cond ((and <-pos >-pos
		    (> temp <-pos)
		    (< temp >-pos))
	       (if (or route-addr-:-pos
		       (< (length @-pos) 2)
		       (> temp (car @-pos))
		       (< temp (nth 1 @-pos)))
		   (mail-extr-nuke-char-at temp)
		 (setq route-addr-:-pos temp)))
	      ((or (not <-pos)
		   (and <-pos
			(< temp <-pos)))
	       (setq group-:-pos temp))))
      
      ;; Nuke any ; that is in or to the left of a < > pair or to the left
      ;; of a GROUP starting :.  Also, there may only be one ;.
      (while \;-pos
	(setq temp (car \;-pos)
	      \;-pos (cdr \;-pos))
	(cond ((and <-pos >-pos
		    (> temp <-pos)
		    (< temp >-pos))
	       (mail-extr-nuke-char-at temp))
	      ((and (or (not group-:-pos)
			(> temp group-:-pos))
		    (not group-\;-pos))
	       (setq group-\;-pos temp))))
      
      ;; Handle junk like ";@host.company.dom" that sendmail adds.
      ;; **** should I remember comment positions?
      (and 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)
	   (mail-extr-nuke-outside-range %-pos group-:-pos group-\;-pos t)
	   (mail-extr-nuke-outside-range ,-pos group-:-pos group-\;-pos t)
	   (and last-real-pos
		(> last-real-pos (1+ group-\;-pos))
		(setq last-real-pos (1+ group-\;-pos)))
	   (and comment-end
		(> comment-end group-\;-pos)
		(setq comment-end nil
		      comment-beg nil))
	   (and quote-end
		(> quote-end group-\;-pos)
		(setq quote-end nil
		      quote-beg nil))
	   (narrow-to-region (point-min) group-\;-pos))
      
      ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
      ;; others.
      ;; Hell, go ahead an 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 ,-pos 1 1)
      
      ;; can only have multiple @s inside < >.  The fact that some MTAs
      ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is
      ;; 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))))
      
      ;; 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))))
      
      ;; de-listify @-pos
      (setq @-pos (car @-pos))
      
      ;; TODO: remove comments in the middle of an address
      
      (set-buffer canonicalization-buffer)
      (fundamental-mode)
      (kill-all-local-variables)
      (buffer-disable-undo canonicalization-buffer)
      (set-syntax-table mail-extr-address-syntax-table)
      (setq case-fold-search nil)
      
      (widen)
      (erase-buffer)
      (insert-buffer-substring extraction-buffer)
      
      (if <-pos
	  (narrow-to-region (progn
			      (goto-char (1+ <-pos))
			      (mail-extr-skip-whitespace-forward)
			      (point))
			    >-pos)
	;; ****** Oh no!  What if the address is completely empty!
	;; well, don't lose totally. -jwz
	(if first-real-pos
	    (narrow-to-region first-real-pos last-real-pos)
	  (narrow-to-region 1 1)))
      
      (and @-pos %-pos
	   (mail-extr-nuke-outside-range %-pos (point-min) @-pos))
      (and %-pos !-pos
	   (mail-extr-nuke-outside-range !-pos (point-min) (car %-pos)))
      (and @-pos !-pos (not %-pos)
	   (mail-extr-nuke-outside-range !-pos (point-min) @-pos))
      
      ;; Error condition:?? (and %-pos (not @-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)))))
      (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))
      ;; RFC 1034 doesn't approve of this, oh well:
      (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
      (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
			     (get
			      (intern
			       (buffer-substring domain-pos (point)))
			      '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))))))
      (setq mbox-beg (point-min)
	    mbox-end (if %-pos (car %-pos)
		       (or @-pos
			   (point-max))))
      
      ;; Done canonicalizing address.
      
      (set-buffer extraction-buffer)
      
      ;; Find the full name
      
      (cond ((and phrase-beg
		  (eq quote-beg phrase-beg)
		  (<= quote-end phrase-end))
	     (narrow-to-region (1+ quote-beg) (1- quote-end))
	     (mail-extr-undo-backslash-quoting (point-min) (point-max)))
	    (phrase-beg
	     (narrow-to-region phrase-beg phrase-end))
	    (comment-beg
	     (narrow-to-region (1+ comment-beg) (1- comment-end))
	     (mail-extr-undo-backslash-quoting (point-min) (point-max)))
	    (t
	     ;; *** Work in canon buffer instead?  No, can't.  Hmm.
	     (delete-region (point-min) (point-max))
	     (insert-buffer-substring canonicalization-buffer
				      mbox-beg mbox-end)
	     (goto-char (point-min))
	     (setq \.-ends-name (search-forward "_" nil t))
	     (goto-char (point-min))

	     (if (not mail-extr-mangle-uucp)
		 (modify-syntax-entry ?! "w" (syntax-table)))
	       
	     (while (progn
		      (mail-extr-skip-whitespace-forward)
		      (not (eobp)))
	       (setq char (char-after (point)))
	       (cond
		((eq char ?\")
		 (setq quote-beg (point))
		 (or (mail-extr-safe-move-sexp 1)
		     ;; TODO: handle this error condition!!!!!
		     (forward-char 1))
		 ;; take into account deletions
		 (setq quote-end (- (point) 2))
		 (save-excursion
		   (backward-char 1)
		   (mail-extr-delete-char 1)
		   (goto-char quote-beg)
		   (mail-extr-delete-char 1))
		 (mail-extr-undo-backslash-quoting quote-beg quote-end)
		 (or (eq ?\  (char-after (point)))
		     (insert " "))
		 (setq \.-ends-name t))
		((eq char ?.)
		 (if (eq (char-after (1+ (point))) ?_)
		     (progn
		       (forward-char 1)
		       (mail-extr-delete-char 1)
		       (insert ?\ ))
		   (if \.-ends-name
		       (narrow-to-region (point-min) (point))
		     (mail-extr-delete-char 1)
		     (insert " "))))
		((memq (char-syntax char) '(?. ?\\))
		 (mail-extr-delete-char 1)
		 (insert " "))
		(t
		 (setq atom-beg (point))
		 (forward-word 1)
		 (setq atom-end (point))
		 (save-restriction
		   (narrow-to-region atom-beg atom-end)
		   (goto-char (point-min))
		   (while (re-search-forward "\\([^_]+\\)_" nil t)
		     (replace-match "\\1 "))
		   (goto-char (point-max))))))

	     ;; undo the dirty deed
	     (if (not mail-extr-mangle-uucp)
		 (modify-syntax-entry ?! "." (syntax-table)))
	     ;;
	     ;; If we derived the name from the mailbox part of the address,
	     ;; and we only got one word out of it, don't treat that as a
	     ;; name.  "foo@bar" --> (nil "foo@bar"), not ("foo" "foo@bar")
	     (if (not (search-backward " " nil t))
		 (delete-region (point-min) (point-max)))
	     ))
      
      (set-syntax-table mail-extr-address-text-syntax-table)
      
      (mail-extr-voodoo mbox-beg mbox-end canonicalization-buffer)
      (goto-char (point-min))

      ;; If name is "First Last" and userid is "F?L", then assume
      ;; the middle initial is the second letter in the userid.
      ;; initially by Jamie Zawinski <jwz@lucid.com>
      (cond ((and mail-extr-guess-middle-initial
		  (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) ". ")))))
      
;;       ;; Restore suffix
;;       (cond (name-suffix
;; 	     (goto-char (point-max))
;; 	     (insert ", " name-suffix)
;; 	     (backward-word 1)
;; 	     (cond ((memq (following-char) '(?j ?J ?s ?S))
;; 		    (capitalize-word 1)
;; 		    (or (eq (following-char) ?.)
;; 			(insert ?.)))
;; 		   (t
;; 		    (upcase-word 1)))))
      
      ;; Result
      (list (and (not (= (point-min) (point-max)))
		 (buffer-string))
	    (progn
	      (set-buffer canonicalization-buffer)
	      (and (not (= (point-min) (point-max)))
		   (buffer-string))))
      )))


(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
	comment-beg comment-end initial beg end
	)
    (save-excursion
      (set-syntax-table mail-extr-address-text-syntax-table)
      
      ;; Fix . used as space
      (goto-char (point-min))
      (while (re-search-forward mail-extr-bad-dot-pattern nil t)
	(replace-match "\\1 \\2"))

      ;; Skip any initial garbage.
      (goto-char (point-min))
      (skip-chars-forward mail-extr-non-begin-name-chars)
      (skip-chars-backward "& \"")
      (narrow-to-region (point) (point-max))
      
      (catch 'stop
	(while t
	  (mail-extr-skip-whitespace-forward)
	  
	  (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 ?\ ))
	    (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-count (1+ word-count))
	    (throw 'stop t))
	   
	   ;; Handle SCA names
	   ((looking-at "MKA \\(.+\\)")	; "Mundanely Known As"
	    (setq word-count 0)
	    (goto-char (match-beginning 1))
	    (narrow-to-region (point) (point-max)))
	   
	   ;; Various stopping points
	   ((or
	     ;; Stop before ALL CAPS acronyms, if preceded by mixed-case or
	     ;; lowercase words.  Eg. XT-DEM.
	     (and (>= word-count 2)
		  (or mixed-case-flag lower-case-flag)
		  (looking-at mail-extr-weird-acronym-pattern)
		  (not (looking-at mail-extr-roman-numeral-pattern)))
	     ;; Stop before 4-or-more letter lowercase words preceded by
	     ;; mixed case or uppercase words.
	     (and (>= word-count 2)
		  (or upper-case-flag mixed-case-flag)
		  (looking-at "[a-z][a-z][a-z][a-z]+\\b"))
	     ;; Stop before trailing alternative address
	     (looking-at mail-extr-alternative-address-pattern)
	     ;; Stop before trailing comment not introduced by comma
	     (looking-at mail-extr-trailing-comment-start-pattern)
	     ;; Stop before telephone numbers
	     (looking-at mail-extr-telephone-extension-pattern))
	    (throw 'stop 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
	   ((eq ?, (following-char))
	    (throw 'stop t))
	   
	   ;; Delete parenthesized/quoted comment/nickname
	   ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
	    (setq comment-beg (point))
	    (set-syntax-table mail-extr-address-text-comment-syntax-table)
	    (cond ((memq (following-char) '(?\' ?\`))
		   (if (eq ?\' (following-char))
		       (forward-char 1))
		   (or (search-forward "'" nil t)
		       (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 comment-end (point))
	    (cond
	     ;; Handle case of entire name being quoted
	     ((and (eq word-count 0)
		   (looking-at " *\\'")
		   (>= (- comment-end comment-beg) 2))
	      (narrow-to-region (1+ comment-beg) (1- comment-end))
	      (goto-char (point-min)))
	     (t
	      ;; Handle case of quoted initial
	      (if (and (or (= 3 (- comment-end comment-beg))
			   (and (= 4 (- comment-end comment-beg))
				(eq ?. (char-after (+ 2 comment-beg)))))
		       (not (looking-at " *\\'")))
		  (setq initial (char-after (1+ comment-beg)))
		(setq initial nil))
	      (delete-region comment-beg comment-end)
	      (if initial
		  (insert initial ". ")))))
	   
	   ;; Delete ham radio call signs
	   ((looking-at mail-extr-ham-call-sign-pattern)
	    (delete-region (match-beginning 0) (match-end 0)))
	   
	   ;; Handle & substitution
	   ;; TODO: remember to disable middle initial guessing
	   ((and (or (bobp)
		     (eq ?\  (preceding-char)))
		 (looking-at "&\\( \\|\\'\\)"))
	    (mail-extr-delete-char 1)
	    (capitalize-region
	     (point)
	     (progn
	       (insert-buffer-substring canonicalization-buffer
					mbox-beg mbox-end)
	       (point))))
	   
	   ;; 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-count (1+ word-count)))
	   
	   ;; Regular name words
	   ((looking-at mail-extr-name-pattern)
	    (setq beg (point))
	    (setq end (match-end 0))
	    (set (if (re-search-forward "[a-z]" end t)
		     (if (progn
			   (goto-char beg)
			   (re-search-forward "[A-Z]" end t))
			 'mixed-case-flag
		       'lower-case-flag)
		   'upper-case-flag) t)
	    (goto-char end)
	    (setq word-count (1+ word-count)))

	   (t
	    (throw 'stop t)))))
      
      (narrow-to-region (point-min) (point))

      ;; Delete trailing word followed immediately by .
      (cond ((not suffix-flag)
	     (goto-char (point-min))
	     (if (re-search-forward "\\b[A-Za-z][A-Za-z]+\\. *\\'" nil t)
		 (narrow-to-region (point-min) (match-beginning 0)))))
      
      ;; If last name first put it at end (but before suffix)
      (cond (last-name-comma-flag
	     (goto-char (point-min))
	     (search-forward ",")
	     (setq end (1- (point)))
	     (goto-char (or suffix-flag (point-max)))
	     (or (eq ?\  (preceding-char))
		 (insert ?\ ))
	     (insert-buffer-substring (current-buffer) (point-min) end)
	     (narrow-to-region (1+ end) (point-max))))
      
      (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 " "))
      )))


;; Mail-extr doesn't use this, but it's neat.
;; 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.

(defconst all-top-level-domains
  (let ((ob (make-vector 509 0)))
    (mapcar
     (function
      (lambda (x)
	(put (intern (upcase (car x)) ob)
	     'domain-name
	     (if (nth 2 x)
		 (format (nth 2 x) (nth 1 x))
	       (nth 1 x)))))
     '(("ag" "Antigua")
       ("ar" "Argentina"	"Argentine Republic")
       ("arpa" t		"Advanced Projects Research Agency")
       ("at" "Austria"		"The Republic of %s")
       ("au" "Australia")
       ("bb" "Barbados")
       ("be" "Belgium"		"The Kingdom of %s")
       ("bg" "Bulgaria")
       ("bitnet" t		"Because It's Time NET")
       ("bo" "Bolivia"		"Republic of %s")
       ("br" "Brazil"		"The Federative Republic of %s")
       ("bs" "Bahamas")
       ("bz" "Belize")
       ("ca" "Canada")
       ("ch" "Switzerland"	"The Swiss Confederation")
       ("cl" "Chile"		"The Republic of %s")
       ("cn" "China"		"The People's Republic of %s")
       ("co" "Columbia")
       ("com" t			"Commercial")
       ("cr" "Costa Rica"	"The Republic of %s")
       ("cs" "Czechoslovakia")
       ("de" "Germany")
       ("dk" "Denmark")
       ("dm" "Dominica")
       ("do" "Dominican Republic"	"The %s")
       ("ec" "Ecuador"		"The Republic of %s")
       ("edu" t			"Educational")
       ("eg" "Egypt"		"The Arab Republic of %s")
       ("es" "Spain"		"The Kingdom of %s")
       ("fi" "Finland"		"The Republic of %s")
       ("fj" "Fiji")
       ("fr" "France")
       ("gov" t			"Government (U.S.A.)")
       ("gr" "Greece"		"The Hellenic Republic (%s)")
       ("hk" "Hong Kong")
       ("hu" "Hungary"		"The Hungarian People's Republic")	;???
       ("ie" "Ireland")
       ("il" "Israel"		"The State of %s")
       ("in" "India"		"The Republic of %s")
       ("int" t			"(something British, don't know what)")
       ("is" "Iceland"		"The Republic of %s")
       ("it" "Italy"		"The Italian Republic")
       ("jm" "Jamaica")
       ("jp" "Japan")
       ("kn" "St. Kitts and Nevis")
       ("kr" "South Korea")
       ("lc" "St. Lucia")
       ("lk" "Sri Lanka"	"The Democratic Socialist Republic of %s")
       ("mil" t			"Military (U.S.A.)")
       ("mx" "Mexico"		"The United Mexican States")
       ("my" "Malaysia"		"%s (changed to Myanmar?)")		;???
       ("na" "Namibia")
       ("nato" t		"North Atlantic Treaty Organization")
       ("net" t			"Network")
       ("ni" "Nicaragua"	"The Republic of %s")
       ("nl" "Netherlands"	"The Kingdom of the %s")
       ("no" "Norway"		"The Kingdom of %s")
       ("nz" "New Zealand")
       ("org" t			"Organization")
       ("pe" "Peru")
       ("pg" "Papua New Guinea")
       ("ph" "Philippines"	"The Republic of the %s")
       ("pl" "Poland")
       ("pr" "Puerto Rico")
       ("pt" "Portugal"		"The Portugese Republic")
       ("py" "Paraguay")
       ("se" "Sweden"		"The Kingdom of %s")
       ("sg" "Singapore"	"The Republic of %s")
       ("sr" "Suriname")
       ("su" "Soviet Union")
       ("th" "Thailand"		"The Kingdom of %s")
       ("tn" "Tunisia")
       ("tr" "Turkey"		"The Republic of %s")
       ("tt" "Trinidad and Tobago")
       ("tw" "Taiwan")
       ("uk" "United Kingdom"	"The %s of Great Britain")
       ("unter-dom" t		"(something German)")
       ("us" "U.S.A."		"The United States of America")
       ("uucp" t		"Unix to Unix CoPy")
       ("uy" "Uruguay"		"The Eastern Republic of %s")
       ("vc" "St. Vincent and the Grenadines")
       ("ve" "Venezuela"	"The Republic of %s")
       ("yu" "Yugoslavia"	"The Socialist Federal Republic of %s")
       ;; Also said to be Zambia ... (why not Zaire???)
       ("za" "South Africa"	"The Republic of %s (or Zambia? Zaire?)")
       ("zw" "Zimbabwe"		"Republic of %s")
;; fipnet
       ))
    ob))

;;;###autoload
(defun what-domain (x)
  "Prompts for a mail domain, and prints the country it corresponds to
in the minibuffer."
  (interactive
   (let ((completion-ignore-case t))
     (list (completing-read "Domain: " all-top-level-domains nil t))))
  (or (setq x (intern-soft x all-top-level-domains))
      (setq x (intern-soft (upcase x) all-top-level-domains))
      (error "no such domain: %s" x))
  (message "%s: %s" x (get x 'domain-name)))


;; Code for testing.

;(defun time-extract ()
;  (let (times list)
;    (setq times (cons (current-time-string) times)
;	  list problem-address-alist)
;    (while list
;      (mail-extract-address-components (car (car list)))
;      (setq list (cdr list)))
;    (setq times (cons (current-time-string) times))
;    (nreverse times)))
;
;(defun test-extract (&optional starting-point)
;  (interactive)
;  (set-buffer (get-buffer-create "*Testing*"))
;  (erase-buffer)
;  (sit-for 0)
;  (mapcar 'test-extract-internal
;	  (if starting-point
;	      (memq starting-point problem-address-alist)
;	     problem-address-alist)))
;
;(defvar failed-item)
;(defun test-extract-internal (item)
;  (setq failed-item item)
;  (let* ((address (car item))
;	 (correct-name (nth 1 item))
;	 (correct-canon (nth 2 item))
;	 (result (mail-extract-address-components address))
;	 (name (or (car result) ""))
;	 (canon (nth 1 result))
;	 (name-correct (or (null correct-name)
;			   (string-equal (downcase correct-name)
;					 (downcase name))))
;	 (canon-correct (or (null correct-canon)
;			    (string-equal correct-canon canon))))
;    (cond ((not (and name-correct canon-correct))
;	   (pop-to-buffer "*Testing*")
;	   (select-window (get-buffer-window (current-buffer)))
;	   (goto-char (point-max))
;	   (insert "Address: " address "\n")
;	   (if (not name-correct)
;	       (insert " Correct Name:  [" correct-name
;		       "]\; Result: [" name "]\n"))
;	   (if (not canon-correct)
;	       (insert " Correct Canon: [" correct-canon
;		       "]\; Result: [" canon "]\n"))
;	   (insert "\n")
;	   (sit-for 0))))
;  (setq failed-item nil))
;
;(defun test-continue-extract ()
;  (interactive)
;  (test-extract failed-item))


(provide 'mail-extr)

;;; mail-extr.el ends here
