![[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 [Apple XNU] / GNUtools / emacs / lisp|
Return to mail-utils.el CVS log | Up to [Apple XNU] / GNUtools / emacs / 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 free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19:
20:
21: (provide 'mail-utils)
22:
23: ;; should be in loaddefs
24: (defvar mail-use-rfc822 nil
25: "*If non-nil, use a full, hairy RFC822 parser on mail addresses.
26: Otherwise, (the default) use a smaller, somewhat faster and
27: often-correct parser.")
28:
29: (defun mail-string-delete (string start end)
30: "Returns a string containing all of STRING except the part
31: from START (inclusive) to END (exclusive)."
32: (if (null end) (substring string 0 start)
33: (concat (substring string 0 start)
34: (substring string end nil))))
35:
36: (defun mail-strip-quoted-names (address)
37: "Delete comments and quoted strings in an address list ADDRESS.
38: Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
39: Return a modified address list."
40: (if (null address)
41: nil
42: (if mail-use-rfc822
43: (progn (require 'rfc822)
44: (mapconcat 'identity (rfc822-addresses address) ", "))
45: (let (pos)
46: ;; Strip rfc822 comments (within parens).
47: ;; Understand properly the effect of backslashes and string quotes.
48: (let (instring (depth 0) start)
49: (setq pos -1)
50: (while pos
51: (cond ((< pos 0))
52: ((= (aref address pos) ?\\)
53: (setq pos (1+ pos)))
54: ((= (aref address pos) ?\")
55: (setq instring (not instring)))
56: (instring nil)
57: ((= (aref address pos) ?\()
58: (if (= depth 0) (setq start pos))
59: (setq depth (1+ depth)))
60: ((= (aref address pos) ?\))
61: (setq depth (1- depth))
62: (if (= depth 0)
63: (setq address (mail-string-delete address start (1+ pos))
64: pos (1- start)))))
65: (setq pos (string-match "[\"\\()]" address (1+ pos)))))
66:
67: ;; strip surrounding whitespace
68: (string-match "\\`[ \t\n]*" address)
69: (setq address (substring address
70: (match-end 0)
71: (string-match "[ \t\n]*\\'" address
72: (match-end 0))))
73:
74: ;; Strip whitespace before commas.
75: (let (instring)
76: (setq pos -1)
77: (while pos
78: (cond ((< pos 0))
79: ((= (aref address pos) ?\\)
80: (setq pos (1+ pos)))
81: ((= (aref address pos) ?\")
82: (setq instring (not instring)))
83: (instring nil)
84: ((eq (string-match "[ \t]*," address pos) pos)
85: (setq address (mail-string-delete address pos
86: (1- (match-end 0))))))
87: (setq pos (string-match "[ \t,\"\\]" address (1+ pos)))))
88:
89: ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
90: (setq pos 0)
91: (while (setq pos (string-match
92: "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
93: address pos))
94: ;; If the next thing is "@", we have "foo bar"@host. Leave it.
95: (if (and (> (length address) (match-end 0))
96: (= (aref address (match-end 0)) ?@))
97: (setq pos (match-end 0))
98: (setq address
99: (mail-string-delete address
100: pos (match-end 0)))))
101: ;; Retain only part of address in <> delims, if there is such a thing.
102: (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
103: address))
104: (let ((junk-beg (match-end 1))
105: (junk-end (match-beginning 2))
106: (close (match-end 0)))
107: (setq address (mail-string-delete address (1- close) close))
108: (setq address (mail-string-delete address junk-beg junk-end))))
109: address))))
110:
111: (or (and (boundp 'rmail-default-dont-reply-to-names)
112: (not (null rmail-default-dont-reply-to-names)))
113: (setq rmail-default-dont-reply-to-names "info-"))
114:
115: ; rmail-dont-reply-to-names is defined in loaddefs
116: (defun rmail-dont-reply-to (userids)
117: "Returns string of mail addresses USERIDS sans any recipients
118: that start with matches for rmail-dont-reply-to-names.
119: Usenet paths ending in an element that matches are removed also."
120: (if (null rmail-dont-reply-to-names)
121: (setq rmail-dont-reply-to-names
122: (concat (if rmail-default-dont-reply-to-names
123: (concat rmail-default-dont-reply-to-names "\\|")
124: "")
125: (concat (regexp-quote
126: (or (getenv "USER") (getenv "LOGNAME")
127: (user-login-name)))
128: "\\>"))))
129: (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
130: rmail-dont-reply-to-names
131: "\\)"))
132: (case-fold-search t)
133: pos epos)
134: (while (setq pos (string-match match userids))
135: (if (> pos 0) (setq pos (1+ pos)))
136: (setq epos
137: (if (string-match "[ \t\n,]+" userids (match-end 0))
138: (match-end 0)
139: (length userids)))
140: (setq userids
141: (mail-string-delete
142: userids pos epos)))
143: ;; get rid of any trailing commas
144: (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
145: (setq userids (substring userids 0 pos)))
146: ;; remove leading spaces. they bother me.
147: (if (string-match "\\s *" userids)
148: (substring userids (match-end 0))
149: userids)))
150:
151: (defun mail-fetch-field (field-name &optional last all)
152: "Return the value of the header field FIELD.
153: The buffer is expected to be narrowed to just the headers of the message.
154: If 2nd arg LAST is non-nil, use the last such field if there are several.
155: If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
156: (save-excursion
157: (goto-char (point-min))
158: (let ((case-fold-search t)
159: (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
160: (goto-char (point-min))
161: (if all
162: (let ((value ""))
163: (while (re-search-forward name nil t)
164: (let ((opoint (point)))
165: (while (progn (forward-line 1)
166: (looking-at "[ \t]")))
167: (setq value (concat value
168: (if (string= value "") "" ", ")
169: (buffer-substring opoint (1- (point)))))))
170: (and (not (string= value "")) value))
171: (if (re-search-forward name nil t)
172: (progn
173: (if last (while (re-search-forward name nil t)))
174: (let ((opoint (point)))
175: (while (progn (forward-line 1)
176: (looking-at "[ \t]")))
177: (buffer-substring opoint (1- (point))))))))))
178:
179: ;; Parse a list of tokens separated by commas.
180: ;; It runs from point to the end of the visible part of the buffer.
181: ;; Whitespace before or after tokens is ignored,
182: ;; but whitespace within tokens is kept.
183: (defun mail-parse-comma-list ()
184: (let (accumulated
185: beg)
186: (skip-chars-forward " ")
187: (while (not (eobp))
188: (setq beg (point))
189: (skip-chars-forward "^,")
190: (skip-chars-backward " ")
191: (setq accumulated
192: (cons (buffer-substring beg (point))
193: accumulated))
194: (skip-chars-forward "^,")
195: (skip-chars-forward ", "))
196: accumulated))
197:
198: (defun mail-comma-list-regexp (labels)
199: (let (pos)
200: (setq pos (or (string-match "[^ \t]" labels) 0))
201: ;; Remove leading and trailing whitespace.
202: (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
203: ;; Change each comma to \|, and flush surrounding whitespace.
204: (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
205: (setq labels
206: (concat (substring labels 0 pos)
207: "\\|"
208: (substring labels (match-end 0))))))
209: labels)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.