From d1782bd882dc768d06d49234c7af86f344bcf653 Mon Sep 17 00:00:00 2001
From: Karl Heuer <kwzh@gnu.org>
Date: Thu, 20 Nov 1997 21:45:59 +0000
Subject: [PATCH] (mail-extract-address-components): New arg ALL says return
 info about all the addresses. Clarify buffer switching logic using
 save-excursion.

---
 lisp/mail/mail-extr.el | 1393 ++++++++++++++++++++--------------------
 1 file changed, 713 insertions(+), 680 deletions(-)

diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 6989e8aefa..daa50daa8f 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1,10 +1,9 @@
 ;;; mail-extr.el --- extract full name and address from RFC 822 mail header.
 
-;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <jbw@cs.bu.edu>
-;; Maintainer: Jamie Zawinski <jwz@lucid.com>
-;; Version: 1.8
+;; Maintainer: FSF
 ;; Keywords: mail
 
 ;; This file is part of GNU Emacs.
@@ -28,7 +27,7 @@
 
 ;; The entry point of this code is
 ;;
-;;    mail-extract-address-components: (address)
+;;    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).
@@ -40,6 +39,10 @@
 ;;    If ADDRESS contains more than one RFC-822 address, only the first is
 ;;     returned.
 ;;
+;;    If ALL is non-nil, that means return info about all the addresses
+;;     that are found in ADDRESS.  The value is a list of elements of
+;;     the form (FULL-NAME CANONICAL-ADDRESS), one per address.
+;;
 ;; This code is more correct (and more heuristic) parser than the code in
 ;; rfc822.el.  And despite its size, it's fairly fast.
 ;;
@@ -706,44 +709,28 @@ by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\".")
 (defvar cend)				; dynamic assignment
 
 ;;;###autoload
-(defun mail-extract-address-components (address)
-  "Given an RFC-822 ADDRESS, extract full name and canonical address.
+(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.
+
+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
+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.)
-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."
+ consing a string.)"
   (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
 	(extraction-buffer (get-buffer-create " *extract address components*"))
-	char
-;;	multiple-addresses
-	<-pos >-pos @-pos :-pos comma-pos !-pos %-pos \;-pos
-	group-:-pos group-\;-pos route-addr-:-pos
-	record-pos-symbol
-	first-real-pos last-real-pos
-	phrase-beg phrase-end
-	cbeg cend			; dynamically set from -voodoo
-	quote-beg quote-end
-	atom-beg atom-end
-	mbox-beg mbox-end
-	\.-ends-name
-	temp
-;;	name-suffix
-	fi mi li			; first, middle, last initial
-	saved-%-pos saved-!-pos saved-@-pos
-	domain-pos \.-pos insert-point
-;;	mailbox-name-processed-flag
-	disable-initial-guessing-flag	; dynamically set from -voodoo
-	)
-    
+	value-list)
+
     (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)
@@ -763,672 +750,718 @@ If ADDRESS contains more than one RFC-822 address, only the first is
 	     (error "Invalid address: %s" address)))
 
       (set-text-properties (point-min) (point-max) nil)
+
+      (save-excursion
+	(set-buffer canonicalization-buffer)
+	(fundamental-mode)
+	(buffer-disable-undo canonicalization-buffer)
+	(set-syntax-table mail-extr-address-syntax-table)
+	(setq case-fold-search nil))
+
       
-      ;; 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 cbeg)
-		   (save-excursion
-		     (forward-char 1)
-		     (mail-extr-skip-whitespace-forward)
-		     (not (eq ?\) (char-after (point))))))
-	      (setq cbeg (point)))
-	  ;; TODO: don't record if unbalanced
-	  (or (mail-extr-safe-move-sexp 1)
+      ;; Loop over addresses until we have as many as we want.
+      (while (and (or all (null value-list))
+		  (progn (goto-char (point-min))
+			 (skip-chars-forward " \t")
+			 (not (eobp))))
+	(let (char
+	      end-of-address
+	      <-pos >-pos @-pos :-pos comma-pos !-pos %-pos \;-pos
+	      group-:-pos group-\;-pos route-addr-:-pos
+	      record-pos-symbol
+	      first-real-pos last-real-pos
+	      phrase-beg phrase-end
+	      cbeg cend			; dynamically set from -voodoo
+	      quote-beg quote-end
+	      atom-beg atom-end
+	      mbox-beg mbox-end
+	      \.-ends-name
+	      temp
+	      ;;	name-suffix
+	      fi mi li			; first, middle, last initial
+	      saved-%-pos saved-!-pos saved-@-pos
+	      domain-pos \.-pos insert-point
+	      ;;	mailbox-name-processed-flag
+	      disable-initial-guessing-flag) ; dynamically set from -voodoo
+
+	  (goto-char (point-min))
+
+	  ;; Insert extra space at beginning to allow later replacement with <
+	  ;; without having to move markers.
+	  (or (eq (following-char) ?\ )
+	      (insert ?\ ))
+
+	  ;; First pass grabs useful information about address.
+	  (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 cbeg)
+		       (save-excursion
+			 (forward-char 1)
+			 (mail-extr-skip-whitespace-forward)
+			 (not (eq ?\) (char-after (point))))))
+		  (setq cbeg (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 cbeg
+		       (not cend))
+		  (setq cend (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 (and (null <-pos)
+			    ;; Handle ROUTE-ADDR address that is missing its <.
+			    (not (eq ?@ (char-after (1+ (point))))))
+		       (and >-pos
+			    ;; handle weird munged addresses
+			    ;; BUG FIX: This test was reversed.  Thanks to the
+			    ;; brilliant Rod Whitby <rwhitby@research.canon.oz.au>
+			    ;; for discovering this!
+			    (< (mail-extr-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))))
+	      (narrow-to-region (point-min) (1+ (point)))
+	      (mail-extr-delete-char 1)
+	      (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) (?, . comma-pos) (?! . !-pos)
+				 (?% . %-pos) (?\; . \;-pos)))))
+	      (set record-pos-symbol
+		   (cons (point) (symbol-value record-pos-symbol)))
 	      (forward-char 1))
-	  (set-syntax-table mail-extr-address-syntax-table)
-	  (if (and cbeg
-		   (not cend))
-	      (setq cend (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)
+	     ((eq char ?.)
 	      (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)
+	     ((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))
-	  (set-syntax-table mail-extr-address-syntax-table))
-	 ;; commas delimit addresses when outside < > pairs.
-	 ((and (eq char ?,)
-	       (or (and (null <-pos)
-			;; Handle ROUTE-ADDR address that is missing its <.
-			(not (eq ?@ (char-after (1+ (point))))))
-		   (and >-pos
-			;; handle weird munged addresses
-			;; BUG FIX: This test was reversed.  Thanks to the
-			;; brilliant Rod Whitby <rwhitby@research.canon.oz.au>
-			;; for discovering this!
-			(< (mail-extr-last <-pos) (car >-pos)))))
-;; It'd be great if some day this worked, but for now, punt.
-;;	  (setq multiple-addresses t)
-;;	  ;; *** Why do I want this:
-;;	  (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) (?, . comma-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 ?\()
-	    ;; At the end of first address of a multiple address header.
-	    (and (eq char ?,)
-		 (eobp))
-	    (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.
-      ;; 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)
-		  (eq 1 (length :-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 ?<)))
-      
-      ;; 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))))
-      
-      ;; 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)))
-      
-      ;; Handle junk like ";@host.company.dom" that sendmail adds.
-      ;; **** should I remember comment positions?
-      (cond
-       (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 comma-pos group-:-pos group-\;-pos t)
-	(and last-real-pos
-	     (> last-real-pos (1+ group-\;-pos))
-	     (setq last-real-pos (1+ group-\;-pos)))
-	;; *** This may be wrong:
-        (and cend
-             (> cend group-\;-pos)
-             (setq cend nil
-                   cbeg nil))
-	(and quote-end
-	     (> quote-end group-\;-pos)
-	     (setq quote-end nil
-		   quote-beg nil))
-	;; This was both wrong and unnecessary:
-	;;(narrow-to-region (point-min) group-\;-pos)
-
-	;; *** 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.
-      ;; **** 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)
-      
-      ;; 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)
-	(if (and first-real-pos last-real-pos)
-	    (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))
-	  ))
-      
-      (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))
-      
-      ;; 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))
+	     (t
+	      (forward-word 1)))
+	    (or (eq char ?\()
+		;; At the end of first address of a multiple address header.
+		(and (eq char ?,)
+		     (eobp))
+		(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.
+	  ;; 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)
+		      (eq 1 (length :-pos))	;TODO: check if between last two @s
+		      (not \;-pos)
+		      (not <-pos))
+		 (goto-char (point-min))
 		 (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)))))
-
-      ;; 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))))))
-      (setq mbox-beg (point-min)
-	    mbox-end (if %-pos (car %-pos)
-		       (or @-pos
-			   (point-max))))
-      
-      ;; Done canonicalizing address.
-      
-      (set-buffer extraction-buffer)
-      
-      ;; Decide what part of the address to search to find the full name.
-      (cond (
-	     ;; Example: "First M. Last" <fml@foo.bar.dom>
-	     (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)))
-
-	    ;; Example: First Last <fml@foo.bar.dom>
-	    (phrase-beg
-	     (narrow-to-region phrase-beg phrase-end))
-
-	    ;; Example: fml@foo.bar.dom (First M. Last)
-	    (cbeg
-	     (narrow-to-region (1+ cbeg) (1- cend))
-	     (mail-extr-undo-backslash-quoting (point-min) (point-max))
-	     
-	     ;; Deal with spacing problems
-	     (goto-char (point-min))
-;	     (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))))))
-	     )
-	    
-	    ;; Otherwise we try to get the name from the mailbox portion
-	    ;; of the address.
-	    ;; Example: First_M_Last@foo.bar.dom
-	    (t
-	     ;; *** Work in canon buffer instead?  No, can't.  Hmm.
-	     (goto-char (point-max))
-	     (narrow-to-region (point) (point))
-	     (insert-buffer-substring canonicalization-buffer
-				      mbox-beg mbox-end)
-	     (goto-char (point-min))
-	     
-	     ;; Example: First_Last.XXX@foo.bar.dom
-	     (setq \.-ends-name (re-search-forward "[_0-9]" nil t))
-	     
-	     (goto-char (point-min))
-
-	     (if (not mail-extr-mangle-uucp)
-		 (modify-syntax-entry ?! "w" (syntax-table)))
+		 (setq <-pos (list (point)))
+		 (insert ?<)))
 
-	     (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)
+	  ;; 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))))
+
+	  ;; 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)))
+
+	  ;; Handle junk like ";@host.company.dom" that sendmail adds.
+	  ;; **** should I remember comment positions?
+	  (cond
+	   (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 comma-pos group-:-pos group-\;-pos t)
+	    (and last-real-pos
+		 (> last-real-pos (1+ group-\;-pos))
+		 (setq last-real-pos (1+ group-\;-pos)))
+	    ;; *** This may be wrong:
+	    (and cend
+		 (> cend group-\;-pos)
+		 (setq cend nil
+		       cbeg nil))
+	    (and quote-end
+		 (> quote-end group-\;-pos)
+		 (setq quote-end nil
+		       quote-beg nil))
+	    ;; This was both wrong and unnecessary:
+	    ;;(narrow-to-region (point-min) group-\;-pos)
+
+	    ;; *** 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.
+	  ;; **** 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)
+
+	  ;; 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)
-		   (goto-char quote-beg)
-		   (or (eobp)
-		       (mail-extr-delete-char 1)))
-		 (mail-extr-undo-backslash-quoting quote-beg quote-end)
-		 (or (eq ?\  (char-after (point)))
-		     (insert " "))
-;;		 (setq mailbox-name-processed-flag t)
-		 (setq \.-ends-name t))
-		((eq char ?.)
-		 (if (memq (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 " ")))
-;;		 (setq mailbox-name-processed-flag t)
-		 )
-		((memq (char-syntax char) '(?. ?\\))
-		 (mail-extr-delete-char 1)
-		 (insert " ")
-;;		 (setq mailbox-name-processed-flag t)
+		   (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
+
+	  (save-excursion
+	    (set-buffer canonicalization-buffer)
+
+	    (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)
+	      (if (and first-real-pos last-real-pos)
+		  (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))
+		))
+
+	    (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))
+
+	    ;; 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)))))
+
+	    ;; 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))))))
+	    (setq mbox-beg (point-min)
+		  mbox-end (if %-pos (car %-pos)
+			     (or @-pos
+				 (point-max)))))
+
+	  ;; Done canonicalizing address.
+	  ;; We are now back in extraction-buffer.
+
+	  ;; Decide what part of the address to search to find the full name.
+	  (cond (
+		 ;; Example: "First M. Last" <fml@foo.bar.dom>
+		 (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)))
+
+		;; Example: First Last <fml@foo.bar.dom>
+		(phrase-beg
+		 (narrow-to-region phrase-beg phrase-end))
+
+		;; Example: fml@foo.bar.dom (First M. Last)
+		(cbeg
+		 (narrow-to-region (1+ cbeg) (1- cend))
+		 (mail-extr-undo-backslash-quoting (point-min) (point-max))
+
+		 ;; Deal with spacing problems
+		 (goto-char (point-min))
+;;;	     (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))))))
 		 )
+
+		;; Otherwise we try to get the name from the mailbox portion
+		;; of the address.
+		;; Example: First_M_Last@foo.bar.dom
 		(t
-		 (setq atom-beg (point))
-		 (forward-word 1)
-		 (setq atom-end (point))
-		 (goto-char atom-beg)
-		 (save-restriction
-		   (narrow-to-region atom-beg atom-end)
+		 ;; *** Work in canon buffer instead?  No, can't.  Hmm.
+		 (goto-char (point-max))
+		 (narrow-to-region (point) (point))
+		 (insert-buffer-substring canonicalization-buffer
+					  mbox-beg mbox-end)
+		 (goto-char (point-min))
+
+		 ;; Example: First_Last.XXX@foo.bar.dom
+		 (setq \.-ends-name (re-search-forward "[_0-9]" 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
-		    
-		    ;; Handle X.400 addresses encoded in RFC-822.
-		    ;; *** Shit!  This has to handle the case where it is
-		    ;; *** embedded in a quote too!
-		    ;; *** Shit!  The input is being broken up into atoms
-		    ;; *** by periods!
-		    ((looking-at mail-extr-x400-encoded-address-pattern)
-		     
-		     ;; 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 " ")))))
-		      (list mail-extr-x400-encoded-address-given-name-pattern
-			    mail-extr-x400-encoded-address-surname-pattern
-			    mail-extr-x400-encoded-address-full-name-pattern))
-		     
-		     ;; Discard the rest, since it contains stuff like
-		     ;; routing information, not part of a name.
-		     (mail-extr-skip-whitespace-backward)
-		     (delete-region (point) (point-max))
-		     
-		     ;; Handle periods used for spacing.
-		     (while (re-search-forward mail-extr-bad-dot-pattern nil t)
-		       (replace-match "\\1 \\2" t))
-		     
-;;		     (setq mailbox-name-processed-flag t)
+		    ((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)
+		       (or (eobp)
+			   (mail-extr-delete-char 1)))
+		     (mail-extr-undo-backslash-quoting quote-beg quote-end)
+		     (or (eq ?\  (char-after (point)))
+			 (insert " "))
+		     ;;		 (setq mailbox-name-processed-flag t)
+		     (setq \.-ends-name t))
+		    ((eq char ?.)
+		     (if (memq (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 " ")))
+		     ;;		 (setq mailbox-name-processed-flag t)
+		     )
+		    ((memq (char-syntax char) '(?. ?\\))
+		     (mail-extr-delete-char 1)
+		     (insert " ")
+		     ;;		 (setq mailbox-name-processed-flag t)
 		     )
-		    
-		    ;; Handle normal addresses.
 		    (t
-		     (goto-char (point-min))
-		     ;; Handle _ and = used for spacing.
-		     (while (re-search-forward "\\([^_=]+\\)[_=]" nil t)
-		       (replace-match "\\1 " t)
-;;		       (setq mailbox-name-processed-flag t)
-		       )
-		     (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 mailbox-name-processed-flag)
-             ;;     (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))
+		     (setq atom-beg (point))
+		     (forward-word 1)
+		     (setq atom-end (point))
+		     (goto-char atom-beg)
+		     (save-restriction
+		       (narrow-to-region atom-beg atom-end)
+		       (cond
+
+			;; Handle X.400 addresses encoded in RFC-822.
+			;; *** Shit!  This has to handle the case where it is
+			;; *** embedded in a quote too!
+			;; *** Shit!  The input is being broken up into atoms
+			;; *** by periods!
+			((looking-at mail-extr-x400-encoded-address-pattern)
+
+			 ;; 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 " ")))))
+			  (list mail-extr-x400-encoded-address-given-name-pattern
+				mail-extr-x400-encoded-address-surname-pattern
+				mail-extr-x400-encoded-address-full-name-pattern))
+
+			 ;; Discard the rest, since it contains stuff like
+			 ;; routing information, not part of a name.
+			 (mail-extr-skip-whitespace-backward)
+			 (delete-region (point) (point-max))
+
+			 ;; Handle periods used for spacing.
+			 (while (re-search-forward mail-extr-bad-dot-pattern nil t)
+			   (replace-match "\\1 \\2" t))
+
+			 ;;		     (setq mailbox-name-processed-flag t)
+			 )
+
+			;; Handle normal addresses.
+			(t
+			 (goto-char (point-min))
+			 ;; Handle _ and = used for spacing.
+			 (while (re-search-forward "\\([^_=]+\\)[_=]" nil t)
+			   (replace-match "\\1 " t)
+			   ;;		       (setq mailbox-name-processed-flag t)
+			   )
+			 (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 mailbox-name-processed-flag)
+		 ;;     (delete-region (point-min) (point-max)))
+		 ))
 
-      ;; If name is "First Last" and userid is "F?L", then assume
-      ;; the middle initial is the second letter in the userid.
-      ;; Initial code by Jamie Zawinski <jwz@lucid.com>
-      ;; *** 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) ". ")))))
-      
-      ;; 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))))))
-      
-      ;; Nuke name if it's just one word.
-      (goto-char (point-min))
-      (and mail-extr-ignore-single-names
-	   (not (re-search-forward "[- ]" nil t))
-	   (narrow-to-region (point) (point)))
-      
-      ;; Result
-      (list (if (not (= (point-min) (point-max)))
-		(buffer-string))
-	    (progn
-	      (set-buffer canonicalization-buffer)
-	      (if (not (= (point-min) (point-max)))
-		  (buffer-string))))
-      )))
+	  (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.
+	  ;; Initial code by Jamie Zawinski <jwz@lucid.com>
+	  ;; *** 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) ". ")))))
+
+	  ;; 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))))))
+
+	  ;; Nuke name if it's just one word.
+	  (goto-char (point-min))
+	  (and mail-extr-ignore-single-names
+	       (not (re-search-forward "[- ]" nil t))
+	       (narrow-to-region (point) (point)))
+
+	  ;; Record the result
+	  (setq value-list
+		(cons (list (if (not (= (point-min) (point-max)))
+				(buffer-string))
+			    (save-excursion
+			      (set-buffer canonicalization-buffer)
+			      (if (not (= (point-min) (point-max)))
+				  (buffer-string))))
+		      value-list))
+
+	  ;; Unless one address is all we wanted,
+	  ;; delete this one from extraction-buffer
+	  ;; and get ready to extract the next address.
+	  (when all
+	    (if end-of-address
+		(narrow-to-region 1 end-of-address)
+	      (widen))
+	    (delete-region (point-min) (point-max))
+	    (widen))
+	  )))
+    (if all (nreverse value-list) (car value-list))
+    ))
 
 (defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer)
   (let ((word-count 0)
-- 
2.39.2