Mercurial > hg > xemacs-beta

comparison lisp/tl/std11-parse.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; std11-parse.el --- STD 11 parser for GNU Emacs
2
3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: mail, news, RFC 822, STD 11
7 ;; Version: $Id: std11-parse.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $
8
9 ;; This file is part of tl (Tiny Library).
10
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
15
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with This program; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Code:
27
28 (require 'std11)
29
30 (autoload 'find-charset-string "emu")
31
32
33 ;;; @ lexical analyze
34 ;;;
35
36 (defconst std11-space-chars " \t\n")
37 (defconst std11-spaces-regexp (concat "^[" std11-space-chars "]+"))
38 (defconst std11-special-chars "][()<>@,;:\\<>.\"")
39 (defconst std11-atom-regexp
40 (concat "^[^" std11-special-chars std11-space-chars "]+"))
41
42 (defun std11-analyze-spaces (str)
43 (if (string-match std11-spaces-regexp str)
44 (let ((end (match-end 0)))
45 (cons (cons 'spaces (substring str 0 end))
46 (substring str end)
47 ))))
48
49 (defun std11-analyze-special (str)
50 (if (and (> (length str) 0)
51 (find (aref str 0) std11-special-chars)
52 )
53 (cons (cons 'specials (substring str 0 1))
54 (substring str 1)
55 )))
56
57 (defun std11-analyze-atom (str)
58 (if (string-match std11-atom-regexp str)
59 (let ((end (match-end 0)))
60 (cons (cons 'atom (substring str 0 end))
61 (substring str end)
62 ))))
63
64 (defun std11-check-enclosure (str open close &optional recursive from)
65 (let ((len (length str))
66 (i (or from 0))
67 )
68 (if (and (> len i)
69 (eq (aref str i) open))
70 (let (p chr dest)
71 (setq i (1+ i))
72 (catch 'tag
73 (while (< i len)
74 (setq chr (aref str i))
75 (cond ((eq chr ?\\)
76 (setq i (1+ i))
77 (if (>= i len)
78 (throw 'tag nil)
79 )
80 (setq i (1+ i))
81 )
82 ((eq chr close)
83 (throw 'tag (1+ i))
84 )
85 ((eq chr open)
86 (if (and recursive
87 (setq p (std11-check-enclosure
88 str open close recursive i))
89 )
90 (setq i p)
91 (throw 'tag nil)
92 ))
93 (t
94 (setq i (1+ i))
95 ))
96 ))))))
97
98 (defun std11-analyze-quoted-string (str)
99 (let ((p (std11-check-enclosure str ?\" ?\")))
100 (if p
101 (cons (cons 'quoted-string (substring str 1 (1- p)))
102 (substring str p))
103 )))
104
105 (defun std11-analyze-domain-literal (str)
106 (let ((p (std11-check-enclosure str ?\[ ?\])))
107 (if p
108 (cons (cons 'domain-literal (substring str 1 (1- p)))
109 (substring str p))
110 )))
111
112 (defun std11-analyze-comment (str)
113 (let ((p (std11-check-enclosure str ?\( ?\) t)))
114 (if p
115 (cons (cons 'comment (substring str 1 (1- p)))
116 (substring str p))
117 )))
118
119 (defun std11-lexical-analyze (str)
120 (let (dest ret)
121 (while (not (string-equal str ""))
122 (setq ret
123 (or (std11-analyze-quoted-string str)
124 (std11-analyze-domain-literal str)
125 (std11-analyze-comment str)
126 (std11-analyze-spaces str)
127 (std11-analyze-special str)
128 (std11-analyze-atom str)
129 '((error) . "")
130 ))
131 (setq dest (cons (car ret) dest))
132 (setq str (cdr ret))
133 )
134 (nreverse dest)
135 ))
136
137
138 ;;; @ parser
139 ;;;
140
141 (defun std11-ignored-token-p (token)
142 (let ((type (car token)))
143 (or (eq type 'spaces)(eq type 'comment))
144 ))
145
146 (defun std11-parse-token (lal)
147 (let (token itl)
148 (while (and lal
149 (progn
150 (setq token (car lal))
151 (std11-ignored-token-p token)
152 ))
153 (setq lal (cdr lal))
154 (setq itl (cons token itl))
155 )
156 (cons (nreverse (cons token itl))
157 (cdr lal))
158 ))
159
160 (defun std11-parse-ascii-token (lal)
161 (let (token itl parsed token-value)
162 (while (and lal
163 (setq token (car lal))
164 (if (and (setq token-value (cdr token))
165 (find-charset-string token-value)
166 )
167 (setq token nil)
168 (std11-ignored-token-p token)
169 ))
170 (setq lal (cdr lal))
171 (setq itl (cons token itl))
172 )
173 (if (and token
174 (setq parsed (nreverse (cons token itl)))
175 )
176 (cons parsed (cdr lal))
177 )))
178
179 (defun std11-parse-token-or-comment (lal)
180 (let (token itl)
181 (while (and lal
182 (progn
183 (setq token (car lal))
184 (eq (car token) 'spaces)
185 ))
186 (setq lal (cdr lal))
187 (setq itl (cons token itl))
188 )
189 (cons (nreverse (cons token itl))
190 (cdr lal))
191 ))
192
193 (defun std11-parse-word (lal)
194 (let ((ret (std11-parse-ascii-token lal)))
195 (if ret
196 (let ((elt (car ret))
197 (rest (cdr ret))
198 )
199 (if (or (assq 'atom elt)
200 (assq 'quoted-string elt))
201 (cons (cons 'word elt) rest)
202 )))))
203
204 (defun std11-parse-word-or-comment (lal)
205 (let ((ret (std11-parse-token-or-comment lal)))
206 (if ret
207 (let ((elt (car ret))
208 (rest (cdr ret))
209 )
210 (cond ((or (assq 'atom elt)
211 (assq 'quoted-string elt))
212 (cons (cons 'word elt) rest)
213 )
214 ((assq 'comment elt)
215 (cons (cons 'comment-word elt) rest)
216 ))
217 ))))
218
219 (defun std11-parse-phrase (lal)
220 (let (ret phrase)
221 (while (setq ret (std11-parse-word-or-comment lal))
222 (setq phrase (append phrase (cdr (car ret))))
223 (setq lal (cdr ret))
224 )
225 (if phrase
226 (cons (cons 'phrase phrase) lal)
227 )))
228
229 (defun std11-parse-local-part (lal)
230 (let ((ret (std11-parse-word lal)))
231 (if ret
232 (let ((local-part (cdr (car ret))) dot)
233 (setq lal (cdr ret))
234 (while (and (setq ret (std11-parse-ascii-token lal))
235 (setq dot (car ret))
236 (string-equal (cdr (assq 'specials dot)) ".")
237 (setq ret (std11-parse-word (cdr ret)))
238 (setq local-part
239 (append local-part dot (cdr (car ret)))
240 )
241 (setq lal (cdr ret))
242 ))
243 (cons (cons 'local-part local-part) lal)
244 ))))
245
246 (defun std11-parse-sub-domain (lal)
247 (let ((ret (std11-parse-ascii-token lal)))
248 (if ret
249 (let ((sub-domain (car ret)))
250 (if (or (assq 'atom sub-domain)
251 (assq 'domain-literal sub-domain)
252 )
253 (cons (cons 'sub-domain sub-domain)
254 (cdr ret)
255 )
256 )))))
257
258 (defun std11-parse-domain (lal)
259 (let ((ret (std11-parse-sub-domain lal)))
260 (if ret
261 (let ((domain (cdr (car ret))) dot)
262 (setq lal (cdr ret))
263 (while (and (setq ret (std11-parse-ascii-token lal))
264 (setq dot (car ret))
265 (string-equal (cdr (assq 'specials dot)) ".")
266 (setq ret (std11-parse-sub-domain (cdr ret)))
267 (setq domain
268 (append domain dot (cdr (car ret)))
269 )
270 (setq lal (cdr ret))
271 ))
272 (cons (cons 'domain domain) lal)
273 ))))
274
275 (defun std11-parse-at-domain (lal)
276 (let ((ret (std11-parse-ascii-token lal)) at-sign)
277 (if (and ret
278 (setq at-sign (car ret))
279 (string-equal (cdr (assq 'specials at-sign)) "@")
280 (setq ret (std11-parse-domain (cdr ret)))
281 )
282 (cons (cons 'at-domain (append at-sign (cdr (car ret))))
283 (cdr ret))
284 )))
285
286 (defun std11-parse-addr-spec (lal)
287 (let ((ret (std11-parse-local-part lal))
288 addr)
289 (if (and ret
290 (prog1
291 (setq addr (cdr (car ret)))
292 (setq lal (cdr ret))
293 (and (setq ret (std11-parse-at-domain lal))
294 (setq addr (append addr (cdr (car ret))))
295 (setq lal (cdr ret))
296 )))
297 (cons (cons 'addr-spec addr) lal)
298 )))
299
300 (defun std11-parse-route (lal)
301 (let ((ret (std11-parse-at-domain lal))
302 route comma colon)
303 (if (and ret
304 (progn
305 (setq route (cdr (car ret)))
306 (setq lal (cdr ret))
307 (while (and (setq ret (std11-parse-ascii-token lal))
308 (setq comma (car ret))
309 (string-equal (cdr (assq 'specials comma)) ",")
310 (setq ret (std11-parse-at-domain (cdr ret)))
311 )
312 (setq route (append route comma (cdr (car ret))))
313 (setq lal (cdr ret))
314 )
315 (and (setq ret (std11-parse-ascii-token lal))
316 (setq colon (car ret))
317 (string-equal (cdr (assq 'specials colon)) ":")
318 (setq route (append route colon))
319 )
320 ))
321 (cons (cons 'route route)
322 (cdr ret)
323 )
324 )))
325
326 (defun std11-parse-route-addr (lal)
327 (let ((ret (std11-parse-ascii-token lal))
328 < route addr-spec >)
329 (if (and ret
330 (setq < (car ret))
331 (string-equal (cdr (assq 'specials <)) "<")
332 (setq lal (cdr ret))
333 (progn (and (setq ret (std11-parse-route lal))
334 (setq route (cdr (car ret)))
335 (setq lal (cdr ret))
336 )
337 (setq ret (std11-parse-addr-spec lal))
338 )
339 (setq addr-spec (cdr (car ret)))
340 (setq lal (cdr ret))
341 (setq ret (std11-parse-ascii-token lal))
342 (setq > (car ret))
343 (string-equal (cdr (assq 'specials >)) ">")
344 )
345 (cons (cons 'route-addr (append route addr-spec))
346 (cdr ret)
347 )
348 )))
349
350 (defun std11-parse-phrase-route-addr (lal)
351 (let ((ret (std11-parse-phrase lal)) phrase)
352 (if ret
353 (progn
354 (setq phrase (cdr (car ret)))
355 (setq lal (cdr ret))
356 ))
357 (if (setq ret (std11-parse-route-addr lal))
358 (cons (list 'phrase-route-addr
359 phrase
360 (cdr (car ret)))
361 (cdr ret))
362 )))
363
364 (defun std11-parse-mailbox (lal)
365 (let ((ret (or (std11-parse-phrase-route-addr lal)
366 (std11-parse-addr-spec lal)))
367 mbox comment)
368 (if (and ret
369 (prog1
370 (setq mbox (car ret))
371 (setq lal (cdr ret))
372 (if (and (setq ret (std11-parse-token-or-comment lal))
373 (setq comment (cdr (assq 'comment (car ret))))
374 )
375 (setq lal (cdr ret))
376 )))
377 (cons (list 'mailbox mbox comment)
378 lal)
379 )))
380
381 (defun std11-parse-group (lal)
382 (let ((ret (std11-parse-phrase lal))
383 phrase colon comma mbox semicolon)
384 (if (and ret
385 (setq phrase (cdr (car ret)))
386 (setq lal (cdr ret))
387 (setq ret (std11-parse-ascii-token lal))
388 (setq colon (car ret))
389 (string-equal (cdr (assq 'specials colon)) ":")
390 (setq lal (cdr ret))
391 (progn
392 (and (setq ret (std11-parse-mailbox lal))
393 (setq mbox (list (car ret)))
394 (setq lal (cdr ret))
395 (progn
396 (while (and (setq ret (std11-parse-ascii-token lal))
397 (setq comma (car ret))
398 (string-equal
399 (cdr (assq 'specials comma)) ",")
400 (setq lal (cdr ret))
401 (setq ret (std11-parse-mailbox lal))
402 (setq mbox (cons (car ret) mbox))
403 (setq lal (cdr ret))
404 )
405 )))
406 (and (setq ret (std11-parse-ascii-token lal))
407 (setq semicolon (car ret))
408 (string-equal (cdr (assq 'specials semicolon)) ";")
409 )))
410 (cons (list 'group phrase (nreverse mbox))
411 (cdr ret)
412 )
413 )))
414
415 (defun std11-parse-address (lal)
416 (or (std11-parse-group lal)
417 (std11-parse-mailbox lal)
418 ))
419
420 (defun std11-parse-addresses (lal)
421 (let ((ret (std11-parse-address lal)))
422 (if ret
423 (let ((dest (list (car ret))))
424 (setq lal (cdr ret))
425 (while (and (setq ret (std11-parse-ascii-token lal))
426 (string-equal (cdr (assq 'specials (car ret))) ",")
427 (setq ret (std11-parse-address (cdr ret)))
428 )
429 (setq dest (cons (car ret) dest))
430 (setq lal (cdr ret))
431 )
432 (nreverse dest)
433 ))))
434
435
436 ;;; @ end
437 ;;;
438
439 (provide 'std11-parse)
440
441 ;;; std11-parse.el ends here