Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; ietf-drums.el --- Functions for parsing RFC822bis headers |
e84b4b86 TTN |
2 | |
3 | ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, | |
ae940284 | 4 | ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
c113de23 GM |
5 | |
6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
7 | ;; This file is part of GNU Emacs. | |
8 | ||
5e809f55 | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
c113de23 | 10 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
11 | ;; the Free Software Foundation, either version 3 of the License, or |
12 | ;; (at your option) any later version. | |
c113de23 GM |
13 | |
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
5e809f55 | 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
c113de23 GM |
17 | ;; GNU General Public License for more details. |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
c113de23 GM |
21 | |
22 | ;;; Commentary: | |
23 | ||
24 | ;; DRUMS is an IETF Working Group that works (or worked) on the | |
25 | ;; successor to RFC822, "Standard For The Format Of Arpa Internet Text | |
26 | ;; Messages". This library is based on | |
27 | ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. | |
28 | ||
23f87bed MB |
29 | ;; Pending a real regression self test suite, Simon Josefsson added |
30 | ;; various self test expressions snipped from bug reports, and their | |
31 | ;; expected value, below. I you believe it could be useful, please | |
32 | ;; add your own test cases, or write a real self test suite, or just | |
33 | ;; remove this. | |
34 | ||
35 | ;; <m3oekvfd50.fsf@whitebox.m5r.de> | |
36 | ;; (ietf-drums-parse-address "'foo' <foo@example.com>") | |
37 | ;; => ("foo@example.com" . "'foo'") | |
38 | ||
c113de23 GM |
39 | ;;; Code: |
40 | ||
3b9d5a55 | 41 | (eval-when-compile (require 'cl)) |
c113de23 GM |
42 | (require 'time-date) |
43 | (require 'mm-util) | |
44 | ||
45 | (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" | |
46 | "US-ASCII control characters excluding CR, LF and white space.") | |
47 | (defvar ietf-drums-text-token "\001-\011\013\014\016-\177" | |
8f688cb0 | 48 | "US-ASCII characters excluding CR and LF.") |
c113de23 GM |
49 | (defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" |
50 | "Special characters.") | |
51 | (defvar ietf-drums-quote-token "\\" | |
52 | "Quote character.") | |
53 | (defvar ietf-drums-wsp-token " \t" | |
54 | "White space.") | |
55 | (defvar ietf-drums-fws-regexp | |
56 | (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") | |
57 | "Folding white space.") | |
58 | (defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" | |
59 | "Textual token.") | |
60 | (defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." | |
61 | "Textual token including full stop.") | |
62 | (defvar ietf-drums-qtext-token | |
63 | (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") | |
a1506d29 | 64 | "Non-white-space control characters, plus the rest of ASCII excluding |
8f688cb0 | 65 | backslash and doublequote.") |
c113de23 GM |
66 | (defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" |
67 | "Tspecials.") | |
68 | ||
69 | (defvar ietf-drums-syntax-table | |
70 | (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) | |
71 | (modify-syntax-entry ?\\ "/" table) | |
72 | (modify-syntax-entry ?< "(" table) | |
73 | (modify-syntax-entry ?> ")" table) | |
74 | (modify-syntax-entry ?@ "w" table) | |
75 | (modify-syntax-entry ?/ "w" table) | |
23f87bed MB |
76 | (modify-syntax-entry ?* "_" table) |
77 | (modify-syntax-entry ?\; "_" table) | |
78 | (modify-syntax-entry ?\' "_" table) | |
79 | (if (featurep 'xemacs) | |
80 | (let ((i 128)) | |
81 | (while (< i 256) | |
82 | (modify-syntax-entry i "w" table) | |
83 | (setq i (1+ i))))) | |
c113de23 GM |
84 | table)) |
85 | ||
86 | (defun ietf-drums-token-to-list (token) | |
87 | "Translate TOKEN into a list of characters." | |
88 | (let ((i 0) | |
89 | b e c out range) | |
90 | (while (< i (length token)) | |
91 | (setq c (mm-char-int (aref token i))) | |
92 | (incf i) | |
93 | (cond | |
94 | ((eq c (mm-char-int ?-)) | |
95 | (if b | |
96 | (setq range t) | |
97 | (push c out))) | |
98 | (range | |
99 | (while (<= b c) | |
01c52d31 | 100 | (push (make-char 'ascii b) out) |
c113de23 GM |
101 | (incf b)) |
102 | (setq range nil)) | |
103 | ((= i (length token)) | |
01c52d31 | 104 | (push (make-char 'ascii c) out)) |
c113de23 GM |
105 | (t |
106 | (when b | |
01c52d31 | 107 | (push (make-char 'ascii b) out)) |
c113de23 GM |
108 | (setq b c)))) |
109 | (nreverse out))) | |
110 | ||
111 | (defsubst ietf-drums-init (string) | |
112 | (set-syntax-table ietf-drums-syntax-table) | |
113 | (insert string) | |
114 | (ietf-drums-unfold-fws) | |
115 | (goto-char (point-min))) | |
116 | ||
117 | (defun ietf-drums-remove-comments (string) | |
118 | "Remove comments from STRING." | |
119 | (with-temp-buffer | |
120 | (let (c) | |
121 | (ietf-drums-init string) | |
122 | (while (not (eobp)) | |
123 | (setq c (char-after)) | |
124 | (cond | |
125 | ((eq c ?\") | |
8e38a1a9 MB |
126 | (condition-case err |
127 | (forward-sexp 1) | |
128 | (error (goto-char (point-max))))) | |
c113de23 | 129 | ((eq c ?\() |
8e38a1a9 MB |
130 | (delete-region |
131 | (point) | |
132 | (condition-case nil | |
133 | (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) | |
134 | (modify-syntax-entry ?\" "w") | |
135 | (forward-sexp 1) | |
136 | (point)) | |
137 | (error (point-max))))) | |
c113de23 GM |
138 | (t |
139 | (forward-char 1)))) | |
140 | (buffer-string)))) | |
141 | ||
142 | (defun ietf-drums-remove-whitespace (string) | |
143 | "Remove whitespace from STRING." | |
144 | (with-temp-buffer | |
145 | (ietf-drums-init string) | |
146 | (let (c) | |
147 | (while (not (eobp)) | |
148 | (setq c (char-after)) | |
149 | (cond | |
150 | ((eq c ?\") | |
151 | (forward-sexp 1)) | |
152 | ((eq c ?\() | |
153 | (forward-sexp 1)) | |
8afb8b29 | 154 | ((memq c '(?\ ?\t ?\n)) |
c113de23 GM |
155 | (delete-char 1)) |
156 | (t | |
157 | (forward-char 1)))) | |
158 | (buffer-string)))) | |
159 | ||
160 | (defun ietf-drums-get-comment (string) | |
161 | "Return the first comment in STRING." | |
162 | (with-temp-buffer | |
163 | (ietf-drums-init string) | |
164 | (let (result c) | |
165 | (while (not (eobp)) | |
166 | (setq c (char-after)) | |
167 | (cond | |
168 | ((eq c ?\") | |
169 | (forward-sexp 1)) | |
170 | ((eq c ?\() | |
171 | (setq result | |
172 | (buffer-substring | |
173 | (1+ (point)) | |
174 | (progn (forward-sexp 1) (1- (point)))))) | |
175 | (t | |
176 | (forward-char 1)))) | |
177 | result))) | |
178 | ||
179 | (defun ietf-drums-strip (string) | |
180 | "Remove comments and whitespace from STRING." | |
181 | (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) | |
182 | ||
183 | (defun ietf-drums-parse-address (string) | |
184 | "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." | |
185 | (with-temp-buffer | |
186 | (let (display-name mailbox c display-string) | |
187 | (ietf-drums-init string) | |
188 | (while (not (eobp)) | |
189 | (setq c (char-after)) | |
190 | (cond | |
191 | ((or (eq c ? ) | |
192 | (eq c ?\t)) | |
193 | (forward-char 1)) | |
194 | ((eq c ?\() | |
195 | (forward-sexp 1)) | |
196 | ((eq c ?\") | |
197 | (push (buffer-substring | |
198 | (1+ (point)) (progn (forward-sexp 1) (1- (point)))) | |
199 | display-name)) | |
200 | ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) | |
201 | (push (buffer-substring (point) (progn (forward-sexp 1) (point))) | |
202 | display-name)) | |
203 | ((eq c ?<) | |
204 | (setq mailbox | |
205 | (ietf-drums-remove-whitespace | |
206 | (ietf-drums-remove-comments | |
207 | (buffer-substring | |
208 | (1+ (point)) | |
209 | (progn (forward-sexp 1) (1- (point)))))))) | |
01c52d31 MB |
210 | (t |
211 | (message "Unknown symbol: %c" c) | |
212 | (forward-char 1)))) | |
c113de23 GM |
213 | ;; If we found no display-name, then we look for comments. |
214 | (if display-name | |
215 | (setq display-string | |
216 | (mapconcat 'identity (reverse display-name) " ")) | |
217 | (setq display-string (ietf-drums-get-comment string))) | |
218 | (if (not mailbox) | |
219 | (when (string-match "@" display-string) | |
220 | (cons | |
221 | (mapconcat 'identity (nreverse display-name) "") | |
222 | (ietf-drums-get-comment string))) | |
223 | (cons mailbox display-string))))) | |
224 | ||
01c52d31 MB |
225 | (defun ietf-drums-parse-addresses (string &optional rawp) |
226 | "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. | |
227 | If RAWP, don't actually parse the addresses, but instead return | |
228 | a list of address strings." | |
23f87bed MB |
229 | (if (null string) |
230 | nil | |
231 | (with-temp-buffer | |
232 | (ietf-drums-init string) | |
233 | (let ((beg (point)) | |
234 | pairs c address) | |
235 | (while (not (eobp)) | |
236 | (setq c (char-after)) | |
237 | (cond | |
238 | ((memq c '(?\" ?< ?\()) | |
239 | (condition-case nil | |
240 | (forward-sexp 1) | |
241 | (error | |
242 | (skip-chars-forward "^,")))) | |
243 | ((eq c ?,) | |
244 | (setq address | |
01c52d31 MB |
245 | (if rawp |
246 | (buffer-substring beg (point)) | |
247 | (condition-case nil | |
248 | (ietf-drums-parse-address | |
249 | (buffer-substring beg (point))) | |
250 | (error nil)))) | |
23f87bed MB |
251 | (if address (push address pairs)) |
252 | (forward-char 1) | |
253 | (setq beg (point))) | |
254 | (t | |
255 | (forward-char 1)))) | |
256 | (setq address | |
01c52d31 MB |
257 | (if rawp |
258 | (buffer-substring beg (point)) | |
259 | (condition-case nil | |
260 | (ietf-drums-parse-address | |
261 | (buffer-substring beg (point))) | |
262 | (error nil)))) | |
23f87bed MB |
263 | (if address (push address pairs)) |
264 | (nreverse pairs))))) | |
c113de23 GM |
265 | |
266 | (defun ietf-drums-unfold-fws () | |
267 | "Unfold folding white space in the current buffer." | |
268 | (goto-char (point-min)) | |
269 | (while (re-search-forward ietf-drums-fws-regexp nil t) | |
270 | (replace-match " " t t)) | |
271 | (goto-char (point-min))) | |
272 | ||
273 | (defun ietf-drums-parse-date (string) | |
274 | "Return an Emacs time spec from STRING." | |
275 | (apply 'encode-time (parse-time-string string))) | |
276 | ||
277 | (defun ietf-drums-narrow-to-header () | |
278 | "Narrow to the header section in the current buffer." | |
279 | (narrow-to-region | |
280 | (goto-char (point-min)) | |
281 | (if (re-search-forward "^\r?$" nil 1) | |
282 | (match-beginning 0) | |
283 | (point-max))) | |
284 | (goto-char (point-min))) | |
285 | ||
286 | (defun ietf-drums-quote-string (string) | |
287 | "Quote string if it needs quoting to be displayed in a header." | |
288 | (if (string-match (concat "[^" ietf-drums-atext-token "]") string) | |
289 | (concat "\"" string "\"") | |
290 | string)) | |
291 | ||
01c52d31 MB |
292 | (defun ietf-drums-make-address (name address) |
293 | (if name | |
294 | (concat (ietf-drums-quote-string name) " <" address ">") | |
295 | address)) | |
296 | ||
c113de23 GM |
297 | (provide 'ietf-drums) |
298 | ||
cbee283d | 299 | ;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9 |
c113de23 | 300 | ;;; ietf-drums.el ends here |