|
0
|
1 ;;; mail-header.el --- Mail header parsing, merging, formatting
|
|
|
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
|
|
|
28 ;; mail news, and some other systems. The simple syntactic rules for such
|
|
|
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
|
|
98
|
39 ;; message, it is a string, the value of the header. An extracted set of
|
|
0
|
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
|
|
|
49 (require 'cl)
|
|
|
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))
|
|
108
|
65 (progn (forward-char)
|
|
0
|
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) " "))
|
|
98
|
75 (cons header (car value)))
|
|
0
|
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,
|
|
98
|
111 with any subsequent elements being the result of parsing the value.
|
|
0
|
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))
|
|
98
|
120 (entry (assq header alist)))
|
|
0
|
121 (if entry
|
|
|
122 (setf (cdr entry) value)
|
|
98
|
123 (nconc alist (list (cons header value)))))
|
|
0
|
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)
|
|
|
148 "\n")))
|
|
|
149
|
|
|
150 (defun mail-header-format (format-rules headers)
|
|
|
151 "Use FORMAT-RULES to format HEADERS and insert into current buffer.
|
|
|
152 FORMAT-RULES is an alist whose keys are header names (symbols), and whose
|
|
|
153 values are functions that format the header, the results of which are
|
|
|
154 inserted, unless it is nil. The function takes two arguments, the header
|
|
|
155 symbol, and the value of that header. If the function itself is nil, the
|
|
|
156 default action is to insert the value of the header, unless it is nil.
|
|
|
157 The headers are inserted in the order of the FORMAT-RULES.
|
|
|
158 A key of t represents any otherwise unmentioned headers.
|
|
|
159 A key of nil has as its value a list of defaulted headers to ignore."
|
|
|
160 (let ((ignore (append (cdr (assq nil format-rules))
|
|
|
161 (mapcar #'car format-rules))))
|
|
|
162 (dolist (rule format-rules)
|
|
|
163 (let* ((header (car rule))
|
|
98
|
164 (value (mail-header header)))
|
|
0
|
165 (cond ((null header) 'ignore)
|
|
|
166 ((eq header t)
|
|
|
167 (dolist (defaulted headers)
|
|
|
168 (unless (memq (car defaulted) ignore)
|
|
|
169 (let* ((header (car defaulted))
|
|
|
170 (value (cdr defaulted)))
|
|
|
171 (if (cdr rule)
|
|
|
172 (funcall (cdr rule) header value)
|
|
98
|
173 (funcall mail-header-format-function header value))))))
|
|
0
|
174 (value
|
|
|
175 (if (cdr rule)
|
|
|
176 (funcall (cdr rule) header value)
|
|
98
|
177 (funcall mail-header-format-function header value))))))
|
|
0
|
178 (insert "\n")))
|
|
|
179
|
|
|
180 (provide 'mailheader)
|
|
|
181
|
|
|
182 ;;; mail-header.el ends here
|
