/[emacs]/emacs/lisp/mail/mail-extr.el
ViewVC logotype

Diff of /emacs/lisp/mail/mail-extr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.35 by rms, Fri Nov 16 19:54:57 2001 UTC revision 1.36 by monnier, Mon Nov 19 23:16:21 2001 UTC
# Line 511  by translating things like \"foo!bar!baz Line 511  by translating things like \"foo!bar!baz
511  (defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table))  (defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table))
512  (defconst mail-extr-address-text-comment-syntax-table (make-syntax-table))  (defconst mail-extr-address-text-comment-syntax-table (make-syntax-table))
513  (defconst mail-extr-address-text-syntax-table (make-syntax-table))  (defconst mail-extr-address-text-syntax-table (make-syntax-table))
514  (mapcar  (mapc
515   (function   (lambda (pair)
516    (lambda (pair)     (let ((syntax-table (symbol-value (car pair))))
517      (let ((syntax-table (symbol-value (car pair))))       (dolist (item (cdr pair))
518        (mapcar         (if (eq 2 (length item))
519         (function             ;; modifying syntax of a single character
520          (lambda (item)             (modify-syntax-entry (car item) (car (cdr item)) syntax-table)
521            (if (eq 2 (length item))           ;; modifying syntax of a range of characters
522                ;; modifying syntax of a single character           (let ((char (nth 0 item))
523                (modify-syntax-entry (car item) (car (cdr item)) syntax-table)                 (bound (nth 1 item))
524              ;; modifying syntax of a range of characters                 (syntax (nth 2 item)))
525              (let ((char (nth 0 item))             (while (<= char bound)
526                    (bound (nth 1 item))               (modify-syntax-entry char syntax syntax-table)
527                    (syntax (nth 2 item)))               (setq char (1+ char))))))))
               (while (<= char bound)  
                 (modify-syntax-entry char syntax syntax-table)  
                 (setq char (1+ char)))))))  
        (cdr pair)))))  
528   '((mail-extr-address-syntax-table   '((mail-extr-address-syntax-table
529      (?\000 ?\037 "w")                   ;control characters      (?\000 ?\037 "w")                   ;control characters
530      (?\040       " ")                   ;SPC      (?\040       " ")                   ;SPC
# Line 618  by translating things like \"foo!bar!baz Line 614  by translating things like \"foo!bar!baz
614  ;; Utility functions and macros.  ;; Utility functions and macros.
615  ;;  ;;
616    
 (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)))  
   
617  (defsubst mail-extr-skip-whitespace-forward ()  (defsubst mail-extr-skip-whitespace-forward ()
618    ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.    ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
619    (skip-chars-forward " \t\n\r\240"))    (skip-chars-forward " \t\n\r\240"))
# Line 639  by translating things like \"foo!bar!baz Line 630  by translating things like \"foo!bar!baz
630        (goto-char (point-min))        (goto-char (point-min))
631        ;; undo \ quoting        ;; undo \ quoting
632        (while (search-forward "\\" nil t)        (while (search-forward "\\" nil t)
633          (mail-extr-delete-char -1)          (delete-char -1)
634          (or (eobp)          (or (eobp)
635              (forward-char 1))))))              (forward-char 1))))))
636    
637  (defsubst mail-extr-nuke-char-at (pos)  (defsubst mail-extr-nuke-char-at (pos)
638    (save-excursion    (save-excursion
639      (goto-char pos)      (goto-char pos)
640      (mail-extr-delete-char 1)      (delete-char 1)
641      (insert ?\ )))      (insert ?\ )))
642    
643  (put 'mail-extr-nuke-outside-range  (put 'mail-extr-nuke-outside-range
# Line 655  by translating things like \"foo!bar!baz Line 646  by translating things like \"foo!bar!baz
646  (defmacro mail-extr-nuke-outside-range (list-symbol  (defmacro mail-extr-nuke-outside-range (list-symbol
647                                          beg-symbol end-symbol                                          beg-symbol end-symbol
648                                          &optional no-replace)                                          &optional no-replace)
649    ;; LIST-SYMBOL names a variable holding a list of buffer positions    "Delete all elements outside BEG..END in LIST.
650    ;; BEG-SYMBOL and END-SYMBOL name variables delimiting a range  LIST-SYMBOL names a variable holding a list of buffer positions
651    ;; Each element of LIST-SYMBOL which lies outside of the range is  BEG-SYMBOL and END-SYMBOL name variables delimiting a range
652    ;;  deleted from the list.  Each element of LIST-SYMBOL which lies outside of the range is
653    ;; Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL   deleted from the list.
654    ;;  which lie outside of the range, one character at that position is  Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
655    ;;  replaced with a SPC.   which lie outside of the range, one character at that position is
656     replaced with a SPC."
657    (or (memq no-replace '(t nil))    (or (memq no-replace '(t nil))
658        (error "no-replace must be t or nil, evaluable at macroexpand-time"))        (error "no-replace must be t or nil, evaluable at macroexpand-time"))
659    (` (let ((temp (, list-symbol))    `(let ((temp ,list-symbol)
660             ch)             ch)
661         (while temp         (while temp
662           (setq ch (car temp))           (setq ch (car temp))
663           (cond ((or (> ch (, end-symbol))           (when (or (> ch ,end-symbol)
664                      (< ch (, beg-symbol)))                     (< ch ,beg-symbol))
665                  (,@ (if no-replace             ,@(if no-replace
666                          nil                     nil
667                        (` ((mail-extr-nuke-char-at ch)))))                   `((mail-extr-nuke-char-at ch)))
668                  (setcar temp nil)))             (setcar temp nil))
669           (setq temp (cdr temp)))           (setq temp (cdr temp)))
670         (setq (, list-symbol) (delq nil (, list-symbol))))))         (setq ,list-symbol (delq nil ,list-symbol))))
671    
672  (defun mail-extr-demarkerize (marker)  (defun mail-extr-demarkerize (marker)
673    ;; if arg is a marker, destroys the marker, then returns the old value.    ;; if arg is a marker, destroys the marker, then returns the old value.
# Line 909  ADDRESS may be a string or a buffer.  If Line 901  ADDRESS may be a string or a buffer.  If
901            ;; If multiple @s and a :, but no < and >, insert around buffer.            ;; If multiple @s and a :, but no < and >, insert around buffer.
902            ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc            ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc
903            ;; This commonly happens on the UUCP "From " line.  Ugh.            ;; This commonly happens on the UUCP "From " line.  Ugh.
904            (cond ((and (> (length @-pos) 1)            (when (and (> (length @-pos) 1)
905                        (eq 1 (length colon-pos)) ;TODO: check if between last two @s                        (eq 1 (length colon-pos)) ;TODO: check if between last two @s
906                        (not \;-pos)                        (not \;-pos)
907                        (not <-pos))                        (not <-pos))
908                   (goto-char (point-min))              (goto-char (point-min))
909                   (mail-extr-delete-char 1)              (delete-char 1)
910                   (setq <-pos (list (point)))              (setq <-pos (list (point)))
911                   (insert ?<)))              (insert ?<))
912    
913            ;; If < but no >, insert > in rightmost possible position            ;; If < but no >, insert > in rightmost possible position
914            (cond ((and <-pos            (when (and <-pos (null >-pos))
915                        (null >-pos))              (goto-char (point-max))
916                   (goto-char (point-max))              (setq >-pos (list (point)))
917                   (setq >-pos (list (point)))              (insert ?>))
                  (insert ?>)))  
918    
919            ;; If > but no <, replace > with space.            ;; If > but no <, replace > with space.
920            (cond ((and >-pos            (when (and >-pos (null <-pos))
921                        (null <-pos))              (mail-extr-nuke-char-at (car >-pos))
922                   (mail-extr-nuke-char-at (car >-pos))              (setq >-pos nil))
                  (setq >-pos nil)))  
923    
924            ;; Turn >-pos and <-pos into non-lists            ;; Turn >-pos and <-pos into non-lists
925            (setq >-pos (car >-pos)            (setq >-pos (car >-pos)
# Line 937  ADDRESS may be a string or a buffer.  If Line 927  ADDRESS may be a string or a buffer.  If
927    
928            ;; Trim other punctuation lists of items outside < > pair to handle            ;; Trim other punctuation lists of items outside < > pair to handle
929            ;; stupid MTAs.            ;; stupid MTAs.
930            (cond (<-pos                  ; don't need to check >-pos also            (when <-pos                   ; don't need to check >-pos also
931                   ;; handle bozo software that violates RFC 822 by sticking              ;; handle bozo software that violates RFC 822 by sticking
932                   ;; punctuation marks outside of a < > pair              ;; punctuation marks outside of a < > pair
933                   (mail-extr-nuke-outside-range @-pos <-pos >-pos t)              (mail-extr-nuke-outside-range @-pos <-pos >-pos t)
934                   ;; RFC 822 says nothing about these two outside < >, but              ;; RFC 822 says nothing about these two outside < >, but
935                   ;; remove those positions from the lists to make things              ;; remove those positions from the lists to make things
936                   ;; easier.              ;; easier.
937                   (mail-extr-nuke-outside-range !-pos <-pos >-pos t)              (mail-extr-nuke-outside-range !-pos <-pos >-pos t)
938                   (mail-extr-nuke-outside-range %-pos <-pos >-pos t)))              (mail-extr-nuke-outside-range %-pos <-pos >-pos t))
939    
940            ;; Check for : that indicates GROUP list and for : part of            ;; Check for : that indicates GROUP list and for : part of
941            ;; ROUTE-ADDR spec.            ;; ROUTE-ADDR spec.
# Line 982  ADDRESS may be a string or a buffer.  If Line 972  ADDRESS may be a string or a buffer.  If
972                     (setq group-\;-pos temp))))                     (setq group-\;-pos temp))))
973    
974            ;; Nuke unmatched GROUP syntax characters.            ;; Nuke unmatched GROUP syntax characters.
975            (cond ((and group-:-pos (not group-\;-pos))            (when (and group-:-pos (not group-\;-pos))
976                   ;; *** Do I really need to erase it?              ;; *** Do I really need to erase it?
977                   (mail-extr-nuke-char-at group-:-pos)              (mail-extr-nuke-char-at group-:-pos)
978                   (setq group-:-pos nil)))              (setq group-:-pos nil))
979            (cond ((and group-\;-pos (not group-:-pos))            (when (and group-\;-pos (not group-:-pos))
980                   ;; *** Do I really need to erase it?              ;; *** Do I really need to erase it?
981                   (mail-extr-nuke-char-at group-\;-pos)              (mail-extr-nuke-char-at group-\;-pos)
982                   (setq group-\;-pos nil)))              (setq group-\;-pos nil))
983    
984            ;; Handle junk like ";@host.company.dom" that sendmail adds.            ;; Handle junk like ";@host.company.dom" that sendmail adds.
985            ;; **** should I remember comment positions?            ;; **** should I remember comment positions?
986            (cond            (when group-\;-pos
            (group-\;-pos  
987              ;; this is fine for now              ;; this is fine for now
988              (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t)              (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t)
989              (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t)              (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t)
# Line 1018  ADDRESS may be a string or a buffer.  If Line 1007  ADDRESS may be a string or a buffer.  If
1007              ;; *** The entire handling of GROUP addresses seems rather lame.              ;; *** The entire handling of GROUP addresses seems rather lame.
1008              ;; *** It deserves a complete rethink, except that these addresses              ;; *** It deserves a complete rethink, except that these addresses
1009              ;; *** are hardly ever seen.              ;; *** are hardly ever seen.
1010              ))              )
1011    
1012            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any            ;; Any commas must be between < and : of ROUTE-ADDR.  Nuke any
1013            ;; others.            ;; others.
# Line 1032  ADDRESS may be a string or a buffer.  If Line 1021  ADDRESS may be a string or a buffer.  If
1021            ;; handled above.            ;; handled above.
1022    
1023            ;; Locate PHRASE part of ROUTE-ADDR.            ;; Locate PHRASE part of ROUTE-ADDR.
1024            (cond (<-pos            (when <-pos
1025                   (goto-char <-pos)              (goto-char <-pos)
1026                   (mail-extr-skip-whitespace-backward)              (mail-extr-skip-whitespace-backward)
1027                   (setq phrase-end (point))              (setq phrase-end (point))
1028                   (goto-char (or ;;group-:-pos              (goto-char (or ;;group-:-pos
1029                                  (point-min)))                          (point-min)))
1030                   (mail-extr-skip-whitespace-forward)              (mail-extr-skip-whitespace-forward)
1031                   (if (< (point) phrase-end)              (if (< (point) phrase-end)
1032                       (setq phrase-beg (point))                  (setq phrase-beg (point))
1033                     (setq phrase-end nil))))                (setq phrase-end nil)))
1034    
1035            ;; handle ROUTE-ADDRS with real ROUTEs.            ;; handle ROUTE-ADDRS with real ROUTEs.
1036            ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and            ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and
1037            ;; any % or ! must be semantically meaningless.            ;; any % or ! must be semantically meaningless.
1038            ;; TODO: do this processing into canonicalization buffer            ;; TODO: do this processing into canonicalization buffer
1039            (cond (route-addr-:-pos            (when route-addr-:-pos
1040                   (setq !-pos nil              (setq !-pos nil
1041                         %-pos nil                    %-pos nil
1042                         >-pos (copy-marker >-pos)                    >-pos (copy-marker >-pos)
1043                         route-addr-:-pos (copy-marker route-addr-:-pos))                    route-addr-:-pos (copy-marker route-addr-:-pos))
1044                   (goto-char >-pos)              (goto-char >-pos)
1045                   (insert-before-markers ?X)              (insert-before-markers ?X)
1046                   (goto-char (car @-pos))              (goto-char (car @-pos))
1047                   (while (setq @-pos (cdr @-pos))              (while (setq @-pos (cdr @-pos))
1048                     (mail-extr-delete-char 1)                (delete-char 1)
1049                     (setq %-pos (cons (point-marker) %-pos))                (setq %-pos (cons (point-marker) %-pos))
1050                     (insert "%")                (insert "%")
1051                     (goto-char (1- >-pos))                (goto-char (1- >-pos))
1052                     (save-excursion                (save-excursion
1053                       (insert-buffer-substring extraction-buffer                  (insert-buffer-substring extraction-buffer
1054                                                (car @-pos) route-addr-:-pos)                                           (car @-pos) route-addr-:-pos)
1055                       (delete-region (car @-pos) route-addr-:-pos))                  (delete-region (car @-pos) route-addr-:-pos))
1056                     (or (cdr @-pos)                (or (cdr @-pos)
1057                         (setq saved-@-pos (list (point)))))                    (setq saved-@-pos (list (point)))))
1058                   (setq @-pos saved-@-pos)              (setq @-pos saved-@-pos)
1059                   (goto-char >-pos)              (goto-char >-pos)
1060                   (mail-extr-delete-char -1)              (delete-char -1)
1061                   (mail-extr-nuke-char-at route-addr-:-pos)              (mail-extr-nuke-char-at route-addr-:-pos)
1062                   (mail-extr-demarkerize route-addr-:-pos)              (mail-extr-demarkerize route-addr-:-pos)
1063                   (setq route-addr-:-pos nil              (setq route-addr-:-pos nil
1064                         >-pos (mail-extr-demarkerize >-pos)                    >-pos (mail-extr-demarkerize >-pos)
1065                         %-pos (mapcar 'mail-extr-demarkerize %-pos))))                    %-pos (mapcar 'mail-extr-demarkerize %-pos)))
1066    
1067            ;; de-listify @-pos            ;; de-listify @-pos
1068            (setq @-pos (car @-pos))            (setq @-pos (car @-pos))
1069    
1070            ;; TODO: remove comments in the middle of an address            ;; TODO: remove comments in the middle of an address
1071    
1072            (save-excursion            (with-current-buffer canonicalization-buffer
             (set-buffer canonicalization-buffer)  
   
1073              (widen)              (widen)
1074              (erase-buffer)              (erase-buffer)
1075              (insert-buffer-substring extraction-buffer)              (insert-buffer-substring extraction-buffer)
# Line 1097  ADDRESS may be a string or a buffer.  If Line 1084  ADDRESS may be a string or a buffer.  If
1084                    (narrow-to-region first-real-pos last-real-pos)                    (narrow-to-region first-real-pos last-real-pos)
1085                  ;; ****** Oh no!  What if the address is completely empty!                  ;; ****** Oh no!  What if the address is completely empty!
1086                  ;; *** Is this correct?                  ;; *** Is this correct?
1087                  (narrow-to-region (point-max) (point-max))                  (narrow-to-region (point-max) (point-max))))
                 ))  
1088    
1089              (and @-pos %-pos              (and @-pos %-pos
1090                   (mail-extr-nuke-outside-range %-pos (point-min) @-pos))                   (mail-extr-nuke-outside-range %-pos (point-min) @-pos))
# Line 1110  ADDRESS may be a string or a buffer.  If Line 1096  ADDRESS may be a string or a buffer.  If
1096              ;; Error condition:?? (and %-pos (not @-pos))              ;; Error condition:?? (and %-pos (not @-pos))
1097    
1098              ;; WARNING: THIS CODE IS DUPLICATED BELOW.              ;; WARNING: THIS CODE IS DUPLICATED BELOW.
1099              (cond ((and %-pos              (when (and %-pos (not @-pos))
1100                          (not @-pos))                (goto-char (car %-pos))
1101                     (goto-char (car %-pos))                (delete-char 1)
1102                     (mail-extr-delete-char 1)                (setq @-pos (point))
1103                     (setq @-pos (point))                (insert "@")
1104                     (insert "@")                (setq %-pos (cdr %-pos)))
1105                     (setq %-pos (cdr %-pos))))  
1106                (when (and mail-extr-mangle-uucp !-pos)
1107              (if mail-extr-mangle-uucp                ;; **** I don't understand this save-restriction and the
1108                  (cond (!-pos                ;; narrow-to-region inside it.  Why did I do that?
1109                         ;; **** I don't understand this save-restriction and the                (save-restriction
1110                         ;; narrow-to-region inside it.  Why did I do that?                  (cond ((and @-pos
1111                         (save-restriction                              mail-extr-@-binds-tighter-than-!)
1112                           (cond ((and @-pos                         (goto-char @-pos)
1113                                       mail-extr-@-binds-tighter-than-!)                         (setq %-pos (cons (point) %-pos)
1114                                  (goto-char @-pos)                               @-pos nil)
1115                                  (setq %-pos (cons (point) %-pos)                         (delete-char 1)
1116                                        @-pos nil)                         (insert "%")
1117                                  (mail-extr-delete-char 1)                         (setq insert-point (point-max)))
1118                                  (insert "%")                        (mail-extr-@-binds-tighter-than-!
1119                                  (setq insert-point (point-max)))                         (setq insert-point (point-max)))
1120                                 (mail-extr-@-binds-tighter-than-!                        (%-pos
1121                                  (setq insert-point (point-max)))                         (setq insert-point (car (last %-pos))
1122                                 (%-pos                               saved-%-pos (mapcar 'mail-extr-markerize %-pos)
1123                                  (setq insert-point (car (last %-pos))                               %-pos nil
1124                                        saved-%-pos (mapcar 'mail-extr-markerize %-pos)                               @-pos (mail-extr-markerize @-pos)))
1125                                        %-pos nil                        (@-pos
1126                                        @-pos (mail-extr-markerize @-pos)))                         (setq insert-point @-pos)
1127                                 (@-pos                         (setq @-pos (mail-extr-markerize @-pos)))
1128                                  (setq insert-point @-pos)                        (t
1129                                  (setq @-pos (mail-extr-markerize @-pos)))                         (setq insert-point (point-max))))
1130                                 (t                  (narrow-to-region (point-min) insert-point)
1131                                  (setq insert-point (point-max))))                  (setq saved-!-pos (car !-pos))
1132                           (narrow-to-region (point-min) insert-point)                  (while !-pos
1133                           (setq saved-!-pos (car !-pos))                    (goto-char (point-max))
1134                           (while !-pos                    (cond ((and (not @-pos)
1135                             (goto-char (point-max))                                (not (cdr !-pos)))
1136                             (cond ((and (not @-pos)                           (setq @-pos (point))
1137                                         (not (cdr !-pos)))                           (insert-before-markers "@ "))
1138                                    (setq @-pos (point))                          (t
1139                                    (insert-before-markers "@ "))                           (setq %-pos (cons (point) %-pos))
1140                                   (t                           (insert-before-markers "% ")))
1141                                    (setq %-pos (cons (point) %-pos))                    (backward-char 1)
1142                                    (insert-before-markers "% ")))                    (insert-buffer-substring
1143                             (backward-char 1)                     (current-buffer)
1144                             (insert-buffer-substring                     (if (nth 1 !-pos)
1145                              (current-buffer)                         (1+ (nth 1 !-pos))
1146                              (if (nth 1 !-pos)                       (point-min))
1147                                  (1+ (nth 1 !-pos))                     (car !-pos))
1148                                (point-min))                    (delete-char 1)
1149                              (car !-pos))                    (or (save-excursion
1150                             (mail-extr-delete-char 1)                          (mail-extr-safe-move-sexp -1)
1151                             (or (save-excursion                          (mail-extr-skip-whitespace-backward)
1152                                   (mail-extr-safe-move-sexp -1)                          (eq ?. (preceding-char)))
1153                                   (mail-extr-skip-whitespace-backward)                        (insert-before-markers
1154                                   (eq ?. (preceding-char)))                         (if (save-excursion
1155                                 (insert-before-markers                               (mail-extr-skip-whitespace-backward)
1156                                  (if (save-excursion                               (eq ?. (preceding-char)))
1157                                        (mail-extr-skip-whitespace-backward)                             ""
1158                                        (eq ?. (preceding-char)))                           ".")
1159                                      ""                         "uucp"))
1160                                    ".")                    (setq !-pos (cdr !-pos))))
1161                                  "uucp"))                (and saved-%-pos
1162                             (setq !-pos (cdr !-pos))))                     (setq %-pos (append (mapcar 'mail-extr-demarkerize
1163                         (and saved-%-pos                                                 saved-%-pos)
1164                              (setq %-pos (append (mapcar 'mail-extr-demarkerize                                         %-pos)))
1165                                                          saved-%-pos)                (setq @-pos (mail-extr-demarkerize @-pos))
1166                                                  %-pos)))                (narrow-to-region (1+ saved-!-pos) (point-max)))
                        (setq @-pos (mail-extr-demarkerize @-pos))  
                        (narrow-to-region (1+ saved-!-pos) (point-max)))))  
1167    
1168              ;; WARNING: THIS CODE IS DUPLICATED ABOVE.              ;; WARNING: THIS CODE IS DUPLICATED ABOVE.
1169              (cond ((and %-pos              (when (and %-pos (not @-pos))
1170                          (not @-pos))                (goto-char (car %-pos))
1171                     (goto-char (car %-pos))                (delete-char 1)
1172                     (mail-extr-delete-char 1)                (setq @-pos (point))
1173                     (setq @-pos (point))                (insert "@")
1174                     (insert "@")                (setq %-pos (cdr %-pos)))
1175                     (setq %-pos (cdr %-pos))))  
1176                (when (setq %-pos (nreverse %-pos)) ; implies @-pos valid
1177              (setq %-pos (nreverse %-pos))                (setq temp %-pos)
1178              (cond (%-pos                        ; implies @-pos valid                (catch 'truncated
1179                     (setq temp %-pos)                  (while temp
1180                     (catch 'truncated                    (goto-char (or (nth 1 temp)
1181                       (while temp                                   @-pos))
1182                         (goto-char (or (nth 1 temp)                    (mail-extr-skip-whitespace-backward)
1183                                        @-pos))                    (save-excursion
1184                         (mail-extr-skip-whitespace-backward)                      (mail-extr-safe-move-sexp -1)
1185                         (save-excursion                      (setq domain-pos (point))
1186                           (mail-extr-safe-move-sexp -1)                      (mail-extr-skip-whitespace-backward)
1187                           (setq domain-pos (point))                      (setq \.-pos (eq ?. (preceding-char))))
1188                           (mail-extr-skip-whitespace-backward)                    (when (and \.-pos
1189                           (setq \.-pos (eq ?. (preceding-char))))                               ;; #### string consing
1190                         (cond ((and \.-pos                               (let ((s (intern-soft
1191                                     ;; #### string consing                                         (buffer-substring domain-pos (point))
1192                                     (let ((s (intern-soft                                         mail-extr-all-top-level-domains)))
1193                                               (buffer-substring domain-pos (point))                                 (and s (get s 'domain-name))))
1194                                               mail-extr-all-top-level-domains)))                      (narrow-to-region (point-min) (point))
1195                                       (and s (get s 'domain-name))))                      (goto-char (car temp))
1196                                (narrow-to-region (point-min) (point))                      (delete-char 1)
1197                                (goto-char (car temp))                      (setq @-pos (point))
1198                                (mail-extr-delete-char 1)                      (setcdr temp nil)
1199                                (setq @-pos (point))                      (setq %-pos (delq @-pos %-pos))
1200                                (setcdr temp nil)                      (insert "@")
1201                                (setq %-pos (delq @-pos %-pos))                      (throw 'truncated t))
1202                                (insert "@")                    (setq temp (cdr temp)))))
                               (throw 'truncated t)))  
                        (setq temp (cdr temp))))))  
1203              (setq mbox-beg (point-min)              (setq mbox-beg (point-min)
1204                    mbox-end (if %-pos (car %-pos)                    mbox-end (if %-pos (car %-pos)
1205                               (or @-pos                               (or @-pos
1206                                   (point-max)))))                                   (point-max))))
1207    
1208                (when @-pos
1209                  ;; Make the domain-name part lowercase since it's case
1210                  ;; insensitive anyway.
1211                  (downcase-region (1+ @-pos) (point-max))))
1212    
1213            ;; Done canonicalizing address.            ;; Done canonicalizing address.
1214            ;; We are now back in extraction-buffer.            ;; We are now back in extraction-buffer.
# Line 1295  ADDRESS may be a string or a buffer.  If Line 1282  ADDRESS may be a string or a buffer.  If
1282                       (setq quote-end (- (point) 2))                       (setq quote-end (- (point) 2))
1283                       (save-excursion                       (save-excursion
1284                         (backward-char 1)                         (backward-char 1)
1285                         (mail-extr-delete-char 1)                         (delete-char 1)
1286                         (goto-char quote-beg)                         (goto-char quote-beg)
1287                         (or (eobp)                         (or (eobp)
1288                             (mail-extr-delete-char 1)))                             (delete-char 1)))
1289                       (mail-extr-undo-backslash-quoting quote-beg quote-end)                       (mail-extr-undo-backslash-quoting quote-beg quote-end)
1290                       (or (eq ?\  (char-after (point)))                       (or (eq ?\  (char-after (point)))
1291                           (insert " "))                           (insert " "))
# Line 1308  ADDRESS may be a string or a buffer.  If Line 1295  ADDRESS may be a string or a buffer.  If
1295                       (if (memq (char-after (1+ (point))) '(?_ ?=))                       (if (memq (char-after (1+ (point))) '(?_ ?=))
1296                           (progn                           (progn
1297                             (forward-char 1)                             (forward-char 1)
1298                             (mail-extr-delete-char 1)                             (delete-char 1)
1299                             (insert ?\ ))                             (insert ?\ ))
1300                         (if \.-ends-name                         (if \.-ends-name
1301                             (narrow-to-region (point-min) (point))                             (narrow-to-region (point-min) (point))
1302                           (mail-extr-delete-char 1)                           (delete-char 1)
1303                           (insert " ")))                           (insert " ")))
1304                       ;;          (setq mailbox-name-processed-flag t)                       ;;          (setq mailbox-name-processed-flag t)
1305                       )                       )
1306                      ((memq (char-syntax char) '(?. ?\\))                      ((memq (char-syntax char) '(?. ?\\))
1307                       (mail-extr-delete-char 1)                       (delete-char 1)
1308                       (insert " ")                       (insert " ")
1309                       ;;          (setq mailbox-name-processed-flag t)                       ;;          (setq mailbox-name-processed-flag t)
1310                       )                       )
# Line 1339  ADDRESS may be a string or a buffer.  If Line 1326  ADDRESS may be a string or a buffer.  If
1326    
1327                           ;; Copy the contents of the individual fields that                           ;; Copy the contents of the individual fields that
1328                           ;; might hold name data to the beginning.                           ;; might hold name data to the beginning.
1329                           (mapcar                           (mapc
1330                            (function                            (lambda (field-pattern)
1331                             (lambda (field-pattern)                              (when
1332                               (cond                                  (save-excursion
1333                                ((save-excursion                                    (re-search-forward field-pattern nil t))
1334                                   (re-search-forward field-pattern nil t))                                (insert-buffer-substring (current-buffer)
1335                                 (insert-buffer-substring (current-buffer)                                                         (match-beginning 1)
1336                                                          (match-beginning 1)                                                         (match-end 1))
1337                                                          (match-end 1))                                (insert " ")))
                                (insert " ")))))  
1338                            (list mail-extr-x400-encoded-address-given-name-pattern                            (list mail-extr-x400-encoded-address-given-name-pattern
1339                                  mail-extr-x400-encoded-address-surname-pattern                                  mail-extr-x400-encoded-address-surname-pattern
1340                                  mail-extr-x400-encoded-address-full-name-pattern))                                  mail-extr-x400-encoded-address-full-name-pattern))
# Line 1396  ADDRESS may be a string or a buffer.  If Line 1382  ADDRESS may be a string or a buffer.  If
1382            ;; Initial code by Jamie Zawinski <jwz@lucid.com>            ;; Initial code by Jamie Zawinski <jwz@lucid.com>
1383            ;; *** Make it work when there's a suffix as well.            ;; *** Make it work when there's a suffix as well.
1384            (goto-char (point-min))            (goto-char (point-min))
1385            (cond ((and mail-extr-guess-middle-initial            (when (and mail-extr-guess-middle-initial
1386                        (not disable-initial-guessing-flag)                       (not disable-initial-guessing-flag)
1387                        (eq 3 (- mbox-end mbox-beg))                       (eq 3 (- mbox-end mbox-beg))
1388                        (progn                       (progn
1389                          (goto-char (point-min))                         (goto-char (point-min))
1390                          (looking-at mail-extr-two-name-pattern)))                         (looking-at mail-extr-two-name-pattern)))
1391                   (setq fi (char-after (match-beginning 0))              (setq fi (char-after (match-beginning 0))
1392                         li (char-after (match-beginning 3)))                    li (char-after (match-beginning 3)))
1393                   (save-excursion              (with-current-buffer canonicalization-buffer
1394                     (set-buffer canonicalization-buffer)                ;; char-equal is ignoring case here, so no need to upcase
1395                     ;; char-equal is ignoring case here, so no need to upcase                ;; or downcase.
1396                     ;; or downcase.                (let ((case-fold-search t))
1397                     (let ((case-fold-search t))                  (and (char-equal fi (char-after mbox-beg))
1398                       (and (char-equal fi (char-after mbox-beg))                       (char-equal li (char-after (1- mbox-end)))
1399                            (char-equal li (char-after (1- mbox-end)))                       (setq mi (char-after (1+ mbox-beg))))))
1400                            (setq mi (char-after (1+ mbox-beg))))))              (when (and mi
1401                   (cond ((and mi                         ;; TODO: use better table than syntax table
1402                               ;; TODO: use better table than syntax table                         (eq ?w (char-syntax mi)))
1403                               (eq ?w (char-syntax mi)))                (goto-char (match-beginning 3))
1404                          (goto-char (match-beginning 3))                (insert (upcase mi) ". ")))
                         (insert (upcase mi) ". ")))))  
1405    
1406            ;; Nuke name if it is the same as mailbox name.            ;; Nuke name if it is the same as mailbox name.
1407            (let ((buffer-length (- (point-max) (point-min)))            (let ((buffer-length (- (point-max) (point-min)))
1408                  (i 0)                  (i 0)
1409                  (names-match-flag t))                  (names-match-flag t))
1410              (cond ((and (> buffer-length 0)              (when (and (> buffer-length 0)
1411                          (eq buffer-length (- mbox-end mbox-beg)))                         (eq buffer-length (- mbox-end mbox-beg)))
1412                     (goto-char (point-max))                (goto-char (point-max))
1413                     (insert-buffer-substring canonicalization-buffer                (insert-buffer-substring canonicalization-buffer
1414                                              mbox-beg mbox-end)                                         mbox-beg mbox-end)
1415                     (while (and names-match-flag                (while (and names-match-flag
1416                                 (< i buffer-length))                            (< i buffer-length))
1417                       (or (eq (downcase (char-after (+ i (point-min))))                  (or (eq (downcase (char-after (+ i (point-min))))
1418                               (downcase                          (downcase
1419                                (char-after (+ i buffer-length (point-min)))))                           (char-after (+ i buffer-length (point-min)))))
1420                           (setq names-match-flag nil))                      (setq names-match-flag nil))
1421                       (setq i (1+ i)))                  (setq i (1+ i)))
1422                     (delete-region (+ (point-min) buffer-length) (point-max))                (delete-region (+ (point-min) buffer-length) (point-max))
1423                     (if names-match-flag                (if names-match-flag
1424                         (narrow-to-region (point) (point))))))                    (narrow-to-region (point) (point)))))
1425    
1426            ;; Nuke name if it's just one word.            ;; Nuke name if it's just one word.
1427            (goto-char (point-min))            (goto-char (point-min))
# Line 1448  ADDRESS may be a string or a buffer.  If Line 1433  ADDRESS may be a string or a buffer.  If
1433            (setq value-list            (setq value-list
1434                  (cons (list (if (not (= (point-min) (point-max)))                  (cons (list (if (not (= (point-min) (point-max)))
1435                                  (buffer-string))                                  (buffer-string))
1436                              (save-excursion                              (with-current-buffer canonicalization-buffer
                               (set-buffer canonicalization-buffer)  
1437                                (if (not (= (point-min) (point-max)))                                (if (not (= (point-min) (point-max)))
1438                                    (buffer-string))))                                    (buffer-string))))
1439                        value-list))                        value-list))
# Line 1492  ADDRESS may be a string or a buffer.  If Line 1476  ADDRESS may be a string or a buffer.  If
1476          (skip-chars-forward "^({[\"'`")          (skip-chars-forward "^({[\"'`")
1477          (let ((cbeg (point)))          (let ((cbeg (point)))
1478            (set-syntax-table mail-extr-address-text-comment-syntax-table)            (set-syntax-table mail-extr-address-text-comment-syntax-table)
1479            (cond ((memq (following-char) '(?\' ?\`))            (if (memq (following-char) '(?\' ?\`))
1480                   (search-forward "'" nil 'move                (search-forward "'" nil 'move
1481                                   (if (eq ?\' (following-char)) 2 1)))                                (if (eq ?\' (following-char)) 2 1))
1482                  (t              (or (mail-extr-safe-move-sexp 1)
1483                   (or (mail-extr-safe-move-sexp 1)                  (goto-char (point-max))))
                      (goto-char (point-max)))))  
1484            (set-syntax-table mail-extr-address-text-syntax-table)            (set-syntax-table mail-extr-address-text-syntax-table)
1485            (when (eq (char-after cbeg) ?\()            (when (eq (char-after cbeg) ?\()
1486              ;; Delete the comment itself.              ;; Delete the comment itself.
# Line 1522  ADDRESS may be a string or a buffer.  If Line 1505  ADDRESS may be a string or a buffer.  If
1505        ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)        ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t)
1506        ;;  (replace-match "\\1 \\2" t))        ;;  (replace-match "\\1 \\2" t))
1507    
1508        (cond ((not (search-forward " " nil t))        (unless (search-forward " " nil t)
1509               (goto-char (point-min))          (goto-char (point-min))
1510               (cond ((search-forward "_" nil t)          (cond ((search-forward "_" nil t)
1511                      ;; Handle the *idiotic* use of underlines as spaces.                 ;; Handle the *idiotic* use of underlines as spaces.
1512                      ;; Example: fml@foo.bar.dom (First_M._Last)                 ;; Example: fml@foo.bar.dom (First_M._Last)
1513                      (goto-char (point-min))                 (goto-char (point-min))
1514                      (while (search-forward "_" nil t)                 (while (search-forward "_" nil t)
1515                        (replace-match " " t)))                   (replace-match " " t)))
1516                     ((search-forward "." nil t)                ((search-forward "." nil t)
1517                      ;; Fix . used as space                 ;; Fix . used as space
1518                      ;; Example: danj1@cb.att.com (daniel.jacobson)                 ;; Example: danj1@cb.att.com (daniel.jacobson)
1519                      (goto-char (point-min))                 (goto-char (point-min))
1520                      (while (re-search-forward mail-extr-bad-dot-pattern nil t)                 (while (re-search-forward mail-extr-bad-dot-pattern nil t)
1521                        (replace-match "\\1 \\2" t))))))                   (replace-match "\\1 \\2" t)))))
1522    
1523        ;; Loop over the words (and other junk) in the name.        ;; Loop over the words (and other junk) in the name.
1524        (goto-char (point-min))        (goto-char (point-min))
1525        (while (not name-done-flag)        (while (not name-done-flag)
1526                    
1527          (cond (word-found-flag          (when word-found-flag
1528                 ;; Last time through this loop we skipped over a word.            ;; Last time through this loop we skipped over a word.
1529                 (setq last-word-beg this-word-beg)            (setq last-word-beg this-word-beg)
1530                 (setq drop-last-word-if-trailing-flag            (setq drop-last-word-if-trailing-flag
1531                       drop-this-word-if-trailing-flag)                  drop-this-word-if-trailing-flag)
1532                 (setq word-found-flag nil)))            (setq word-found-flag nil))
1533    
1534          (cond (begin-again-flag          (when begin-again-flag
1535                 ;; Last time through the loop we found something that            ;; Last time through the loop we found something that
1536                 ;; indicates we should pretend we are beginning again from            ;; indicates we should pretend we are beginning again from
1537                 ;; the start.            ;; the start.
1538                 (setq word-count 0)            (setq word-count 0)
1539                 (setq last-word-beg nil)            (setq last-word-beg nil)
1540                 (setq drop-last-word-if-trailing-flag nil)            (setq drop-last-word-if-trailing-flag nil)
1541                 (setq mixed-case-flag nil)            (setq mixed-case-flag nil)
1542                 (setq lower-case-flag nil)            (setq lower-case-flag nil)
1543  ;;             (setq upper-case-flag nil)            ;;           (setq upper-case-flag nil)
1544                 (setq begin-again-flag nil)            (setq begin-again-flag nil))
                ))  
1545                    
1546          ;; Initialize for this iteration of the loop.          ;; Initialize for this iteration of the loop.
1547          (mail-extr-skip-whitespace-forward)          (mail-extr-skip-whitespace-forward)
# Line 1625  ADDRESS may be a string or a buffer.  If Line 1607  ADDRESS may be a string or a buffer.  If
1607            (cond ((memq (following-char) '(?\' ?\`))            (cond ((memq (following-char) '(?\' ?\`))
1608                   (or (search-forward "'" nil t                   (or (search-forward "'" nil t
1609                                       (if (eq ?\' (following-char)) 2 1))                                       (if (eq ?\' (following-char)) 2 1))
1610                       (mail-extr-delete-char 1)))                       (delete-char 1)))
1611                  (t                  (t
1612                   (or (mail-extr-safe-move-sexp 1)                   (or (mail-extr-safe-move-sexp 1)
1613                       (goto-char (point-max)))))                       (goto-char (point-max)))))
# Line 1718  ADDRESS may be a string or a buffer.  If Line 1700  ADDRESS may be a string or a buffer.  If
1700                 (eq ?\  (preceding-char))                 (eq ?\  (preceding-char))
1701                 (eq (following-char) ?&)                 (eq (following-char) ?&)
1702                 (eq (1+ (point)) (point-max)))                 (eq (1+ (point)) (point-max)))
1703            (mail-extr-delete-char 1)            (delete-char 1)
1704            (capitalize-region            (capitalize-region
1705             (point)             (point)
1706             (progn             (progn
# Line 1801  ADDRESS may be a string or a buffer.  If Line 1783  ADDRESS may be a string or a buffer.  If
1783        ;; here at all.  Actually I guess it would be best to map patterns        ;; here at all.  Actually I guess it would be best to map patterns
1784        ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't        ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't
1785        ;; actually know that that is what's going on.        ;; actually know that that is what's going on.
1786        (cond ((not suffix-flag)        (unless suffix-flag
1787               (goto-char (point-min))          (goto-char (point-min))
1788               (let ((case-fold-search t))          (let ((case-fold-search t))
1789                 (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")            (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'")
1790                     (erase-buffer)))))                (erase-buffer))))
1791    
1792        ;; If last name first put it at end (but before suffix)        ;; If last name first put it at end (but before suffix)
1793        (cond (last-name-comma-flag        (when last-name-comma-flag
1794               (goto-char (point-min))          (goto-char (point-min))
1795               (search-forward ",")          (search-forward ",")
1796               (setq name-end (1- (point)))          (setq name-end (1- (point)))
1797               (goto-char (or suffix-flag (point-max)))          (goto-char (or suffix-flag (point-max)))
1798               (or (eq ?\  (preceding-char))          (or (eq ?\  (preceding-char))
1799                   (insert ?\ ))              (insert ?\ ))
1800               (insert-buffer-substring (current-buffer) (point-min) name-end)          (insert-buffer-substring (current-buffer) (point-min) name-end)
1801               (goto-char name-end)          (goto-char name-end)
1802               (skip-chars-forward "\t ,")          (skip-chars-forward "\t ,")
1803               (narrow-to-region (point) (point-max))))          (narrow-to-region (point) (point-max)))
1804                
1805        ;; Delete leading and trailing junk characters.        ;; Delete leading and trailing junk characters.
1806        ;; *** This is probably completely unneeded now.        ;; *** This is probably completely unneeded now.
# Line 1851  ADDRESS may be a string or a buffer.  If Line 1833  ADDRESS may be a string or a buffer.  If
1833    
1834  (defconst mail-extr-all-top-level-domains  (defconst mail-extr-all-top-level-domains
1835    (let ((ob (make-vector 739 0)))    (let ((ob (make-vector 739 0)))
1836      (mapcar      (mapc
1837       (function       (lambda (x)
1838        (lambda (x)         (put (intern (downcase (car x)) ob)
1839          (put (intern (downcase (car x)) ob)              'domain-name
1840               'domain-name              (if (nth 2 x)
1841               (if (nth 2 x)                  (format (nth 2 x) (nth 1 x))
1842                   (format (nth 2 x) (nth 1 x))                (nth 1 x))))
                (nth 1 x)))))  
1843       '(       '(
1844         ;; ISO 3166 codes:         ;; ISO 3166 codes:
1845         ("ad" "Andorra")         ("ad" "Andorra")

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.36

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26