comparison lisp/mail/mail-extr.el @ 41300:5f6710a130ca

Use backquote/dolist/mapc/when. Docstring fixes. (mail-extract-address-components): Downcase domain names. (mail-extr-delete-char): Remove. Use delete-char instead.

41299:77b08a460f84

(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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Utility functions and macros.
;;

(defsubst 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.
  (delete-region (point) (+ (point) n)))

(defsubst mail-extr-skip-whitespace-forward ()
  ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
  (skip-chars-forward " \t\n\r\240"))

(defsubst mail-extr-skip-whitespace-backward ()

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

(defsubst mail-extr-nuke-char-at (pos)
  (save-excursion
    (goto-char pos)
    (mail-extr-delete-char 1)
    (insert ?\ )))

(put 'mail-extr-nuke-outside-range
     'edebug-form-spec '(symbolp &optional form form atom))

(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, evaluable 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)

	    (setcdr >-pos (nthcdr 2 >-pos)))

	  ;; If multiple @s and a :, but no < and >, insert around buffer.
	  ;; Example: @foo.bar.dom,@xxx.yyy.zzz:[e-mail]
	  ;; This commonly happens on the UUCP "From " line.  Ugh.
	  (cond ((and (> (length @-pos) 1)
		      (eq 1 (length colon-pos))	;TODO: check if between last two @s
		      (not \;-pos)
		      (not <-pos))
		 (goto-char (point-min))
		 (mail-extr-delete-char 1)
		 (setq <-pos (list (point)))
		 (insert ?<)))

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

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

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

	  (save-excursion
	    (set-buffer canonicalization-buffer)

	    (widen)
	    (erase-buffer)
	    (insert-buffer-substring extraction-buffer)

	    (if <-pos

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

		 (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 (car (last %-pos))
				      saved-%-pos (mapcar 'mail-extr-markerize %-pos)
				      %-pos nil
				      @-pos (mail-extr-markerize @-pos)))
			       (@-pos
				(setq insert-point @-pos)
				(setq @-pos (mail-extr-markerize @-pos)))
			       (t
				(setq insert-point (point-max))))
			 (narrow-to-region (point-min) insert-point)
			 (setq saved-!-pos (car !-pos))
			 (while !-pos
			   (goto-char (point-max))
			   (cond ((and (not @-pos)
				       (not (cdr !-pos)))
				  (setq @-pos (point))
				  (insert-before-markers "@ "))
				 (t
				  (setq %-pos (cons (point) %-pos))
				  (insert-before-markers "% ")))
			   (backward-char 1)
			   (insert-buffer-substring 
			    (current-buffer)
			    (if (nth 1 !-pos)
				(1+ (nth 1 !-pos))
			      (point-min))
			    (car !-pos))
			   (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.

			 (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)
		     )
		    (t
		     (setq atom-beg (point))

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

	  ;; 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 <[e-mail]>
	  ;; *** 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))

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

      (while (not (eobp))
	;; Initialize for this iteration of the loop.
	(skip-chars-forward "^({[\"'`")
	(let ((cbeg (point)))
	  (set-syntax-table mail-extr-address-text-comment-syntax-table)
	  (cond ((memq (following-char) '(?\' ?\`))
		 (search-forward "'" nil 'move
				 (if (eq ?\' (following-char)) 2 1)))
		(t
		 (or (mail-extr-safe-move-sexp 1)
		     (goto-char (point-max)))))
	  (set-syntax-table mail-extr-address-text-syntax-table)
	  (when (eq (char-after cbeg) ?\()
	    ;; Delete the comment itself.
	    (delete-region cbeg (point))
	    ;; Canonicalize whitespace where the comment was.

      ;;   "Piet.Rypens" <[e-mail]>
      ;;(goto-char (point-min))
      ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
      ;;  (replace-match "\\1 \\2" t))

      (cond ((not (search-forward " " nil t))
	     (goto-char (point-min))
	     (cond ((search-forward "_" nil t)
		    ;; Handle the *idiotic* use of underlines as spaces.
		    ;; Example: [e-mail] (First_M._Last)
		    (goto-char (point-min))
		    (while (search-forward "_" nil t)
		      (replace-match " " t)))
		   ((search-forward "." nil t)
		    ;; Fix . used as space
		    ;; Example: [e-mail] (daniel.jacobson)
		    (goto-char (point-min))
		    (while (re-search-forward mail-extr-bad-dot-pattern nil t)
		      (replace-match "\\1 \\2" t))))))

      ;; Loop over the words (and other junk) in the name.
      (goto-char (point-min))
      (while (not name-done-flag)
	
	(cond (word-found-flag
	       ;; Last time through this loop we skipped over a word.
	       (setq last-word-beg this-word-beg)
	       (setq drop-last-word-if-trailing-flag
		     drop-this-word-if-trailing-flag)
	       (setq word-found-flag nil)))

	(cond (begin-again-flag
	       ;; Last time through the loop we found something that
	       ;; indicates we should pretend we are beginning again from
	       ;; the start.
	       (setq word-count 0)
	       (setq last-word-beg nil)
	       (setq drop-last-word-if-trailing-flag nil)
	       (setq mixed-case-flag nil)
	       (setq lower-case-flag nil)
;;	       (setq upper-case-flag nil)
	       (setq begin-again-flag nil)
	       ))
	
	;; Initialize for this iteration of the loop.
	(mail-extr-skip-whitespace-forward)
	(if (eq word-count 0) (narrow-to-region (point) (point-max)))
	(setq this-word-beg (point))

	  (setq cbeg (point))
	  (set-syntax-table mail-extr-address-text-comment-syntax-table)
	  (cond ((memq (following-char) '(?\' ?\`))
		 (or (search-forward "'" nil t
				     (if (eq ?\' (following-char)) 2 1))
		     (mail-extr-delete-char 1)))
		(t
		 (or (mail-extr-safe-move-sexp 1)
		     (goto-char (point-max)))))
	  (set-syntax-table mail-extr-address-text-syntax-table)
	  (setq cend (point))

	 ;; Handle & substitution, when & is last and is not first.
	 ((and (> word-count 0)
	       (eq ?\  (preceding-char))
	       (eq (following-char) ?&)
	       (eq (1+ (point)) (point-max)))
	  (mail-extr-delete-char 1)
	  (capitalize-region
	   (point)
	   (progn
	     (insert-buffer-substring canonicalization-buffer
				      mbox-beg mbox-end)

      ;; We simply refuse to believe that any last name is PARC or ADOC.
      ;; If it looks like that is the last name, that there is no meaningful
      ;; here at all.  Actually I guess it would be best to map patterns
      ;; like [e-mail] into [e-mail], but I don't
      ;; actually know that that is what's going on.
      (cond ((not suffix-flag)
	     (goto-char (point-min))
	     (let ((case-fold-search t))
	       (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
		   (erase-buffer)))))

      ;; If last name first put it at end (but before suffix)
      (cond (last-name-comma-flag
	     (goto-char (point-min))
	     (search-forward ",")
	     (setq name-end (1- (point)))
	     (goto-char (or suffix-flag (point-max)))
	     (or (eq ?\  (preceding-char))
		 (insert ?\ ))
	     (insert-buffer-substring (current-buffer) (point-min) name-end)
	     (goto-char name-end)
	     (skip-chars-forward "\t ,")
	     (narrow-to-region (point) (point-max))))
      
      ;; Delete leading and trailing junk characters.
      ;; *** This is probably completely unneeded now.
      ;;(goto-char (point-max))
      ;;(skip-chars-backward mail-extr-non-end-name-chars)

;; a U.S. FIPS that specifies a different set of two-letter country
;; abbreviations.

(defconst mail-extr-all-top-level-domains
  (let ((ob (make-vector 739 0)))
    (mapcar
     (function
      (lambda (x)
	(put (intern (downcase (car x)) ob)
	     'domain-name
	     (if (nth 2 x)
		 (format (nth 2 x) (nth 1 x))
	       (nth 1 x)))))
     '(
       ;; ISO 3166 codes:
       ("ad" "Andorra")
       ("ae" "United Arab Emirates")
       ("af" "Afghanistan")

41300:5f6710a130ca

(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))
(mapc
 (lambda (pair)
   (let ((syntax-table (symbol-value (car pair))))
     (dolist (item (cdr pair))
       (if (eq 2 (length item))
	   ;; modifying syntax of a single character
	   (modify-syntax-entry (car item) (car (cdr item)) syntax-table)
	 ;; modifying syntax of a range of characters
	 (let ((char (nth 0 item))
	       (bound (nth 1 item))
	       (syntax (nth 2 item)))
	   (while (<= char bound)
	     (modify-syntax-entry char syntax syntax-table)
	     (setq char (1+ char))))))))
 '((mail-extr-address-syntax-table
    (?\000 ?\037 "w")			;control characters
    (?\040	 " ")			;SPC
    (?! ?~	 "w")			;printable characters
    (?\177	 "w")			;DEL

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Utility functions and macros.
;;

(defsubst mail-extr-skip-whitespace-forward ()
  ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
  (skip-chars-forward " \t\n\r\240"))

(defsubst mail-extr-skip-whitespace-backward ()

    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      ;; undo \ quoting
      (while (search-forward "\\" nil t)
	(delete-char -1)
	(or (eobp)
	    (forward-char 1))))))

(defsubst mail-extr-nuke-char-at (pos)
  (save-excursion
    (goto-char pos)
    (delete-char 1)
    (insert ?\ )))

(put 'mail-extr-nuke-outside-range
     'edebug-form-spec '(symbolp &optional form form atom))

(defmacro mail-extr-nuke-outside-range (list-symbol
					beg-symbol end-symbol
					&optional no-replace)
  "Delete all elements outside BEG..END in LIST.
LIST-SYMBOL names a variable holding a list of buffer positions
BEG-SYMBOL and END-SYMBOL name variables delimiting a range
Each element of LIST-SYMBOL which lies outside of the range is
 deleted from the list.
Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
 which lie outside of the range, one character at that position is
 replaced with a SPC."
  (or (memq no-replace '(t nil))
      (error "no-replace must be t or nil, evaluable at macroexpand-time"))
  `(let ((temp ,list-symbol)
	   ch)
       (while temp
	 (setq ch (car temp))
	 (when (or (> ch ,end-symbol)
		   (< ch ,beg-symbol))
	   ,@(if no-replace
		   nil
		 `((mail-extr-nuke-char-at ch)))
	   (setcar temp nil))
	 (setq temp (cdr temp)))
       (setq ,list-symbol (delq nil ,list-symbol))))

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

	    (setcdr >-pos (nthcdr 2 >-pos)))

	  ;; If multiple @s and a :, but no < and >, insert around buffer.
	  ;; Example: @foo.bar.dom,@xxx.yyy.zzz:[e-mail]
	  ;; This commonly happens on the UUCP "From " line.  Ugh.
	  (when (and (> (length @-pos) 1)
		      (eq 1 (length colon-pos))	;TODO: check if between last two @s
		      (not \;-pos)
		      (not <-pos))
	    (goto-char (point-min))
	    (delete-char 1)
	    (setq <-pos (list (point)))
	    (insert ?<))

	  ;; If < but no >, insert > in rightmost possible position
	  (when (and <-pos (null >-pos))
	    (goto-char (point-max))
	    (setq >-pos (list (point)))
	    (insert ?>))

	  ;; If > but no <, replace > with space.
	  (when (and >-pos (null <-pos))
	    (mail-extr-nuke-char-at (car >-pos))
	    (setq >-pos nil))

	  ;; Turn >-pos and <-pos into non-lists
	  (setq >-pos (car >-pos)
		<-pos (car <-pos))

	  ;; Trim other punctuation lists of items outside < > pair to handle
	  ;; stupid MTAs.
	  (when <-pos			; don't need to check >-pos also
	    ;; handle bozo software that violates RFC 822 by sticking
	    ;; punctuation marks outside of a < > pair
	    (mail-extr-nuke-outside-range @-pos <-pos >-pos t)
	    ;; RFC 822 says nothing about these two outside < >, but
	    ;; remove those positions from the lists to make things
	    ;; easier.
	    (mail-extr-nuke-outside-range !-pos <-pos >-pos t)
	    (mail-extr-nuke-outside-range %-pos <-pos >-pos t))

	  ;; Check for : that indicates GROUP list and for : part of
	  ;; ROUTE-ADDR spec.
	  ;; Can't possibly be more than two :.  Nuke any extra.
	  (while colon-pos

			    (> temp group-:-pos))
			(not group-\;-pos))
		   (setq group-\;-pos temp))))

	  ;; Nuke unmatched GROUP syntax characters.
	  (when (and group-:-pos (not group-\;-pos))
	    ;; *** Do I really need to erase it?
	    (mail-extr-nuke-char-at group-:-pos)
	    (setq group-:-pos nil))
	  (when (and group-\;-pos (not group-:-pos))
	    ;; *** Do I really need to erase it?
	    (mail-extr-nuke-char-at group-\;-pos)
	    (setq group-\;-pos nil))

	  ;; Handle junk like ";@host.company.dom" that sendmail adds.
	  ;; **** should I remember comment positions?
	  (when group-\;-pos
	    ;; this is fine for now
	    (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t)
	    (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t)
	    (mail-extr-nuke-outside-range %-pos group-:-pos group-\;-pos t)
	    (mail-extr-nuke-outside-range comma-pos group-:-pos group-\;-pos t)

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

	  ;; 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.
	  (when <-pos
	    (goto-char <-pos)
	    (mail-extr-skip-whitespace-backward)
	    (setq phrase-end (point))
	    (goto-char (or ;;group-:-pos
			(point-min)))
	    (mail-extr-skip-whitespace-forward)
	    (if (< (point) phrase-end)
		(setq phrase-beg (point))
	      (setq phrase-end nil)))

	  ;; handle ROUTE-ADDRS with real ROUTEs.
	  ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and
	  ;; any % or ! must be semantically meaningless.
	  ;; TODO: do this processing into canonicalization buffer
	  (when route-addr-:-pos
	    (setq !-pos nil
		  %-pos nil
		  >-pos (copy-marker >-pos)
		  route-addr-:-pos (copy-marker route-addr-:-pos))
	    (goto-char >-pos)
	    (insert-before-markers ?X)
	    (goto-char (car @-pos))
	    (while (setq @-pos (cdr @-pos))
	      (delete-char 1)
	      (setq %-pos (cons (point-marker) %-pos))
	      (insert "%")
	      (goto-char (1- >-pos))
	      (save-excursion
		(insert-buffer-substring extraction-buffer
					 (car @-pos) route-addr-:-pos)
		(delete-region (car @-pos) route-addr-:-pos))
	      (or (cdr @-pos)
		  (setq saved-@-pos (list (point)))))
	    (setq @-pos saved-@-pos)
	    (goto-char >-pos)
	    (delete-char -1)
	    (mail-extr-nuke-char-at route-addr-:-pos)
	    (mail-extr-demarkerize route-addr-:-pos)
	    (setq route-addr-:-pos nil
		  >-pos (mail-extr-demarkerize >-pos)
		  %-pos (mapcar 'mail-extr-demarkerize %-pos)))

	  ;; de-listify @-pos
	  (setq @-pos (car @-pos))

	  ;; TODO: remove comments in the middle of an address

	  (with-current-buffer canonicalization-buffer
	    (widen)
	    (erase-buffer)
	    (insert-buffer-substring extraction-buffer)

	    (if <-pos

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

		 (mail-extr-nuke-outside-range !-pos (point-min) @-pos))

	    ;; Error condition:?? (and %-pos (not @-pos))

	    ;; WARNING: THIS CODE IS DUPLICATED BELOW.
	    (when (and %-pos (not @-pos))
	      (goto-char (car %-pos))
	      (delete-char 1)
	      (setq @-pos (point))
	      (insert "@")
	      (setq %-pos (cdr %-pos)))

	    (when (and mail-extr-mangle-uucp !-pos)
	      ;; **** I don't understand this save-restriction and the
	      ;; narrow-to-region inside it.  Why did I do that?
	      (save-restriction
		(cond ((and @-pos
			    mail-extr-@-binds-tighter-than-!)
		       (goto-char @-pos)
		       (setq %-pos (cons (point) %-pos)
			     @-pos nil)
		       (delete-char 1)
		       (insert "%")
		       (setq insert-point (point-max)))
		      (mail-extr-@-binds-tighter-than-!
		       (setq insert-point (point-max)))
		      (%-pos
		       (setq insert-point (car (last %-pos))
			     saved-%-pos (mapcar 'mail-extr-markerize %-pos)
			     %-pos nil
			     @-pos (mail-extr-markerize @-pos)))
		      (@-pos
		       (setq insert-point @-pos)
		       (setq @-pos (mail-extr-markerize @-pos)))
		      (t
		       (setq insert-point (point-max))))
		(narrow-to-region (point-min) insert-point)
		(setq saved-!-pos (car !-pos))
		(while !-pos
		  (goto-char (point-max))
		  (cond ((and (not @-pos)
			      (not (cdr !-pos)))
			 (setq @-pos (point))
			 (insert-before-markers "@ "))
			(t
			 (setq %-pos (cons (point) %-pos))
			 (insert-before-markers "% ")))
		  (backward-char 1)
		  (insert-buffer-substring
		   (current-buffer)
		   (if (nth 1 !-pos)
		       (1+ (nth 1 !-pos))
		     (point-min))
		   (car !-pos))
		  (delete-char 1)
		  (or (save-excursion
			(mail-extr-safe-move-sexp -1)
			(mail-extr-skip-whitespace-backward)
			(eq ?. (preceding-char)))
		      (insert-before-markers
		       (if (save-excursion
			     (mail-extr-skip-whitespace-backward)
			     (eq ?. (preceding-char)))
			   ""
			 ".")
		       "uucp"))
		  (setq !-pos (cdr !-pos))))
	      (and saved-%-pos
		   (setq %-pos (append (mapcar 'mail-extr-demarkerize
					       saved-%-pos)
				       %-pos)))
	      (setq @-pos (mail-extr-demarkerize @-pos))
	      (narrow-to-region (1+ saved-!-pos) (point-max)))

	    ;; WARNING: THIS CODE IS DUPLICATED ABOVE.
	    (when (and %-pos (not @-pos))
	      (goto-char (car %-pos))
	      (delete-char 1)
	      (setq @-pos (point))
	      (insert "@")
	      (setq %-pos (cdr %-pos)))

	    (when (setq %-pos (nreverse %-pos))	; implies @-pos valid
	      (setq temp %-pos)
	      (catch 'truncated
		(while temp
		  (goto-char (or (nth 1 temp)
				 @-pos))
		  (mail-extr-skip-whitespace-backward)
		  (save-excursion
		    (mail-extr-safe-move-sexp -1)
		    (setq domain-pos (point))
		    (mail-extr-skip-whitespace-backward)
		    (setq \.-pos (eq ?. (preceding-char))))
		  (when (and \.-pos
			     ;; #### string consing
			     (let ((s (intern-soft
				       (buffer-substring domain-pos (point))
				       mail-extr-all-top-level-domains)))
			       (and s (get s 'domain-name))))
		    (narrow-to-region (point-min) (point))
		    (goto-char (car temp))
		    (delete-char 1)
		    (setq @-pos (point))
		    (setcdr temp nil)
		    (setq %-pos (delq @-pos %-pos))
		    (insert "@")
		    (throw 'truncated t))
		  (setq temp (cdr temp)))))
	    (setq mbox-beg (point-min)
		  mbox-end (if %-pos (car %-pos)
			     (or @-pos
				 (point-max))))

	    (when @-pos
	      ;; Make the domain-name part lowercase since it's case
	      ;; insensitive anyway.
	      (downcase-region (1+ @-pos) (point-max))))

	  ;; Done canonicalizing address.
	  ;; We are now back in extraction-buffer.

	  ;; Decide what part of the address to search to find the full name.

			 (forward-char 1))
		     ;; take into account deletions
		     (setq quote-end (- (point) 2))
		     (save-excursion
		       (backward-char 1)
		       (delete-char 1)
		       (goto-char quote-beg)
		       (or (eobp)
			   (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)
			   (delete-char 1)
			   (insert ?\ ))
		       (if \.-ends-name
			   (narrow-to-region (point-min) (point))
			 (delete-char 1)
			 (insert " ")))
		     ;;		 (setq mailbox-name-processed-flag t)
		     )
		    ((memq (char-syntax char) '(?. ?\\))
		     (delete-char 1)
		     (insert " ")
		     ;;		 (setq mailbox-name-processed-flag t)
		     )
		    (t
		     (setq atom-beg (point))

			;; *** 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.
			 (mapc
			  (lambda (field-pattern)
			    (when
				(save-excursion
				  (re-search-forward field-pattern nil t))
			      (insert-buffer-substring (current-buffer)
						       (match-beginning 1)
						       (match-end 1))
			      (insert " ")))
			  (list mail-extr-x400-encoded-address-given-name-pattern
				mail-extr-x400-encoded-address-surname-pattern
				mail-extr-x400-encoded-address-full-name-pattern))

			 ;; Discard the rest, since it contains stuff like

	  ;; 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 <[e-mail]>
	  ;; *** Make it work when there's a suffix as well.
	  (goto-char (point-min))
	  (when (and mail-extr-guess-middle-initial
		     (not disable-initial-guessing-flag)
		     (eq 3 (- mbox-end mbox-beg))
		     (progn
		       (goto-char (point-min))
		       (looking-at mail-extr-two-name-pattern)))
	    (setq fi (char-after (match-beginning 0))
		  li (char-after (match-beginning 3)))
	    (with-current-buffer canonicalization-buffer
	      ;; char-equal is ignoring case here, so no need to upcase
	      ;; or downcase.
	      (let ((case-fold-search t))
		(and (char-equal fi (char-after mbox-beg))
		     (char-equal li (char-after (1- mbox-end)))
		     (setq mi (char-after (1+ mbox-beg))))))
	    (when (and mi
		       ;; TODO: use better table than syntax table
		       (eq ?w (char-syntax mi)))
	      (goto-char (match-beginning 3))
	      (insert (upcase mi) ". ")))

	  ;; Nuke name if it is the same as mailbox name.
	  (let ((buffer-length (- (point-max) (point-min)))
		(i 0)
		(names-match-flag t))
	    (when (and (> buffer-length 0)
		       (eq buffer-length (- mbox-end mbox-beg)))
	      (goto-char (point-max))
	      (insert-buffer-substring canonicalization-buffer
				       mbox-beg mbox-end)
	      (while (and names-match-flag
			  (< i buffer-length))
		(or (eq (downcase (char-after (+ i (point-min))))
			(downcase
			 (char-after (+ i buffer-length (point-min)))))
		    (setq names-match-flag nil))
		(setq i (1+ i)))
	      (delete-region (+ (point-min) buffer-length) (point-max))
	      (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))

	  ;; Record the result
	  (setq value-list
		(cons (list (if (not (= (point-min) (point-max)))
				(buffer-string))
			    (with-current-buffer canonicalization-buffer
			      (if (not (= (point-min) (point-max)))
				  (buffer-string))))
		      value-list))

	  ;; Unless one address is all we wanted,

      (while (not (eobp))
	;; Initialize for this iteration of the loop.
	(skip-chars-forward "^({[\"'`")
	(let ((cbeg (point)))
	  (set-syntax-table mail-extr-address-text-comment-syntax-table)
	  (if (memq (following-char) '(?\' ?\`))
	      (search-forward "'" nil 'move
			      (if (eq ?\' (following-char)) 2 1))
	    (or (mail-extr-safe-move-sexp 1)
		(goto-char (point-max))))
	  (set-syntax-table mail-extr-address-text-syntax-table)
	  (when (eq (char-after cbeg) ?\()
	    ;; Delete the comment itself.
	    (delete-region cbeg (point))
	    ;; Canonicalize whitespace where the comment was.

      ;;   "Piet.Rypens" <[e-mail]>
      ;;(goto-char (point-min))
      ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
      ;;  (replace-match "\\1 \\2" t))

      (unless (search-forward " " nil t)
	(goto-char (point-min))
	(cond ((search-forward "_" nil t)
	       ;; Handle the *idiotic* use of underlines as spaces.
	       ;; Example: [e-mail] (First_M._Last)
	       (goto-char (point-min))
	       (while (search-forward "_" nil t)
		 (replace-match " " t)))
	      ((search-forward "." nil t)
	       ;; Fix . used as space
	       ;; Example: [e-mail] (daniel.jacobson)
	       (goto-char (point-min))
	       (while (re-search-forward mail-extr-bad-dot-pattern nil t)
		 (replace-match "\\1 \\2" t)))))

      ;; Loop over the words (and other junk) in the name.
      (goto-char (point-min))
      (while (not name-done-flag)
	
	(when word-found-flag
	  ;; Last time through this loop we skipped over a word.
	  (setq last-word-beg this-word-beg)
	  (setq drop-last-word-if-trailing-flag
		drop-this-word-if-trailing-flag)
	  (setq word-found-flag nil))

	(when begin-again-flag
	  ;; Last time through the loop we found something that
	  ;; indicates we should pretend we are beginning again from
	  ;; the start.
	  (setq word-count 0)
	  (setq last-word-beg nil)
	  (setq drop-last-word-if-trailing-flag nil)
	  (setq mixed-case-flag nil)
	  (setq lower-case-flag nil)
	  ;;	       (setq upper-case-flag nil)
	  (setq begin-again-flag nil))
	
	;; Initialize for this iteration of the loop.
	(mail-extr-skip-whitespace-forward)
	(if (eq word-count 0) (narrow-to-region (point) (point-max)))
	(setq this-word-beg (point))

	  (setq cbeg (point))
	  (set-syntax-table mail-extr-address-text-comment-syntax-table)
	  (cond ((memq (following-char) '(?\' ?\`))
		 (or (search-forward "'" nil t
				     (if (eq ?\' (following-char)) 2 1))
		     (delete-char 1)))
		(t
		 (or (mail-extr-safe-move-sexp 1)
		     (goto-char (point-max)))))
	  (set-syntax-table mail-extr-address-text-syntax-table)
	  (setq cend (point))

	 ;; Handle & substitution, when & is last and is not first.
	 ((and (> word-count 0)
	       (eq ?\  (preceding-char))
	       (eq (following-char) ?&)
	       (eq (1+ (point)) (point-max)))
	  (delete-char 1)
	  (capitalize-region
	   (point)
	   (progn
	     (insert-buffer-substring canonicalization-buffer
				      mbox-beg mbox-end)

      ;; We simply refuse to believe that any last name is PARC or ADOC.
      ;; If it looks like that is the last name, that there is no meaningful
      ;; here at all.  Actually I guess it would be best to map patterns
      ;; like [e-mail] into [e-mail], but I don't
      ;; actually know that that is what's going on.
      (unless suffix-flag
	(goto-char (point-min))
	(let ((case-fold-search t))
	  (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
	      (erase-buffer))))

      ;; If last name first put it at end (but before suffix)
      (when last-name-comma-flag
	(goto-char (point-min))
	(search-forward ",")
	(setq name-end (1- (point)))
	(goto-char (or suffix-flag (point-max)))
	(or (eq ?\  (preceding-char))
	    (insert ?\ ))
	(insert-buffer-substring (current-buffer) (point-min) name-end)
	(goto-char name-end)
	(skip-chars-forward "\t ,")
	(narrow-to-region (point) (point-max)))
      
      ;; Delete leading and trailing junk characters.
      ;; *** This is probably completely unneeded now.
      ;;(goto-char (point-max))
      ;;(skip-chars-backward mail-extr-non-end-name-chars)

;; a U.S. FIPS that specifies a different set of two-letter country
;; abbreviations.

(defconst mail-extr-all-top-level-domains
  (let ((ob (make-vector 739 0)))
    (mapc
     (lambda (x)
       (put (intern (downcase (car x)) ob)
	    'domain-name
	    (if (nth 2 x)
		(format (nth 2 x) (nth 1 x))
	      (nth 1 x))))
     '(
       ;; ISO 3166 codes:
       ("ad" "Andorra")
       ("ae" "United Arab Emirates")
       ("af" "Afghanistan")