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