Mercurial > emacs
annotate lisp/gnus/ietf-drums.el @ 41309:8c4c4027c7bd
(cperl-perldoc): Require man before binding `manual-program'.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Tue, 20 Nov 2001 14:20:41 +0000 |
parents | a26d9b55abb6 |
children | 52d99cc2e9e3 |
rev | line source |
---|---|
38413
a26d9b55abb6
Some fixes to follow coding conventions in files from Gnus.
Pavel Janík <Pavel@Janik.cz>
parents:
33342
diff
changeset
|
1 ;;; ietf-drums.el --- functions for parsing RFC822bis headers |
31717 | 2 ;; Copyright (C) 1998, 1999, 2000 |
3 ;; Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
6 ;; This file is part of GNU Emacs. | |
7 | |
8 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
9 ;; it under the terms of the GNU General Public License as published by | |
10 ;; the Free Software Foundation; either version 2, or (at your option) | |
11 ;; any later version. | |
12 | |
13 ;; GNU Emacs is distributed in the hope that it will be useful, | |
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 ;; GNU General Public License for more details. | |
17 | |
18 ;; You should have received a copy of the GNU General Public License | |
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 ;; Boston, MA 02111-1307, USA. | |
22 | |
23 ;;; Commentary: | |
24 | |
25 ;; DRUMS is an IETF Working Group that works (or worked) on the | |
26 ;; successor to RFC822, "Standard For The Format Of Arpa Internet Text | |
27 ;; Messages". This library is based on | |
28 ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. | |
29 | |
30 ;;; Code: | |
31 | |
32514
a8017f96379d
(mm-util): Require CL when compiling.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
31717
diff
changeset
|
32 (eval-when-compile (require 'cl)) |
31717 | 33 (require 'time-date) |
34 (require 'mm-util) | |
35 | |
36 (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" | |
37 "US-ASCII control characters excluding CR, LF and white space.") | |
38 (defvar ietf-drums-text-token "\001-\011\013\014\016-\177" | |
39 "US-ASCII characters exlcuding CR and LF.") | |
40 (defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" | |
41 "Special characters.") | |
42 (defvar ietf-drums-quote-token "\\" | |
43 "Quote character.") | |
44 (defvar ietf-drums-wsp-token " \t" | |
45 "White space.") | |
46 (defvar ietf-drums-fws-regexp | |
47 (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") | |
48 "Folding white space.") | |
49 (defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" | |
50 "Textual token.") | |
51 (defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." | |
52 "Textual token including full stop.") | |
53 (defvar ietf-drums-qtext-token | |
54 (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") | |
55 "Non-white-space control characaters, plus the rest of ASCII excluding backslash and doublequote.") | |
56 (defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" | |
57 "Tspecials.") | |
58 | |
59 (defvar ietf-drums-syntax-table | |
60 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) | |
61 (modify-syntax-entry ?\\ "/" table) | |
62 (modify-syntax-entry ?< "(" table) | |
63 (modify-syntax-entry ?> ")" table) | |
64 (modify-syntax-entry ?@ "w" table) | |
65 (modify-syntax-entry ?/ "w" table) | |
66 (modify-syntax-entry ?= " " table) | |
67 (modify-syntax-entry ?* " " table) | |
68 (modify-syntax-entry ?\; " " table) | |
69 (modify-syntax-entry ?\' " " table) | |
70 table)) | |
71 | |
72 (defun ietf-drums-token-to-list (token) | |
73 "Translate TOKEN into a list of characters." | |
74 (let ((i 0) | |
75 b e c out range) | |
76 (while (< i (length token)) | |
77 (setq c (mm-char-int (aref token i))) | |
78 (incf i) | |
79 (cond | |
80 ((eq c (mm-char-int ?-)) | |
81 (if b | |
82 (setq range t) | |
83 (push c out))) | |
84 (range | |
85 (while (<= b c) | |
86 (push (mm-make-char 'ascii b) out) | |
87 (incf b)) | |
88 (setq range nil)) | |
89 ((= i (length token)) | |
90 (push (mm-make-char 'ascii c) out)) | |
91 (t | |
92 (when b | |
93 (push (mm-make-char 'ascii b) out)) | |
94 (setq b c)))) | |
95 (nreverse out))) | |
96 | |
97 (defsubst ietf-drums-init (string) | |
98 (set-syntax-table ietf-drums-syntax-table) | |
99 (insert string) | |
100 (ietf-drums-unfold-fws) | |
101 (goto-char (point-min))) | |
102 | |
103 (defun ietf-drums-remove-comments (string) | |
104 "Remove comments from STRING." | |
105 (with-temp-buffer | |
106 (let (c) | |
107 (ietf-drums-init string) | |
108 (while (not (eobp)) | |
109 (setq c (char-after)) | |
110 (cond | |
111 ((eq c ?\") | |
112 (forward-sexp 1)) | |
113 ((eq c ?\() | |
114 (delete-region (point) (progn (forward-sexp 1) (point)))) | |
115 (t | |
116 (forward-char 1)))) | |
117 (buffer-string)))) | |
118 | |
119 (defun ietf-drums-remove-whitespace (string) | |
120 "Remove whitespace from STRING." | |
121 (with-temp-buffer | |
122 (ietf-drums-init string) | |
123 (let (c) | |
124 (while (not (eobp)) | |
125 (setq c (char-after)) | |
126 (cond | |
127 ((eq c ?\") | |
128 (forward-sexp 1)) | |
129 ((eq c ?\() | |
130 (forward-sexp 1)) | |
131 ((memq c '(? ?\t ?\n)) | |
132 (delete-char 1)) | |
133 (t | |
134 (forward-char 1)))) | |
135 (buffer-string)))) | |
136 | |
137 (defun ietf-drums-get-comment (string) | |
138 "Return the first comment in STRING." | |
139 (with-temp-buffer | |
140 (ietf-drums-init string) | |
141 (let (result c) | |
142 (while (not (eobp)) | |
143 (setq c (char-after)) | |
144 (cond | |
145 ((eq c ?\") | |
146 (forward-sexp 1)) | |
147 ((eq c ?\() | |
148 (setq result | |
149 (buffer-substring | |
150 (1+ (point)) | |
151 (progn (forward-sexp 1) (1- (point)))))) | |
152 (t | |
153 (forward-char 1)))) | |
154 result))) | |
155 | |
156 (defun ietf-drums-strip (string) | |
157 "Remove comments and whitespace from STRING." | |
158 (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) | |
159 | |
160 (defun ietf-drums-parse-address (string) | |
161 "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." | |
162 (with-temp-buffer | |
163 (let (display-name mailbox c display-string) | |
164 (ietf-drums-init string) | |
165 (while (not (eobp)) | |
166 (setq c (char-after)) | |
167 (cond | |
168 ((or (eq c ? ) | |
169 (eq c ?\t)) | |
170 (forward-char 1)) | |
171 ((eq c ?\() | |
172 (forward-sexp 1)) | |
173 ((eq c ?\") | |
174 (push (buffer-substring | |
175 (1+ (point)) (progn (forward-sexp 1) (1- (point)))) | |
176 display-name)) | |
177 ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) | |
178 (push (buffer-substring (point) (progn (forward-sexp 1) (point))) | |
179 display-name)) | |
180 ((eq c ?<) | |
181 (setq mailbox | |
182 (ietf-drums-remove-whitespace | |
183 (ietf-drums-remove-comments | |
184 (buffer-substring | |
185 (1+ (point)) | |
186 (progn (forward-sexp 1) (1- (point)))))))) | |
187 (t (error "Unknown symbol: %c" c)))) | |
188 ;; If we found no display-name, then we look for comments. | |
189 (if display-name | |
190 (setq display-string | |
191 (mapconcat 'identity (reverse display-name) " ")) | |
192 (setq display-string (ietf-drums-get-comment string))) | |
193 (if (not mailbox) | |
194 (when (string-match "@" display-string) | |
195 (cons | |
196 (mapconcat 'identity (nreverse display-name) "") | |
197 (ietf-drums-get-comment string))) | |
198 (cons mailbox display-string))))) | |
199 | |
200 (defun ietf-drums-parse-addresses (string) | |
201 "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs." | |
202 (with-temp-buffer | |
203 (ietf-drums-init string) | |
204 (let ((beg (point)) | |
205 pairs c) | |
206 (while (not (eobp)) | |
207 (setq c (char-after)) | |
208 (cond | |
209 ((memq c '(?\" ?< ?\()) | |
210 (forward-sexp 1)) | |
211 ((eq c ?,) | |
212 (push (ietf-drums-parse-address (buffer-substring beg (point))) | |
213 pairs) | |
214 (forward-char 1) | |
215 (setq beg (point))) | |
216 (t | |
217 (forward-char 1)))) | |
218 (push (ietf-drums-parse-address (buffer-substring beg (point))) | |
219 pairs) | |
220 (nreverse pairs)))) | |
221 | |
222 (defun ietf-drums-unfold-fws () | |
223 "Unfold folding white space in the current buffer." | |
224 (goto-char (point-min)) | |
225 (while (re-search-forward ietf-drums-fws-regexp nil t) | |
226 (replace-match " " t t)) | |
227 (goto-char (point-min))) | |
228 | |
229 (defun ietf-drums-parse-date (string) | |
230 "Return an Emacs time spec from STRING." | |
231 (apply 'encode-time (parse-time-string string))) | |
232 | |
233 (defun ietf-drums-narrow-to-header () | |
234 "Narrow to the header section in the current buffer." | |
235 (narrow-to-region | |
236 (goto-char (point-min)) | |
237 (if (re-search-forward "^\r?$" nil 1) | |
238 (match-beginning 0) | |
239 (point-max))) | |
240 (goto-char (point-min))) | |
241 | |
242 (defun ietf-drums-quote-string (string) | |
243 "Quote string if it needs quoting to be displayed in a header." | |
244 (if (string-match (concat "[^" ietf-drums-atext-token "]") string) | |
245 (concat "\"" string "\"") | |
246 string)) | |
247 | |
248 (provide 'ietf-drums) | |
249 | |
250 ;;; ietf-drums.el ends here |