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