Mercurial > hg > xemacs-beta

comparison lisp/utils/mail-extr.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 1a767b41a199
children 54cc21c15cbb
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; mail-extr.el --- extract full name and address from RFC 822 mail header. 1 ;;; mail-extr.el --- extract full name and address from RFC 822 mail header.
2 2
3 ;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
4 4
5 ;; Author: Joe Wells <jbw@cs.bu.edu> 5 ;; Author: Joe Wells <jbw@cs.bu.edu>
6 ;; Maintainer: Chuck Thompson <cthomp@xemacs.org> 6 ;; Maintainer: Jamie Zawinski <jwz@lucid.com>
7 ;; Version: 1.8 7 ;; Version: 1.8
8 ;; Keywords: mail 8 ;; Keywords: mail
9 9
10 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
11 11
119 ;; * insert documentation strings! 119 ;; * insert documentation strings!
120 ;; * handle X.400-gatewayed addresses according to RFC 1148. 120 ;; * handle X.400-gatewayed addresses according to RFC 1148.
121 121
122 ;;; Change Log: 122 ;;; Change Log:
123 ;; 123 ;;
124 ;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@netscape.com) 124 ;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@lucid.com)
125 ;; 125 ;;
126 ;; * merged with jbw's latest version 126 ;; * merged with jbw's latest version
127 ;; 127 ;;
128 ;; Wed Feb 9 21:56:27 1994 Jamie Zawinski (jwz@netscape.com) 128 ;; Wed Feb 9 21:56:27 1994 Jamie Zawinski (jwz@lucid.com)
129 ;; 129 ;;
130 ;; * high-bit chars in comments weren't treated as word syntax 130 ;; * high-bit chars in comments weren't treated as word syntax
131 ;; 131 ;;
132 ;; Sat Feb 5 03:13:40 1994 Jamie Zawinski (jwz@netscape.com) 132 ;; Sat Feb 5 03:13:40 1994 Jamie Zawinski (jwz@lucid.com)
133 ;; 133 ;;
134 ;; * call replace-match with fixed-case arg 134 ;; * call replace-match with fixed-case arg
135 ;; 135 ;;
136 ;; Thu Dec 16 21:56:45 1993 Jamie Zawinski (jwz@netscape.com) 136 ;; Thu Dec 16 21:56:45 1993 Jamie Zawinski (jwz@lucid.com)
137 ;; 137 ;;
138 ;; * some more cleanup, doc, added provide 138 ;; * some more cleanup, doc, added provide
139 ;; 139 ;;
140 ;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu) 140 ;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu)
141 ;; 141 ;;
234 "*Whether the local mail transport agent looks at ! before @.") 234 "*Whether the local mail transport agent looks at ! before @.")
235 235
236 (defvar mail-extr-mangle-uucp nil 236 (defvar mail-extr-mangle-uucp nil
237 "*Whether to throw away information in UUCP addresses 237 "*Whether to throw away information in UUCP addresses
238 by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\".") 238 by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\".")
239
240 (defvar mail-extr-mailbox-match-case-fold t
241 "*Non-nil if mailbox and name matching should ignore case.")
242 239
243 ;;---------------------------------------------------------------------- 240 ;;----------------------------------------------------------------------
244 ;; what orderings are meaningful????? 241 ;; what orderings are meaningful?????
245 ;;(defvar mail-operator-precedence-list '(?! ?% ?@)) 242 ;;(defvar mail-operator-precedence-list '(?! ?% ?@))
246 ;; Right operand of a % or a @ must be a domain name, period. No other 243 ;; Right operand of a % or a @ must be a domain name, period. No other
1173 (insert "@") 1170 (insert "@")
1174 (setq %-pos (cdr %-pos)))) 1171 (setq %-pos (cdr %-pos))))
1175 1172
1176 (setq %-pos (nreverse %-pos)) 1173 (setq %-pos (nreverse %-pos))
1177 ;; RFC 1034 doesn't approve of this, oh well: 1174 ;; RFC 1034 doesn't approve of this, oh well:
1178 ;; Neither do we, sb/lmi 1175 (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
1179 ;; (downcase-region (or (car %-pos) @-pos (point-max)) (point-max))
1180 (cond (%-pos ; implies @-pos valid 1176 (cond (%-pos ; implies @-pos valid
1181 (setq temp %-pos) 1177 (setq temp %-pos)
1182 (catch 'truncated 1178 (catch 'truncated
1183 (while temp 1179 (while temp
1184 (goto-char (or (nth 1 temp) 1180 (goto-char (or (nth 1 temp)
1377 (mail-extr-voodoo mbox-beg mbox-end canonicalization-buffer) 1373 (mail-extr-voodoo mbox-beg mbox-end canonicalization-buffer)
1378 (goto-char (point-min)) 1374 (goto-char (point-min))
1379 1375
1380 ;; If name is "First Last" and userid is "F?L", then assume 1376 ;; If name is "First Last" and userid is "F?L", then assume
1381 ;; the middle initial is the second letter in the userid. 1377 ;; the middle initial is the second letter in the userid.
1382 ;; Initial code by Jamie Zawinski <jwz@netscape.com> 1378 ;; Initial code by Jamie Zawinski <jwz@lucid.com>
1383 ;; *** Make it work when there's a suffix as well. 1379 ;; *** Make it work when there's a suffix as well.
1384 (goto-char (point-min)) 1380 (goto-char (point-min))
1385 (cond ((and mail-extr-guess-middle-initial 1381 (cond ((and mail-extr-guess-middle-initial
1386 (not disable-initial-guessing-flag) 1382 (not disable-initial-guessing-flag)
1387 (eq 3 (- mbox-end mbox-beg)) 1383 (eq 3 (- mbox-end mbox-beg))
1413 (goto-char (point-max)) 1409 (goto-char (point-max))
1414 (insert-buffer-substring canonicalization-buffer 1410 (insert-buffer-substring canonicalization-buffer
1415 mbox-beg mbox-end) 1411 mbox-beg mbox-end)
1416 (while (and names-match-flag 1412 (while (and names-match-flag
1417 (< i buffer-length)) 1413 (< i buffer-length))
1418 (or (eq (let ((c (char-after (+ i (point-min))))) 1414 (or (eq (downcase (char-after (+ i (point-min))))
1419 (if mail-extr-mailbox-match-case-fold
1420 (downcase c)
1421 c))
1422 (downcase 1415 (downcase
1423 (char-after (+ i buffer-length (point-min))))) 1416 (char-after (+ i buffer-length (point-min)))))
1424 (setq names-match-flag nil)) 1417 (setq names-match-flag nil))
1425 (setq i (1+ i))) 1418 (setq i (1+ i)))
1426 (delete-region (+ (point-min) buffer-length) (point-max)) 1419 (delete-region (+ (point-min) buffer-length) (point-max))
1713 (if word-found-flag 1706 (if word-found-flag
1714 (setq word-count (1+ word-count)))) 1707 (setq word-count (1+ word-count))))
1715 1708
1716 ;; If the last thing in the name is 2 or more periods, or one or more 1709 ;; If the last thing in the name is 2 or more periods, or one or more
1717 ;; other sentence terminators (but not a single period) then keep them 1710 ;; other sentence terminators (but not a single period) then keep them
1718 ;; and the preceding word. This is for the benefit of whole sentences 1711 ;; and the preceeding word. This is for the benefit of whole sentences
1719 ;; in the name field: it's better behavior than dropping the last word 1712 ;; in the name field: it's better behavior than dropping the last word
1720 ;; of the sentence... 1713 ;; of the sentence...
1721 (if (and (not suffix-flag) 1714 (if (and (not suffix-flag)
1722 (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) 1715 (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'"))
1723 (goto-char (setq suffix-flag (point-max)))) 1716 (goto-char (setq suffix-flag (point-max))))
1825 ("fj" "Fiji") 1818 ("fj" "Fiji")
1826 ("fr" "France") 1819 ("fr" "France")
1827 ("gov" t "Government (U.S.A.)") 1820 ("gov" t "Government (U.S.A.)")
1828 ("gr" "Greece" "The Hellenic Republic (%s)") 1821 ("gr" "Greece" "The Hellenic Republic (%s)")
1829 ("hk" "Hong Kong") 1822 ("hk" "Hong Kong")
1830 ("hr" "Croatia" "The Republic of %s")
1831 ("hu" "Hungary" "The Hungarian People's Republic") ;??? 1823 ("hu" "Hungary" "The Hungarian People's Republic") ;???
1832 ("ie" "Ireland") 1824 ("ie" "Ireland")
1833 ("il" "Israel" "The State of %s") 1825 ("il" "Israel" "The State of %s")
1834 ("in" "India" "The Republic of %s") 1826 ("in" "India" "The Republic of %s")
1835 ("int" t "(something British, don't know what)") 1827 ("int" t "(something British, don't know what)")