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