std11-parse.el

   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 0.9 1996-08-28 20:34:53 morioka 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