Update the options in whitespace-style defcustom
[emacs.git] / lisp / mail / mail-utils.el
blob736e3f5254fcff2a1f147e2cfea6adc95ae88cb9
1 ;;; mail-utils.el --- utility functions used both by rmail and rnews
3 ;; Copyright (C) 1985, 2001-2015 Free Software Foundation, Inc.
5 ;; Maintainer: emacs-devel@gnu.org
6 ;; Keywords: mail, news
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; Utility functions for mail and netnews handling. These handle fine
26 ;; points of header parsing.
28 ;;; Code:
30 ;;;###autoload
31 (defcustom mail-use-rfc822 nil
32 "If non-nil, use a full, hairy RFC822 parser on mail addresses.
33 Otherwise, (the default) use a smaller, somewhat faster, and
34 often correct parser."
35 :type 'boolean
36 :group 'mail)
38 ;;;###autoload
39 (defcustom mail-dont-reply-to-names nil
40 "Regexp specifying addresses to prune from a reply message.
41 If this is nil, it is set the first time you compose a reply, to
42 a value which excludes your own email address.
44 Matching addresses are excluded from the CC field in replies, and
45 also the To field, unless this would leave an empty To field."
46 :type '(choice regexp (const :tag "Your Name" nil))
47 :group 'mail)
49 ;; Returns t if file FILE is an Rmail file.
50 ;;;###autoload
51 (defun mail-file-babyl-p (file)
52 "Return non-nil if FILE is a Babyl file."
53 (with-temp-buffer
54 (insert-file-contents file nil 0 100)
55 (looking-at "BABYL OPTIONS:")))
57 (defun mail-string-delete (string start end)
58 "Returns a string containing all of STRING except the part
59 from START (inclusive) to END (exclusive)."
60 (if (null end) (substring string 0 start)
61 (concat (substring string 0 start)
62 (substring string end nil))))
64 ;;;###autoload
65 (defun mail-quote-printable (string &optional wrapper)
66 "Convert a string to the \"quoted printable\" Q encoding if necessary.
67 If the string contains only ASCII characters and no troublesome ones,
68 we return it unconverted.
70 If the optional argument WRAPPER is non-nil,
71 we add the wrapper characters =?ISO-8859-1?Q?....?=."
72 (let ((i 0) (result ""))
73 (save-match-data
74 (while (or (string-match "[?=\"]" string i)
75 (string-match "[^\000-\177]" string i))
76 (setq result
77 (concat result (substring string i (match-beginning 0))
78 (upcase (format "=%02x"
79 (aref string (match-beginning 0))))))
80 (setq i (match-end 0)))
81 (if wrapper
82 (concat "=?ISO-8859-1?Q?"
83 result (substring string i)
84 "?=")
85 (concat result (substring string i))))))
87 ;;;###autoload
88 (defun mail-quote-printable-region (beg end &optional wrapper)
89 "Convert the region to the \"quoted printable\" Q encoding.
90 If the optional argument WRAPPER is non-nil,
91 we add the wrapper characters =?ISO-8859-1?Q?....?=."
92 (interactive "r\nP")
93 (save-match-data
94 (save-excursion
95 (goto-char beg)
96 (save-restriction
97 (narrow-to-region beg end)
98 (while (re-search-forward "[?=\"\200-\377]" nil t)
99 (replace-match (upcase (format "=%02x" (preceding-char)))
100 t t))
101 (when wrapper
102 (goto-char beg)
103 (insert "=?ISO-8859-1?Q?")
104 (goto-char end)
105 (insert "?="))))))
107 (defun mail-unquote-printable-hexdigit (char)
108 (setq char (upcase char))
109 (if (>= char ?A)
110 (+ (- char ?A) 10)
111 (- char ?0)))
113 ;;;###autoload
114 (defun mail-unquote-printable (string &optional wrapper)
115 "Undo the \"quoted printable\" encoding.
116 If the optional argument WRAPPER is non-nil,
117 we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=."
118 (save-match-data
119 (and wrapper
120 (string-match "\\`=\\?ISO-8859-1\\?Q\\?\\([^?]*\\)\\?" string)
121 (setq string (match-string 1 string)))
122 (let ((i 0) strings)
123 (while (string-match "=\\(..\\|\n\\)" string i)
124 (setq strings (cons (substring string i (match-beginning 0)) strings))
125 (unless (= (aref string (match-beginning 1)) ?\n)
126 (setq strings
127 (cons (make-string 1
128 (+ (* 16 (mail-unquote-printable-hexdigit
129 (aref string (match-beginning 1))))
130 (mail-unquote-printable-hexdigit
131 (aref string (1+ (match-beginning 1))))))
132 strings)))
133 (setq i (match-end 0)))
134 (apply 'concat (nreverse (cons (substring string i) strings))))))
136 ;; FIXME Gnus for some reason has `quoted-printable-decode-region' in qp.el.
137 ;;;###autoload
138 (defun mail-unquote-printable-region (beg end &optional wrapper noerror
139 unibyte)
140 "Undo the \"quoted printable\" encoding in buffer from BEG to END.
141 If the optional argument WRAPPER is non-nil,
142 we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=.
143 On encountering malformed quoted-printable text, exits with an error,
144 unless NOERROR is non-nil, in which case it continues, and returns nil
145 when finished. Returns non-nil on successful completion.
146 If UNIBYTE is non-nil, insert converted characters as unibyte.
147 That is useful if you are going to character code decoding afterward,
148 as Rmail does."
149 ;; FIXME: `unibyte' should always be non-nil, and the iso-latin-1
150 ;; specific handling should be removed (or moved elsewhere and generalized).
151 (interactive "r\nP")
152 (let (failed)
153 (save-match-data
154 (save-excursion
155 (save-restriction
156 (narrow-to-region beg end)
157 (goto-char (point-min))
158 (when (and wrapper
159 (looking-at "\\`=\\?ISO-8859-1\\?Q\\?\\([^?]*\\)\\?"))
160 (delete-region (match-end 1) end)
161 (delete-region (point) (match-beginning 1)))
162 (while (re-search-forward "=\\(\\([0-9A-F][0-9A-F]\\)\\|[=\n]\\|..\\)" nil t)
163 (goto-char (match-end 0))
164 (cond ((= (char-after (match-beginning 1)) ?\n)
165 (replace-match ""))
166 ((= (char-after (match-beginning 1)) ?=)
167 (replace-match "="))
168 ((match-beginning 2)
169 (let ((char (+ (* 16 (mail-unquote-printable-hexdigit
170 (char-after (match-beginning 2))))
171 (mail-unquote-printable-hexdigit
172 (char-after (1+ (match-beginning 2)))))))
173 (if unibyte
174 (progn
175 (replace-match "")
176 ;; insert-byte will insert this as a
177 ;; corresponding eight-bit character.
178 (insert-byte char 1))
179 (replace-match (make-string 1 char) t t))))
180 (noerror
181 (setq failed t))
183 (error "Malformed MIME quoted-printable message"))))
184 (not failed))))))
186 (autoload 'rfc822-addresses "rfc822")
188 (defun mail-strip-quoted-names (address)
189 "Delete comments and quoted strings in an address list ADDRESS.
190 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
191 Return a modified address list."
192 (when address
193 (if mail-use-rfc822
194 (mapconcat 'identity (rfc822-addresses address) ", ")
195 (let (pos)
197 ;; Strip comments.
198 (while (setq pos (string-match
199 "[ \t]*(\\([^()\\]\\|\\\\.\\|\\\\\n\\)*)"
200 address))
201 (setq address (replace-match "" nil nil address 0)))
203 ;; strip surrounding whitespace
204 (string-match "\\`[ \t\n]*" address)
205 (setq address (substring address
206 (match-end 0)
207 (string-match "[ \t\n]*\\'" address
208 (match-end 0))))
210 ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
211 (setq pos 0)
212 (while (setq pos (string-match
213 "\\([ \t]?\\)\\([ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*\\)"
214 address pos))
215 ;; If the next thing is "@", we have "foo bar"@host. Leave it.
216 (if (and (> (length address) (match-end 0))
217 (= (aref address (match-end 0)) ?@))
218 (setq pos (match-end 0))
219 ;; Otherwise discard the "..." part.
220 (setq address (replace-match "" nil nil address 2))))
221 ;; If this address contains <...>, replace it with just
222 ;; the part between the <...>.
223 (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)"
224 address))
225 (setq address (replace-match (match-string 3 address)
226 nil 'literal address 2)))
227 address))))
229 (defun mail-dont-reply-to (destinations)
230 "Prune addresses from DESTINATIONS, a list of recipient addresses.
231 Remove all addresses matching `mail-dont-reply-to-names' from the
232 comma-separated list, and return the pruned list."
233 ;; FIXME this (setting a user option the first time a command is used)
234 ;; is somewhat strange. Normally one would never set the option,
235 ;; but instead fall back to the default so long as it was nil.
236 ;; Or just set the default directly in the defcustom.
237 (if (null mail-dont-reply-to-names)
238 (setq mail-dont-reply-to-names
239 (concat
240 ;; `rmail-default-dont-reply-to-names' is obsolete.
241 (if (bound-and-true-p rmail-default-dont-reply-to-names)
242 (concat rmail-default-dont-reply-to-names "\\|")
244 (if (and user-mail-address
245 (not (equal user-mail-address user-login-name)))
246 ;; Anchor the login name and email address so that we
247 ;; don't match substrings: if the login name is
248 ;; "foo", we shouldn't match "barfoo@baz.com".
249 (concat "\\`"
250 (regexp-quote user-mail-address)
251 "\\'\\|")
253 (concat "\\`" (regexp-quote user-login-name) "@"))))
254 ;; Split up DESTINATIONS and match each element separately.
255 (let ((start-pos 0) (cur-pos 0)
256 (case-fold-search t))
257 (while start-pos
258 (setq cur-pos (string-match "[,\"]" destinations cur-pos))
259 (if (and cur-pos (equal (match-string 0 destinations) "\""))
260 ;; Search for matching quote.
261 (let ((next-pos (string-match "\"" destinations (1+ cur-pos))))
262 (if next-pos
263 (setq cur-pos (1+ next-pos))
264 ;; If the open-quote has no close-quote,
265 ;; delete the open-quote to get something well-defined.
266 ;; This case is not valid, but it can happen if things
267 ;; are weird elsewhere.
268 (setq destinations (concat (substring destinations 0 cur-pos)
269 (substring destinations (1+ cur-pos))))
270 (setq cur-pos start-pos)))
271 (let* ((address (substring destinations start-pos cur-pos))
272 (naked-address (mail-strip-quoted-names address)))
273 (if (string-match mail-dont-reply-to-names naked-address)
274 (setq destinations (concat (substring destinations 0 start-pos)
275 (and cur-pos (substring destinations
276 (1+ cur-pos))))
277 cur-pos start-pos)
278 (setq cur-pos (and cur-pos (1+ cur-pos))
279 start-pos cur-pos))))))
280 ;; get rid of any trailing commas
281 (let ((pos (string-match "[ ,\t\n]*\\'" destinations)))
282 (if pos
283 (setq destinations (substring destinations 0 pos))))
284 ;; remove leading spaces. they bother me.
285 (if (string-match "\\(\\s \\|,\\)*" destinations)
286 (substring destinations (match-end 0))
287 destinations))
289 ;; Legacy name
290 (define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
293 ;;;###autoload
294 (defun mail-fetch-field (field-name &optional last all list)
295 "Return the value of the header field whose type is FIELD-NAME.
296 If second arg LAST is non-nil, use the last field of type FIELD-NAME.
297 If third arg ALL is non-nil, concatenate all such fields with commas between.
298 If 4th arg LIST is non-nil, return a list of all such fields.
299 The buffer should be narrowed to just the header, else false
300 matches may be returned from the message body."
301 (save-excursion
302 (goto-char (point-min))
303 (let ((case-fold-search t)
304 (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
305 (if (or all list)
306 (let ((value (if all "")))
307 (while (re-search-forward name nil t)
308 (let ((opoint (point)))
309 (while (progn (forward-line 1)
310 (looking-at "[ \t]")))
311 ;; Back up over newline, then trailing spaces or tabs
312 (forward-char -1)
313 (skip-chars-backward " \t" opoint)
314 (if list
315 (setq value (cons (buffer-substring-no-properties
316 opoint (point))
317 value))
318 (setq value (concat value
319 (if (string= value "") "" ", ")
320 (buffer-substring-no-properties
321 opoint (point)))))))
322 (if list
323 value
324 (and (not (string= value "")) value)))
325 (if (re-search-forward name nil t)
326 (progn
327 (if last (while (re-search-forward name nil t)))
328 (let ((opoint (point)))
329 (while (progn (forward-line 1)
330 (looking-at "[ \t]")))
331 ;; Back up over newline, then trailing spaces or tabs
332 (forward-char -1)
333 (skip-chars-backward " \t" opoint)
334 (buffer-substring-no-properties opoint (point)))))))))
336 ;; Parse a list of tokens separated by commas.
337 ;; It runs from point to the end of the visible part of the buffer.
338 ;; Whitespace before or after tokens is ignored,
339 ;; but whitespace within tokens is kept.
340 (defun mail-parse-comma-list ()
341 (let (accumulated
342 beg)
343 (skip-chars-forward " \t\n")
344 (while (not (eobp))
345 (setq beg (point))
346 (skip-chars-forward "^,")
347 (skip-chars-backward " \t\n")
348 (setq accumulated
349 (cons (buffer-substring-no-properties beg (point))
350 accumulated))
351 (skip-chars-forward "^,")
352 (skip-chars-forward ", \t\n"))
353 accumulated))
355 (defun mail-comma-list-regexp (labels)
356 (let (pos)
357 (setq pos (or (string-match "[^ \t]" labels) 0))
358 ;; Remove leading and trailing whitespace.
359 (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
360 ;; Change each comma to \|, and flush surrounding whitespace.
361 (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
362 (setq labels
363 (concat (substring labels 0 pos)
364 "\\|"
365 (substring labels (match-end 0))))))
366 labels)
368 (defun mail-rfc822-time-zone (time)
369 (let* ((sec (or (car (current-time-zone time)) 0))
370 (absmin (/ (abs sec) 60)))
371 (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
373 (defun mail-rfc822-date ()
374 (let* ((time (current-time))
375 (s (current-time-string time)))
376 (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s)
377 (concat (substring s (match-beginning 2) (match-end 2)) " "
378 (substring s (match-beginning 1) (match-end 1)) " "
379 (substring s (match-beginning 4) (match-end 4)) " "
380 (substring s (match-beginning 3) (match-end 3)) " "
381 (mail-rfc822-time-zone time))))
383 (defun mail-mbox-from ()
384 "Return an mbox \"From \" line for the current message.
385 The buffer should be narrowed to just the header."
386 (let* ((from (mail-strip-quoted-names (or (mail-fetch-field "from")
387 (mail-fetch-field "really-from")
388 (mail-fetch-field "sender")
389 (mail-fetch-field "return-path")
390 "unknown")))
391 (date (mail-fetch-field "date"))
392 ;; A From: header can contain multiple addresses, a "From "
393 ;; line must contain only one. (Bug#7760)
394 ;; See eg RFC 5322, 3.6.2. Originator Fields.
395 (end (string-match "[ \t]*[,\n]" from)))
396 (format "From %s %s\n" (if end
397 (substring from 0 end)
398 from)
399 (or (and date
400 (ignore-errors
401 (current-time-string (date-to-time date))))
402 (current-time-string)))))
404 (provide 'mail-utils)
406 ;;; mail-utils.el ends here