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