![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mail-utils.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to mail-utils.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ;; Utility functions used both by rmail and rnews
2: ;; Copyright (C) 1985 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21:
22: (provide 'mail-utils)
23:
24: ;; should be in loaddefs
25: (defvar mail-use-rfc822 nil
26: "*If non-nil, use a full, hairy RFC822 parser on mail addresses.
27: Otherwise, (the default) use a smaller, somewhat faster and
28: often-correct parser.")
29:
30: (defun mail-string-delete (string start end)
31: "Returns a string containing all of STRING except the part
32: from START (inclusive) to END (exclusive)."
33: (if (null end) (substring string 0 start)
34: (concat (substring string 0 start)
35: (substring string end nil))))
36:
37: (defun mail-strip-quoted-names (address)
38: "Delete comments and quoted strings in an address list ADDRESS.
39: Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
40: Return a modified address list."
41: (if mail-use-rfc822
42: (progn (require 'rfc822)
43: (mapconcat 'identity (rfc822-addresses address) ", "))
44: (let (pos)
45: (string-match "\\`[ \t\n]*" address)
46: ;; strip surrounding whitespace
47: (setq address (substring address
48: (match-end 0)
49: (string-match "[ \t\n]*\\'" address
50: (match-end 0))))
51: ;; strip rfc822 comments
52: (while (setq pos (string-match
53: ;; This doesn't hack rfc822 nested comments
54: ;; `(xyzzy (foo) whinge)' properly. Big deal.
55: "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
56: address))
57: (setq address
58: (mail-string-delete address
59: pos (match-end 0))))
60: ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
61: (setq pos 0)
62: (while (setq pos (string-match
63: "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
64: address pos))
65: ;; If the next thing is "@", we have "foo bar"@host. Leave it.
66: (if (and (> (length address) (match-end 0))
67: (= (aref address (match-end 0)) ?@))
68: (setq pos (match-end 0))
69: (setq address
70: (mail-string-delete address
71: pos (match-end 0)))))
72: ;; Retain only part of address in <> delims, if there is such a thing.
73: (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
74: address))
75: (let ((junk-beg (match-end 1))
76: (junk-end (match-beginning 2))
77: (close (match-end 0)))
78: (setq address (mail-string-delete address (1- close) close))
79: (setq address (mail-string-delete address junk-beg junk-end))))
80: address)))
81:
82: (or (and (boundp 'rmail-default-dont-reply-to-names)
83: (not (null rmail-default-dont-reply-to-names)))
84: (setq rmail-default-dont-reply-to-names "info-"))
85:
86: ; rmail-dont-reply-to-names is defined in loaddefs
87: (defun rmail-dont-reply-to (userids)
88: "Returns string of mail addresses USERIDS sans any recipients
89: that start with matches for rmail-dont-reply-to-names.
90: Usenet paths ending in an element that matches are removed also."
91: (if (null rmail-dont-reply-to-names)
92: (setq rmail-dont-reply-to-names
93: (concat (if rmail-default-dont-reply-to-names
94: (concat rmail-default-dont-reply-to-names "\\|")
95: "")
96: (concat (regexp-quote
97: (or (getenv "USER") (getenv "LOGNAME")
98: (user-login-name)))
99: "\\>"))))
100: (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
101: rmail-dont-reply-to-names
102: "\\)"))
103: (case-fold-search t)
104: pos epos)
105: (while (setq pos (string-match match userids))
106: (if (> pos 0) (setq pos (1+ pos)))
107: (setq epos
108: (if (string-match "[ \t\n,]+" userids (match-end 0))
109: (match-end 0)
110: (length userids)))
111: (setq userids
112: (mail-string-delete
113: userids pos epos)))
114: ;; get rid of any trailing commas
115: (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
116: (setq userids (substring userids 0 pos)))
117: ;; remove leading spaces. they bother me.
118: (if (string-match "\\s *" userids)
119: (substring userids (match-end 0))
120: userids)))
121:
122: (defun mail-fetch-field (field-name &optional last all)
123: "Return the value of the header field FIELD.
124: The buffer is expected to be narrowed to just the headers of the message.
125: If 2nd arg LAST is non-nil, use the last such field if there are several.
126: If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
127: (save-excursion
128: (goto-char (point-min))
129: (let ((case-fold-search t)
130: (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
131: (goto-char (point-min))
132: (if all
133: (let ((value ""))
134: (while (re-search-forward name nil t)
135: (let ((opoint (point)))
136: (while (progn (forward-line 1)
137: (looking-at "[ \t]")))
138: (setq value (concat value
139: (if (string= value "") "" ", ")
140: (buffer-substring opoint (1- (point)))))))
141: (and (not (string= value "")) value))
142: (if (re-search-forward name nil t)
143: (progn
144: (if last (while (re-search-forward name nil t)))
145: (let ((opoint (point)))
146: (while (progn (forward-line 1)
147: (looking-at "[ \t]")))
148: (buffer-substring opoint (1- (point))))))))))
149:
150: ;; Parse a list of tokens separated by commas.
151: ;; It runs from point to the end of the visible part of the buffer.
152: ;; Whitespace before or after tokens is ignored,
153: ;; but whitespace within tokens is kept.
154: (defun mail-parse-comma-list ()
155: (let (accumulated
156: beg)
157: (skip-chars-forward " ")
158: (while (not (eobp))
159: (setq beg (point))
160: (skip-chars-forward "^,")
161: (skip-chars-backward " ")
162: (setq accumulated
163: (cons (buffer-substring beg (point))
164: accumulated))
165: (skip-chars-forward "^,")
166: (skip-chars-forward ", "))
167: accumulated))
168:
169: (defun mail-comma-list-regexp (labels)
170: (let (pos)
171: (setq pos (or (string-match "[^ \t]" labels) 0))
172: ;; Remove leading and trailing whitespace.
173: (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
174: ;; Change each comma to \|, and flush surrounding whitespace.
175: (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
176: (setq labels
177: (concat (substring labels 0 pos)
178: "\\|"
179: (substring labels (match-end 0))))))
180: labels)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.