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:
   8 ;;      $Id: std11-parse.el,v 0.15 1996-11-28 19:38:27 morioka 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