Mercurial > hg > xemacs-beta

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