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