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