Function: mail-extract-address-components
mail-extract-address-components is an autoloaded and byte-compiled
function defined in mail-extr.el.gz.
Signature
(mail-extract-address-components ADDRESS &optional ALL)
Documentation
Extract full name and canonical address from ADDRESS.
ADDRESS should be in RFC 822 (or later) format.
Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). If no
name can be extracted, FULL-NAME will be nil. Also see
mail-extr-ignore-single-names and
mail-extr-ignore-realname-equals-mailbox-name.
If the optional argument ALL is non-nil, then ADDRESS can contain zero or more recipients, separated by commas, and we return a list of 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.)
This function is primarily meant for when you're displaying the
result to the user: Many prettifications are applied to the
result returned. If you want to decode an address for further
non-display use, you should probably use
mail-header-parse-address instead. Also see
mail-header-parse-address-lax for a function that's less strict
than mail-header-parse-address, but does less post-processing
to the results.
Probably introduced at or before Emacs version 19.1.
Source Code
;; Defined in /usr/src/emacs/lisp/mail/mail-extr.el.gz
(defvar mail-extr-all-top-level-domains) ; Defined below.
;;;###autoload
(defun mail-extract-address-components (address &optional all)
"Extract full name and canonical address from ADDRESS.
ADDRESS should be in RFC 822 (or later) format.
Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). If no
name can be extracted, FULL-NAME will be nil. Also see
`mail-extr-ignore-single-names' and
`mail-extr-ignore-realname-equals-mailbox-name'.
If the optional argument ALL is non-nil, then ADDRESS can contain zero
or more recipients, separated by commas, and we return a list of
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.)
This function is primarily meant for when you're displaying the
result to the user: Many prettifications are applied to the
result returned. If you want to decode an address for further
non-display use, you should probably use
`mail-header-parse-address' instead. Also see
`mail-header-parse-address-lax' for a function that's less strict
than `mail-header-parse-address', but does less post-processing
to the results."
(let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
(extraction-buffer (get-buffer-create " *extract address components*"))
value-list)
(with-current-buffer (get-buffer-create extraction-buffer)
(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 ?\ )
;; Insert the address itself.
(cond ((stringp address)
(insert address))
((bufferp address)
(insert-buffer-substring address))
(t
(error "Invalid address: %s" address)))
(set-text-properties (point-min) (point-max) nil)
(with-current-buffer (get-buffer-create canonicalization-buffer)
(buffer-disable-undo canonicalization-buffer)
(setq case-fold-search nil))
;; Unfold multiple lines.
(goto-char (point-min))
(while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t)
(replace-match "\\1 " t))
;; Loop over addresses until we have as many as we want.
(while (and (or all (null value-list))
(progn (goto-char (point-min))
(skip-chars-forward " \t")
(not (eobp))))
(let (char
end-of-address
<-pos >-pos @-pos colon-pos comma-pos !-pos %-pos \;-pos
group-:-pos group-\;-pos route-addr-:-pos
first-real-pos last-real-pos
phrase-beg phrase-end
;; Dynamically set in mail-extr-voodoo.
mailextr-cbeg mailextr-cend
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
(set-syntax-table mail-extr-address-syntax-table)
(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 mailextr-cbeg)
(save-excursion
(forward-char 1)
(mail-extr-skip-whitespace-forward)
(not (eq ?\) (char-after (point))))))
(setq mailextr-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 mailextr-cbeg
(not mailextr-cend))
(setq mailextr-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!
(< (car (last <-pos)) (car >-pos)))))
;; The argument contains more than one address.
;; Temporarily hide everything after this one.
(setq end-of-address (copy-marker (1+ (point)) t))
(narrow-to-region (point-min) (1+ (point)))
(delete-char 1)
(setq char ?\() ; HAVE I NO SHAME??
)
;; record the position of various interesting chars, determine
;; validity later.
((memq char '(?< ?> ?@ ?: ?, ?! ?% ?\;))
(push (point) (pcase-exhaustive char
(?< <-pos)
(?> >-pos)
(?@ @-pos)
(?: colon-pos)
(?, comma-pos)
(?! !-pos)
(?% %-pos)
(?\; \;-pos)))
(forward-char 1))
((eq char ?.)
(forward-char 1))
((memq char '(
;; comment terminator invalid
?\)
;; domain literal terminator invalid
?\]
;; \ allowed only within quoted strings,
;; domain literals, and comments
?\\
))
(mail-extr-nuke-char-at (point))
(forward-char 1))
(t
;; Do `(forward-word 1)', recognizing non-ASCII characters
;; except Latin-1 nbsp as words.
(while (progn
(skip-chars-forward "^\000-\177 ")
(and (not (eobp))
(eq ?w (char-syntax (char-after)))
(progn
(forward-word-strictly 1)
(and (not (eobp))
(> (char-after) ?\177)
(not (eq (char-after) ? )))))))))
(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.
(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 (or later)
;; by sticking punctuation marks outside of a < > pair.
(mail-extr-nuke-outside-range @-pos <-pos >-pos t)
;; RFC 822 (or later) 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
(setq temp (car colon-pos)
colon-pos (cdr colon-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.
(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)
(and last-real-pos
(> last-real-pos (1+ group-\;-pos))
(setq last-real-pos (1+ group-\;-pos)))
;; *** This may be wrong:
(and mailextr-cend
(> mailextr-cend group-\;-pos)
(setq mailextr-cend nil
mailextr-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 and nuke all of the commas.
;; **** This will cause problems when we start handling commas in
;; the PHRASE part .... no it won't ... yes it will ... ?????
(mail-extr-nuke-outside-range comma-pos 1 1)
;; 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
(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.
(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.
(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)
(mailextr-cbeg
(narrow-to-region (1+ mailextr-cbeg) (1- mailextr-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)))
(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)
(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))
(forward-word-strictly 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 or later.
;; *** 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.
(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
;; 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)))
))
(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))
(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))
(and names-match-flag
mail-extr-ignore-realname-equals-mailbox-name
(narrow-to-region (point) (point)))))
;; Nuke name if it's just one word.
(goto-char (point-min))
(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))
(with-current-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))
))