Mercurial > emacs
annotate lisp/mail/mailheader.el @ 22312:eed3a1470e83
(install-arch-indep): Don't die if site-lisp/ isn't writable.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Mon, 01 Jun 1998 03:46:31 +0000 |
parents | 1808d2672d00 |
children | 011361a15bac |
rev | line source |
---|---|
15580
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
1 ;;; mailheader.el --- Mail header parsing, merging, formatting |
15512 | 2 |
3 ;; Copyright (C) 1996 by Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Erik Naggum <erik@arcana.naggum.no> | |
6 ;; Keywords: tools, mail, news | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
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 2, or (at your option) | |
13 ;; any later version. | |
14 | |
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. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
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 | |
39 ;; messge, it is a string, the value of the header. An extracted set of | |
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)) | |
66 (progn (forward-char) | |
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, | |
112 with any subsequent elements bing the result of parsing the value. | |
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) | |
149 "\n"))) | |
150 | |
151 (defun mail-header-format (format-rules headers) | |
152 "Use FORMAT-RULES to format HEADERS and insert into current buffer. | |
153 FORMAT-RULES is an alist whose keys are header names (symbols), and whose | |
154 values are functions that format the header, the results of which are | |
155 inserted, unless it is nil. The function takes two arguments, the header | |
156 symbol, and the value of that header. If the function itself is nil, the | |
157 default action is to insert the value of the header, unless it is nil. | |
158 The headers are inserted in the order of the FORMAT-RULES. | |
159 A key of t represents any otherwise unmentioned headers. | |
160 A key of nil has as its value a list of defaulted headers to ignore." | |
161 (let ((ignore (append (cdr (assq nil format-rules)) | |
162 (mapcar #'car format-rules)))) | |
163 (dolist (rule format-rules) | |
164 (let* ((header (car rule)) | |
165 (value (mail-header header))) | |
166 (cond ((null header) 'ignore) | |
167 ((eq header t) | |
168 (dolist (defaulted headers) | |
169 (unless (memq (car defaulted) ignore) | |
170 (let* ((header (car defaulted)) | |
171 (value (cdr defaulted))) | |
172 (if (cdr rule) | |
173 (funcall (cdr rule) header value) | |
174 (funcall mail-header-format-function header value)))))) | |
175 (value | |
176 (if (cdr rule) | |
177 (funcall (cdr rule) header value) | |
178 (funcall mail-header-format-function header value)))))) | |
179 (insert "\n"))) | |
180 | |
181 (provide 'mailheader) | |
182 | |
15580
1808d2672d00
(require 'cl) is only necessary when compiling.
Erik Naggum <erik@naggum.no>
parents:
15512
diff
changeset
|
183 ;;; mailheader.el ends here |