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