Mercurial > emacs
changeset 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.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Mon, 19 Nov 2001 23:16:21 +0000 |
| parents | 77b08a460f84 |
| children | f13ec83c07b9 |
| files | lisp/mail/mail-extr.el |
| diffstat | 1 files changed, 319 insertions(+), 338 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/mail/mail-extr.el Mon Nov 19 23:09:28 2001 +0000 +++ b/lisp/mail/mail-extr.el Mon Nov 19 23:16:21 2001 +0000 @@ -511,24 +511,20 @@ (defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table)) (defconst mail-extr-address-text-comment-syntax-table (make-syntax-table)) (defconst mail-extr-address-text-syntax-table (make-syntax-table)) -(mapcar - (function - (lambda (pair) - (let ((syntax-table (symbol-value (car pair)))) - (mapcar - (function - (lambda (item) - (if (eq 2 (length item)) - ;; modifying syntax of a single character - (modify-syntax-entry (car item) (car (cdr item)) syntax-table) - ;; modifying syntax of a range of characters - (let ((char (nth 0 item)) - (bound (nth 1 item)) - (syntax (nth 2 item))) - (while (<= char bound) - (modify-syntax-entry char syntax syntax-table) - (setq char (1+ char))))))) - (cdr pair))))) +(mapc + (lambda (pair) + (let ((syntax-table (symbol-value (car pair)))) + (dolist (item (cdr pair)) + (if (eq 2 (length item)) + ;; modifying syntax of a single character + (modify-syntax-entry (car item) (car (cdr item)) syntax-table) + ;; modifying syntax of a range of characters + (let ((char (nth 0 item)) + (bound (nth 1 item)) + (syntax (nth 2 item))) + (while (<= char bound) + (modify-syntax-entry char syntax syntax-table) + (setq char (1+ char)))))))) '((mail-extr-address-syntax-table (?\000 ?\037 "w") ;control characters (?\040 " ") ;SPC @@ -618,11 +614,6 @@ ;; 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")) @@ -639,14 +630,14 @@ (goto-char (point-min)) ;; undo \ quoting (while (search-forward "\\" nil t) - (mail-extr-delete-char -1) + (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) + (delete-char 1) (insert ?\ ))) (put 'mail-extr-nuke-outside-range @@ -655,27 +646,28 @@ (defmacro mail-extr-nuke-outside-range (list-symbol beg-symbol end-symbol &optional no-replace) - ;; LIST-SYMBOL names a variable holding a list of buffer positions - ;; BEG-SYMBOL and END-SYMBOL name variables delimiting a range - ;; Each element of LIST-SYMBOL which lies outside of the range is - ;; deleted from the list. - ;; Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL - ;; which lie outside of the range, one character at that position is - ;; replaced with a SPC. + "Delete all elements outside BEG..END in LIST. +LIST-SYMBOL names a variable holding a list of buffer positions +BEG-SYMBOL and END-SYMBOL name variables delimiting a range +Each element of LIST-SYMBOL which lies outside of the range is + deleted from the list. +Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL + which lie outside of the range, one character at that position is + replaced with a SPC." (or (memq no-replace '(t nil)) (error "no-replace must be t or nil, evaluable at macroexpand-time")) - (` (let ((temp (, list-symbol)) + `(let ((temp ,list-symbol) ch) (while temp (setq ch (car temp)) - (cond ((or (> ch (, end-symbol)) - (< ch (, beg-symbol))) - (,@ (if no-replace - nil - (` ((mail-extr-nuke-char-at ch))))) - (setcar temp nil))) + (when (or (> ch ,end-symbol) + (< ch ,beg-symbol)) + ,@(if no-replace + nil + `((mail-extr-nuke-char-at ch))) + (setcar temp nil)) (setq temp (cdr temp))) - (setq (, list-symbol) (delq nil (, list-symbol)))))) + (setq ,list-symbol (delq nil ,list-symbol)))) (defun mail-extr-demarkerize (marker) ;; if arg is a marker, destroys the marker, then returns the old value. @@ -909,27 +901,25 @@ ;; If multiple @s and a :, but no < and >, insert around buffer. ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc ;; This commonly happens on the UUCP "From " line. Ugh. - (cond ((and (> (length @-pos) 1) + (when (and (> (length @-pos) 1) (eq 1 (length colon-pos)) ;TODO: check if between last two @s (not \;-pos) (not <-pos)) - (goto-char (point-min)) - (mail-extr-delete-char 1) - (setq <-pos (list (point))) - (insert ?<))) + (goto-char (point-min)) + (delete-char 1) + (setq <-pos (list (point))) + (insert ?<)) ;; If < but no >, insert > in rightmost possible position - (cond ((and <-pos - (null >-pos)) - (goto-char (point-max)) - (setq >-pos (list (point))) - (insert ?>))) + (when (and <-pos (null >-pos)) + (goto-char (point-max)) + (setq >-pos (list (point))) + (insert ?>)) ;; If > but no <, replace > with space. - (cond ((and >-pos - (null <-pos)) - (mail-extr-nuke-char-at (car >-pos)) - (setq >-pos nil))) + (when (and >-pos (null <-pos)) + (mail-extr-nuke-char-at (car >-pos)) + (setq >-pos nil)) ;; Turn >-pos and <-pos into non-lists (setq >-pos (car >-pos) @@ -937,15 +927,15 @@ ;; Trim other punctuation lists of items outside < > pair to handle ;; stupid MTAs. - (cond (<-pos ; don't need to check >-pos also - ;; handle bozo software that violates RFC 822 by sticking - ;; punctuation marks outside of a < > pair - (mail-extr-nuke-outside-range @-pos <-pos >-pos t) - ;; RFC 822 says nothing about these two outside < >, but - ;; remove those positions from the lists to make things - ;; easier. - (mail-extr-nuke-outside-range !-pos <-pos >-pos t) - (mail-extr-nuke-outside-range %-pos <-pos >-pos t))) + (when <-pos ; don't need to check >-pos also + ;; handle bozo software that violates RFC 822 by sticking + ;; punctuation marks outside of a < > pair + (mail-extr-nuke-outside-range @-pos <-pos >-pos t) + ;; RFC 822 says nothing about these two outside < >, but + ;; remove those positions from the lists to make things + ;; easier. + (mail-extr-nuke-outside-range !-pos <-pos >-pos t) + (mail-extr-nuke-outside-range %-pos <-pos >-pos t)) ;; Check for : that indicates GROUP list and for : part of ;; ROUTE-ADDR spec. @@ -982,19 +972,18 @@ (setq group-\;-pos temp)))) ;; Nuke unmatched GROUP syntax characters. - (cond ((and group-:-pos (not group-\;-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-:-pos) - (setq group-:-pos nil))) - (cond ((and group-\;-pos (not group-:-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-\;-pos) - (setq group-\;-pos nil))) + (when (and group-:-pos (not group-\;-pos)) + ;; *** Do I really need to erase it? + (mail-extr-nuke-char-at group-:-pos) + (setq group-:-pos nil)) + (when (and group-\;-pos (not group-:-pos)) + ;; *** Do I really need to erase it? + (mail-extr-nuke-char-at group-\;-pos) + (setq group-\;-pos nil)) ;; Handle junk like ";@host.company.dom" that sendmail adds. ;; **** should I remember comment positions? - (cond - (group-\;-pos + (when group-\;-pos ;; this is fine for now (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t) (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t) @@ -1018,7 +1007,7 @@ ;; *** 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. @@ -1032,57 +1021,55 @@ ;; handled above. ;; Locate PHRASE part of ROUTE-ADDR. - (cond (<-pos - (goto-char <-pos) - (mail-extr-skip-whitespace-backward) - (setq phrase-end (point)) - (goto-char (or ;;group-:-pos - (point-min))) - (mail-extr-skip-whitespace-forward) - (if (< (point) phrase-end) - (setq phrase-beg (point)) - (setq phrase-end nil)))) + (when <-pos + (goto-char <-pos) + (mail-extr-skip-whitespace-backward) + (setq phrase-end (point)) + (goto-char (or ;;group-:-pos + (point-min))) + (mail-extr-skip-whitespace-forward) + (if (< (point) phrase-end) + (setq phrase-beg (point)) + (setq phrase-end nil))) ;; handle ROUTE-ADDRS with real ROUTEs. ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and ;; any % or ! must be semantically meaningless. ;; TODO: do this processing into canonicalization buffer - (cond (route-addr-:-pos - (setq !-pos nil - %-pos nil - >-pos (copy-marker >-pos) - route-addr-:-pos (copy-marker route-addr-:-pos)) - (goto-char >-pos) - (insert-before-markers ?X) - (goto-char (car @-pos)) - (while (setq @-pos (cdr @-pos)) - (mail-extr-delete-char 1) - (setq %-pos (cons (point-marker) %-pos)) - (insert "%") - (goto-char (1- >-pos)) - (save-excursion - (insert-buffer-substring extraction-buffer - (car @-pos) route-addr-:-pos) - (delete-region (car @-pos) route-addr-:-pos)) - (or (cdr @-pos) - (setq saved-@-pos (list (point))))) - (setq @-pos saved-@-pos) - (goto-char >-pos) - (mail-extr-delete-char -1) - (mail-extr-nuke-char-at route-addr-:-pos) - (mail-extr-demarkerize route-addr-:-pos) - (setq route-addr-:-pos nil - >-pos (mail-extr-demarkerize >-pos) - %-pos (mapcar 'mail-extr-demarkerize %-pos)))) + (when route-addr-:-pos + (setq !-pos nil + %-pos nil + >-pos (copy-marker >-pos) + route-addr-:-pos (copy-marker route-addr-:-pos)) + (goto-char >-pos) + (insert-before-markers ?X) + (goto-char (car @-pos)) + (while (setq @-pos (cdr @-pos)) + (delete-char 1) + (setq %-pos (cons (point-marker) %-pos)) + (insert "%") + (goto-char (1- >-pos)) + (save-excursion + (insert-buffer-substring extraction-buffer + (car @-pos) route-addr-:-pos) + (delete-region (car @-pos) route-addr-:-pos)) + (or (cdr @-pos) + (setq saved-@-pos (list (point))))) + (setq @-pos saved-@-pos) + (goto-char >-pos) + (delete-char -1) + (mail-extr-nuke-char-at route-addr-:-pos) + (mail-extr-demarkerize route-addr-:-pos) + (setq route-addr-:-pos nil + >-pos (mail-extr-demarkerize >-pos) + %-pos (mapcar 'mail-extr-demarkerize %-pos))) ;; de-listify @-pos (setq @-pos (car @-pos)) ;; TODO: remove comments in the middle of an address - (save-excursion - (set-buffer canonicalization-buffer) - + (with-current-buffer canonicalization-buffer (widen) (erase-buffer) (insert-buffer-substring extraction-buffer) @@ -1097,8 +1084,7 @@ (narrow-to-region first-real-pos last-real-pos) ;; ****** Oh no! What if the address is completely empty! ;; *** Is this correct? - (narrow-to-region (point-max) (point-max)) - )) + (narrow-to-region (point-max) (point-max)))) (and @-pos %-pos (mail-extr-nuke-outside-range %-pos (point-min) @-pos)) @@ -1110,118 +1096,119 @@ ;; 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)))) + (when (and %-pos (not @-pos)) + (goto-char (car %-pos)) + (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))))) + (when (and mail-extr-mangle-uucp !-pos) + ;; **** I don't understand this save-restriction and the + ;; narrow-to-region inside it. Why did I do that? + (save-restriction + (cond ((and @-pos + mail-extr-@-binds-tighter-than-!) + (goto-char @-pos) + (setq %-pos (cons (point) %-pos) + @-pos nil) + (delete-char 1) + (insert "%") + (setq insert-point (point-max))) + (mail-extr-@-binds-tighter-than-! + (setq insert-point (point-max))) + (%-pos + (setq insert-point (car (last %-pos)) + saved-%-pos (mapcar 'mail-extr-markerize %-pos) + %-pos nil + @-pos (mail-extr-markerize @-pos))) + (@-pos + (setq insert-point @-pos) + (setq @-pos (mail-extr-markerize @-pos))) + (t + (setq insert-point (point-max)))) + (narrow-to-region (point-min) insert-point) + (setq saved-!-pos (car !-pos)) + (while !-pos + (goto-char (point-max)) + (cond ((and (not @-pos) + (not (cdr !-pos))) + (setq @-pos (point)) + (insert-before-markers "@ ")) + (t + (setq %-pos (cons (point) %-pos)) + (insert-before-markers "% "))) + (backward-char 1) + (insert-buffer-substring + (current-buffer) + (if (nth 1 !-pos) + (1+ (nth 1 !-pos)) + (point-min)) + (car !-pos)) + (delete-char 1) + (or (save-excursion + (mail-extr-safe-move-sexp -1) + (mail-extr-skip-whitespace-backward) + (eq ?. (preceding-char))) + (insert-before-markers + (if (save-excursion + (mail-extr-skip-whitespace-backward) + (eq ?. (preceding-char))) + "" + ".") + "uucp")) + (setq !-pos (cdr !-pos)))) + (and saved-%-pos + (setq %-pos (append (mapcar 'mail-extr-demarkerize + saved-%-pos) + %-pos))) + (setq @-pos (mail-extr-demarkerize @-pos)) + (narrow-to-region (1+ saved-!-pos) (point-max))) ;; WARNING: THIS CODE IS DUPLICATED ABOVE. - (cond ((and %-pos - (not @-pos)) - (goto-char (car %-pos)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (insert "@") - (setq %-pos (cdr %-pos)))) + (when (and %-pos (not @-pos)) + (goto-char (car %-pos)) + (delete-char 1) + (setq @-pos (point)) + (insert "@") + (setq %-pos (cdr %-pos))) - (setq %-pos (nreverse %-pos)) - (cond (%-pos ; implies @-pos valid - (setq temp %-pos) - (catch 'truncated - (while temp - (goto-char (or (nth 1 temp) - @-pos)) - (mail-extr-skip-whitespace-backward) - (save-excursion - (mail-extr-safe-move-sexp -1) - (setq domain-pos (point)) - (mail-extr-skip-whitespace-backward) - (setq \.-pos (eq ?. (preceding-char)))) - (cond ((and \.-pos - ;; #### string consing - (let ((s (intern-soft - (buffer-substring domain-pos (point)) - mail-extr-all-top-level-domains))) - (and s (get s 'domain-name)))) - (narrow-to-region (point-min) (point)) - (goto-char (car temp)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (setcdr temp nil) - (setq %-pos (delq @-pos %-pos)) - (insert "@") - (throw 'truncated t))) - (setq temp (cdr temp)))))) + (when (setq %-pos (nreverse %-pos)) ; implies @-pos valid + (setq temp %-pos) + (catch 'truncated + (while temp + (goto-char (or (nth 1 temp) + @-pos)) + (mail-extr-skip-whitespace-backward) + (save-excursion + (mail-extr-safe-move-sexp -1) + (setq domain-pos (point)) + (mail-extr-skip-whitespace-backward) + (setq \.-pos (eq ?. (preceding-char)))) + (when (and \.-pos + ;; #### string consing + (let ((s (intern-soft + (buffer-substring domain-pos (point)) + mail-extr-all-top-level-domains))) + (and s (get s 'domain-name)))) + (narrow-to-region (point-min) (point)) + (goto-char (car temp)) + (delete-char 1) + (setq @-pos (point)) + (setcdr temp nil) + (setq %-pos (delq @-pos %-pos)) + (insert "@") + (throw 'truncated t)) + (setq temp (cdr temp))))) (setq mbox-beg (point-min) mbox-end (if %-pos (car %-pos) (or @-pos - (point-max))))) + (point-max)))) + + (when @-pos + ;; Make the domain-name part lowercase since it's case + ;; insensitive anyway. + (downcase-region (1+ @-pos) (point-max)))) ;; Done canonicalizing address. ;; We are now back in extraction-buffer. @@ -1295,10 +1282,10 @@ (setq quote-end (- (point) 2)) (save-excursion (backward-char 1) - (mail-extr-delete-char 1) + (delete-char 1) (goto-char quote-beg) (or (eobp) - (mail-extr-delete-char 1))) + (delete-char 1))) (mail-extr-undo-backslash-quoting quote-beg quote-end) (or (eq ?\ (char-after (point))) (insert " ")) @@ -1308,16 +1295,16 @@ (if (memq (char-after (1+ (point))) '(?_ ?=)) (progn (forward-char 1) - (mail-extr-delete-char 1) + (delete-char 1) (insert ?\ )) (if \.-ends-name (narrow-to-region (point-min) (point)) - (mail-extr-delete-char 1) + (delete-char 1) (insert " "))) ;; (setq mailbox-name-processed-flag t) ) ((memq (char-syntax char) '(?. ?\\)) - (mail-extr-delete-char 1) + (delete-char 1) (insert " ") ;; (setq mailbox-name-processed-flag t) ) @@ -1339,16 +1326,15 @@ ;; Copy the contents of the individual fields that ;; might hold name data to the beginning. - (mapcar - (function - (lambda (field-pattern) - (cond - ((save-excursion - (re-search-forward field-pattern nil t)) - (insert-buffer-substring (current-buffer) - (match-beginning 1) - (match-end 1)) - (insert " "))))) + (mapc + (lambda (field-pattern) + (when + (save-excursion + (re-search-forward field-pattern nil t)) + (insert-buffer-substring (current-buffer) + (match-beginning 1) + (match-end 1)) + (insert " "))) (list mail-extr-x400-encoded-address-given-name-pattern mail-extr-x400-encoded-address-surname-pattern mail-extr-x400-encoded-address-full-name-pattern)) @@ -1396,47 +1382,46 @@ ;; 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) ". "))))) + (when (and mail-extr-guess-middle-initial + (not disable-initial-guessing-flag) + (eq 3 (- mbox-end mbox-beg)) + (progn + (goto-char (point-min)) + (looking-at mail-extr-two-name-pattern))) + (setq fi (char-after (match-beginning 0)) + li (char-after (match-beginning 3))) + (with-current-buffer canonicalization-buffer + ;; char-equal is ignoring case here, so no need to upcase + ;; or downcase. + (let ((case-fold-search t)) + (and (char-equal fi (char-after mbox-beg)) + (char-equal li (char-after (1- mbox-end))) + (setq mi (char-after (1+ mbox-beg)))))) + (when (and mi + ;; TODO: use better table than syntax table + (eq ?w (char-syntax mi))) + (goto-char (match-beginning 3)) + (insert (upcase mi) ". "))) ;; Nuke name if it is the same as mailbox name. (let ((buffer-length (- (point-max) (point-min))) (i 0) (names-match-flag t)) - (cond ((and (> buffer-length 0) - (eq buffer-length (- mbox-end mbox-beg))) - (goto-char (point-max)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (while (and names-match-flag - (< i buffer-length)) - (or (eq (downcase (char-after (+ i (point-min)))) - (downcase - (char-after (+ i buffer-length (point-min))))) - (setq names-match-flag nil)) - (setq i (1+ i))) - (delete-region (+ (point-min) buffer-length) (point-max)) - (if names-match-flag - (narrow-to-region (point) (point)))))) + (when (and (> buffer-length 0) + (eq buffer-length (- mbox-end mbox-beg))) + (goto-char (point-max)) + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (while (and names-match-flag + (< i buffer-length)) + (or (eq (downcase (char-after (+ i (point-min)))) + (downcase + (char-after (+ i buffer-length (point-min))))) + (setq names-match-flag nil)) + (setq i (1+ i))) + (delete-region (+ (point-min) buffer-length) (point-max)) + (if names-match-flag + (narrow-to-region (point) (point))))) ;; Nuke name if it's just one word. (goto-char (point-min)) @@ -1448,8 +1433,7 @@ (setq value-list (cons (list (if (not (= (point-min) (point-max))) (buffer-string)) - (save-excursion - (set-buffer canonicalization-buffer) + (with-current-buffer canonicalization-buffer (if (not (= (point-min) (point-max))) (buffer-string)))) value-list)) @@ -1492,12 +1476,11 @@ (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))))) + (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. @@ -1522,44 +1505,43 @@ ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) ;; (replace-match "\\1 \\2" t)) - (cond ((not (search-forward " " nil t)) - (goto-char (point-min)) - (cond ((search-forward "_" nil t) - ;; Handle the *idiotic* use of underlines as spaces. - ;; Example: fml@foo.bar.dom (First_M._Last) - (goto-char (point-min)) - (while (search-forward "_" nil t) - (replace-match " " t))) - ((search-forward "." nil t) - ;; Fix . used as space - ;; Example: danj1@cb.att.com (daniel.jacobson) - (goto-char (point-min)) - (while (re-search-forward mail-extr-bad-dot-pattern nil t) - (replace-match "\\1 \\2" t)))))) + (unless (search-forward " " nil t) + (goto-char (point-min)) + (cond ((search-forward "_" nil t) + ;; Handle the *idiotic* use of underlines as spaces. + ;; Example: fml@foo.bar.dom (First_M._Last) + (goto-char (point-min)) + (while (search-forward "_" nil t) + (replace-match " " t))) + ((search-forward "." nil t) + ;; Fix . used as space + ;; Example: danj1@cb.att.com (daniel.jacobson) + (goto-char (point-min)) + (while (re-search-forward mail-extr-bad-dot-pattern nil t) + (replace-match "\\1 \\2" t))))) ;; Loop over the words (and other junk) in the name. (goto-char (point-min)) (while (not name-done-flag) - (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))) + (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)) - (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) - )) + (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) @@ -1625,7 +1607,7 @@ (cond ((memq (following-char) '(?\' ?\`)) (or (search-forward "'" nil t (if (eq ?\' (following-char)) 2 1)) - (mail-extr-delete-char 1))) + (delete-char 1))) (t (or (mail-extr-safe-move-sexp 1) (goto-char (point-max))))) @@ -1718,7 +1700,7 @@ (eq ?\ (preceding-char)) (eq (following-char) ?&) (eq (1+ (point)) (point-max))) - (mail-extr-delete-char 1) + (delete-char 1) (capitalize-region (point) (progn @@ -1801,24 +1783,24 @@ ;; here at all. Actually I guess it would be best to map patterns ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't ;; actually know that that is what's going on. - (cond ((not suffix-flag) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") - (erase-buffer))))) + (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) - (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)))) + (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. @@ -1851,14 +1833,13 @@ (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))))) + (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")