Mercurial > emacs
annotate lisp/mail/mailheader.el @ 110682:ba6a1c230532
gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid regexp backtrace overflows.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Fri, 01 Oct 2010 13:33:03 +0000 |
parents | 280c8ae2476d |
children | af2f491b6b27 |
rev | line source |
---|---|
38436
b174db545cfd
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33413
diff
changeset
|
1 ;;; mailheader.el --- mail header parsing, merging, formatting |
15512 | 2 |
74509 | 3 ;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, |
106815 | 4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
15512 | 5 |
30316
a0e2fa7d8bb7
Correct author's mail address.
Gerd Moellmann <gerd@gnu.org>
parents:
26135
diff
changeset
|
6 ;; Author: Erik Naggum <erik@naggum.no> |
15512 | 7 ;; Keywords: tools, mail, news |
110015
280c8ae2476d
Add "Package:" file headers to denote built-in packages.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
8 ;; Package: mail-utils |
15512 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
94674
ef65fa4dca3b
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
12 ;; GNU Emacs is free software: you can redistribute it and/or modify |
15512 | 13 ;; it under the terms of the GNU General Public License as published by |
94674
ef65fa4dca3b
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
14 ;; the Free Software Foundation, either version 3 of the License, or |
ef65fa4dca3b
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
15 ;; (at your option) any later version. |
15512 | 16 |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
94674
ef65fa4dca3b
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
15512 | 24 |
25 ;;; Commentary: | |
26 | |
27 ;; This package provides an abstraction to RFC822-style messages, used in | |
15580
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
28 ;; mail, news, and some other systems. The simple syntactic rules for such |
15512 | 29 ;; headers, such as quoting and line folding, are routinely reimplemented |
30 ;; in many individual packages. This package removes the need for this | |
31 ;; redundancy by representing message headers as association lists, | |
32 ;; offering functions to extract the set of headers from a message, to | |
33 ;; parse individual headers, to merge sets of headers, and to format a set | |
34 ;; of headers. | |
35 | |
36 ;; The car of each element in the message-header alist is a symbol whose | |
37 ;; print name is the name of the header, in all lower-case. The cdr of an | |
38 ;; element depends on the operation. After extracting headers from a | |
33413 | 39 ;; message, it is a string, the value of the header. An extracted set of |
15512 | 40 ;; headers may be parsed further, which may turn it into a list, whose car |
41 ;; is the original value and whose subsequent elements depend on the | |
42 ;; header. For formatting, it is evaluated to obtain the strings to be | |
43 ;; inserted. For merging, one set of headers consists of strings, while | |
44 ;; the other set will be evaluated with the symbols in the first set of | |
45 ;; headers bound to their respective values. | |
46 | |
47 ;;; Code: | |
48 | |
15580
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
49 (eval-when-compile |
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
50 (require 'cl)) |
15512 | 51 |
52 ;; Make the byte-compiler shut up. | |
53 (defvar headers) | |
54 | |
55 (defun mail-header-extract () | |
56 "Extract headers from current buffer after point. | |
57 Returns a header alist, where each element is a cons cell (name . value), | |
58 where NAME is a symbol, and VALUE is the string value of the header having | |
59 that name." | |
60 (let ((message-headers ()) (top (point)) | |
61 start end) | |
62 (while (and (setq start (point)) | |
63 (> (skip-chars-forward "^\0- :") 0) | |
64 (= (following-char) ?:) | |
65 (setq end (point)) | |
26135
6d8687925869
(mail-header-extract, mail-header-format): Doc fix.
Dave Love <fx@gnu.org>
parents:
22866
diff
changeset
|
66 (progn (forward-char) |
15512 | 67 (> (skip-chars-forward " \t") 0))) |
68 (let ((header (intern (downcase (buffer-substring start end)))) | |
69 (value (list (buffer-substring | |
70 (point) (progn (end-of-line) (point)))))) | |
71 (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) | |
72 (push (buffer-substring (point) (progn (end-of-line) (point))) | |
73 value)) | |
74 (push (if (cdr value) | |
75 (cons header (mapconcat #'identity (nreverse value) " ")) | |
76 (cons header (car value))) | |
77 message-headers))) | |
78 (goto-char top) | |
79 (nreverse message-headers))) | |
80 | |
81 (defun mail-header-extract-no-properties () | |
82 "Extract headers from current buffer after point, without properties. | |
83 Returns a header alist, where each element is a cons cell (name . value), | |
84 where NAME is a symbol, and VALUE is the string value of the header having | |
85 that name." | |
86 (mapcar | |
87 (lambda (elt) | |
88 (set-text-properties 0 (length (cdr elt)) nil (cdr elt)) | |
89 elt) | |
90 (mail-header-extract))) | |
91 | |
92 (defun mail-header-parse (parsing-rules headers) | |
93 "Apply PARSING-RULES to HEADERS. | |
94 PARSING-RULES is an alist whose keys are header names (symbols) and whose | |
95 value is a parsing function. The function takes one argument, a string, | |
96 and return a list of values, which will destructively replace the value | |
97 associated with the key in HEADERS, after being prepended with the original | |
98 value." | |
99 (dolist (rule parsing-rules) | |
100 (let ((header (assq (car rule) headers))) | |
101 (when header | |
102 (if (consp (cdr header)) | |
103 (setf (cddr header) (funcall (cdr rule) (cadr header))) | |
104 (setf (cdr header) | |
105 (cons (cdr header) (funcall (cdr rule) (cdr header)))))))) | |
106 headers) | |
107 | |
108 (defsubst mail-header (header &optional header-alist) | |
109 "Return the value associated with header HEADER in HEADER-ALIST. | |
110 If the value is a string, it is the original value of the header. If the | |
111 value is a list, its first element is the original value of the header, | |
26135
6d8687925869
(mail-header-extract, mail-header-format): Doc fix.
Dave Love <fx@gnu.org>
parents:
22866
diff
changeset
|
112 with any subsequent elements being the result of parsing the value. |
15512 | 113 If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." |
114 (cdr (assq header (or header-alist headers)))) | |
115 | |
116 (defun mail-header-set (header value &optional header-alist) | |
117 "Set the value associated with header HEADER to VALUE in HEADER-ALIST. | |
118 HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. | |
119 See `mail-header' for the semantics of VALUE." | |
120 (let* ((alist (or header-alist headers)) | |
121 (entry (assq header alist))) | |
122 (if entry | |
123 (setf (cdr entry) value) | |
124 (nconc alist (list (cons header value))))) | |
125 value) | |
126 | |
127 (defsetf mail-header (header &optional header-alist) (value) | |
128 `(mail-header-set ,header ,value ,header-alist)) | |
129 | |
130 (defun mail-header-merge (merge-rules headers) | |
131 "Return a new header alist with MERGE-RULES applied to HEADERS. | |
132 MERGE-RULES is an alist whose keys are header names (symbols) and whose | |
133 values are forms to evaluate, the results of which are the new headers. It | |
134 should be a string or a list of string. The first element may be nil to | |
135 denote that the formatting functions must use the remaining elements, or | |
136 skip the header altogether if there are no other elements. | |
137 The macro `mail-header' can be used to access headers in HEADERS." | |
138 (mapcar | |
139 (lambda (rule) | |
140 (cons (car rule) (eval (cdr rule)))) | |
141 merge-rules)) | |
142 | |
143 (defvar mail-header-format-function | |
144 (lambda (header value) | |
145 "Function to format headers without a specified formatting function." | |
146 (insert (capitalize (symbol-name header)) | |
147 ": " | |
148 (if (consp value) (car value) value) | |
67213
818361523ce8
* longlines.el (longlines-mode): Add mail-setup-hook.
Chong Yidong <cyd@stupidchicken.com>
parents:
66965
diff
changeset
|
149 "\n"))) |
15512 | 150 |
151 (defun mail-header-format (format-rules headers) | |
152 "Use FORMAT-RULES to format HEADERS and insert into current buffer. | |
22866
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
153 HEADERS should be an alist of the form (HEADER . VALUE), |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
154 where HEADER is a header field name (a symbol or a string), |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
155 and VALUE is the contents for that header field. |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
156 |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
157 FORMAT-RULES is an alist of elements (HEADER . FUNCTION) Here HEADER |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
158 is a header field name (a symbol), and FUNCTION is how to format that |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
159 header field, if it appears in HEADERS. Each FUNCTION should take two |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
160 arguments: the header symbol, and the value of that header. The value |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
161 returned by FUNCTION is inserted in the buffer unless it is nil. |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
162 |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
163 If the function for a header field is nil, or if no function is |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
164 specified for a particular header field, the default action is to |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
165 insert the value of the header, unless it is nil. |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
166 |
15512 | 167 The headers are inserted in the order of the FORMAT-RULES. |
26135
6d8687925869
(mail-header-extract, mail-header-format): Doc fix.
Dave Love <fx@gnu.org>
parents:
22866
diff
changeset
|
168 A key of t in FORMAT-RULES represents any otherwise unmentioned headers. |
15512 | 169 A key of nil has as its value a list of defaulted headers to ignore." |
170 (let ((ignore (append (cdr (assq nil format-rules)) | |
171 (mapcar #'car format-rules)))) | |
172 (dolist (rule format-rules) | |
173 (let* ((header (car rule)) | |
174 (value (mail-header header))) | |
22866
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
175 (if (stringp header) |
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
176 (setq header (intern header))) |
15512 | 177 (cond ((null header) 'ignore) |
178 ((eq header t) | |
179 (dolist (defaulted headers) | |
180 (unless (memq (car defaulted) ignore) | |
181 (let* ((header (car defaulted)) | |
182 (value (cdr defaulted))) | |
183 (if (cdr rule) | |
184 (funcall (cdr rule) header value) | |
22866
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
185 (funcall mail-header-format-function header value)))))) |
15512 | 186 (value |
187 (if (cdr rule) | |
188 (funcall (cdr rule) header value) | |
22866
011361a15bac
(mail-header-format): Convert string to symbol.
Richard M. Stallman <rms@gnu.org>
parents:
15580
diff
changeset
|
189 (funcall mail-header-format-function header value)))))) |
67213
818361523ce8
* longlines.el (longlines-mode): Add mail-setup-hook.
Chong Yidong <cyd@stupidchicken.com>
parents:
66965
diff
changeset
|
190 (insert "\n"))) |
15512 | 191 |
192 (provide 'mailheader) | |
193 | |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
79712
diff
changeset
|
194 ;; arch-tag: 6e7aa221-80b5-4b3d-b46f-fd66ab567be0 |
15580
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
195 ;;; mailheader.el ends here |