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