tl-822.el

   1 ;;;
   2 ;;; tl-822.el --- RFC 822 parser for GNU Emacs
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version:
   9 ;;;     $Id: tl-822.el,v 1.1 1995-10-03 05:17:31 morioka Exp $
  10 ;;; Keywords: mail, news, RFC 822
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14
  15 (require 'tl-seq)
  16
  17
  18 ;;; @ lexical analyze
  19 ;;;
  20
  21 (defconst rfc822/special-chars "][()<>@,;:\\<>.\"")
  22 (defconst rfc822/space-chars " \t\n")
  23 (defconst rfc822/non-atom-chars
  24   (concat rfc822/special-chars rfc822/space-chars))
  25 (defconst rfc822/non-qtext-chars "\"")
  26 (defconst rfc822/non-dtext-chars "[]")
  27 (defconst rfc822/non-ctext-chars "()")
  28
  29 (defun rfc822/analyze-spaces (str)
  30   (let ((i (position-mismatched
  31             (function
  32              (lambda (elt)
  33                (find elt rfc822/space-chars)
  34                )) str))
  35         )
  36     (if (> i 0)
  37         (cons (cons 'spaces (substring str 0 i))
  38               (substring str i)
  39               ))
  40     ))
  41
  42 (defun rfc822/analyze-special (str)
  43   (if (and (> (length str) 0)
  44            (find (elt str 0) rfc822/special-chars)
  45            )
  46       (cons (cons 'specials (substring str 0 1))
  47             (substring str 1)
  48             ))
  49   )
  50
  51 (defun rfc822/analyze-atom (str)
  52   (let ((i (position-mismatched
  53             (function
  54              (lambda (elt)
  55                (not (find elt rfc822/non-atom-chars))
  56                )) str))
  57         )
  58     (if (> i 0)
  59         (cons (cons 'atom (substring str 0 i))
  60               (substring str i)
  61               ))
  62     ))
  63
  64 (defun rfc822/analyze-quoted-pair (str)
  65   (if (and (>= (length str) 2)
  66            (eq (elt str 0) ?\\)
  67            )
  68       (cons (cons 'quoted-pair (substring str 0 2))
  69             (substring str 2)
  70             ))
  71   )
  72
  73 (defun rfc822/analyze-quoted-string (str)
  74   (if (and (> (length str) 0)
  75            (eq (elt str 0) ?\")
  76            )
  77       (let* ((i (position-mismatched
  78                  (function
  79                   (lambda (elt)
  80                     (not (find elt rfc822/non-qtext-chars))
  81                     ))
  82                  (setq str (substring str 1))
  83                  ))
  84              (rest (substring str i))
  85              )
  86         (if (and (> i 0)
  87                  (> (length rest) 0)
  88                  (eq (elt rest 0) ?\")
  89                  )
  90             (cons (cons 'quoted-string (substring str 0 i))
  91                   (substring rest 1)
  92                   )
  93           ))))
  94
  95 (defun rfc822/analyze-domain-literal (str)
  96   (if (and (> (length str) 0)
  97            (eq (elt str 0) ?\[)
  98            )
  99       (let* ((i (position-mismatched
 100                  (function
 101                   (lambda (elt)
 102                     (not (find elt rfc822/non-dtext-chars))
 103                     ))
 104                  (setq str (substring str 1))
 105                  ))
 106              (rest (substring str i))
 107              )
 108         (if (and (> i 0)
 109                  (> (length rest) 0)
 110                  (eq (elt rest 0) ?\])
 111                  )
 112             (cons (cons 'domain-literal (substring str 0 i))
 113                   (substring rest 1)
 114                   )
 115           ))))
 116
 117 (defun rfc822/analyze-comment (str)
 118   (if (and (> (length str) 0)
 119            (eq (elt str 0) ?\()
 120            )
 121       (let ((dest "")
 122             chr p ret)
 123         (setq str (substring str 1))
 124         (catch 'tag
 125           (while (not (string-equal str ""))
 126             (setq p (position-mismatched
 127                      (function
 128                       (lambda (elt)
 129                         (not (find elt rfc822/non-ctext-chars))
 130                         )) str))
 131             (cond ((> p 0)
 132                    (setq dest (concat dest (substring str 0 p)))
 133                    (setq str (substring str p))
 134                    )
 135                   ((setq ret (rfc822/analyze-comment str))
 136                    (setq dest (concat dest "(" (cdr (car ret)) ")"))
 137                    (setq str (cdr ret))
 138                    )
 139                   (t (throw 'tag nil))
 140                   )
 141             ))
 142         (if (and (> (length str) 0)
 143                  (eq (elt str 0) ?\))
 144                  )
 145             (cons (cons 'comment dest)
 146                   (substring str 1)
 147                   )
 148           ))))
 149
 150 (defun rfc822/lexical-analyze (str)
 151   (let (dest
 152         (i 0)(len (length str))
 153         ret)
 154     (while (not (string-equal str ""))
 155       (setq ret
 156             (or (rfc822/analyze-quoted-string str)
 157                 (rfc822/analyze-domain-literal str)
 158                 (rfc822/analyze-comment str)
 159                 (rfc822/analyze-spaces str)
 160                 (rfc822/analyze-special str)
 161                 (rfc822/analyze-atom str)
 162                 '((error) . "")
 163                 ))
 164       (setq dest (cons (car ret) dest))
 165       (setq str (cdr ret))
 166       )
 167     (reverse dest)
 168     ))
 169
 170
 171 ;;; @ parser
 172 ;;;
 173
 174 (defun rfc822/ignored-token-p (token)
 175   (let ((type (car token)))
 176     (or (eq type 'spaces)(eq type 'comment))
 177     ))
 178
 179 (defun rfc822/parse-token (lal)
 180   (let (token itl)
 181     (while (and lal
 182                 (progn
 183                   (setq token (car lal))
 184                   (rfc822/ignored-token-p token)
 185                   ))
 186       (setq lal (cdr lal))
 187       (setq itl (cons token itl))
 188       )
 189     (cons (reverse (cons token itl))
 190           (cdr lal))
 191     ))
 192
 193 (defun rfc822/parse-token-or-comment (lal)
 194   (let (token itl)
 195     (while (and lal
 196                 (progn
 197                   (setq token (car lal))
 198                   (eq (car token) 'spaces)
 199                   ))
 200       (setq lal (cdr lal))
 201       (setq itl (cons token itl))
 202       )
 203     (cons (reverse (cons token itl))
 204           (cdr lal))
 205     ))
 206
 207 (defun rfc822/parse-word (lal)
 208   (let ((ret (rfc822/parse-token lal)))
 209     (if ret
 210         (let ((elt (car ret))
 211               (rest (cdr ret))
 212               )
 213           (if (or (assq 'atom elt)
 214                   (assq 'quoted-string elt))
 215               (cons (cons 'word elt) rest)
 216             )))))
 217
 218 (defun rfc822/parse-word-or-comment (lal)
 219   (let ((ret (rfc822/parse-token-or-comment lal)))
 220     (if ret
 221         (let ((elt (car ret))
 222               (rest (cdr ret))
 223               )
 224           (cond ((or (assq 'atom elt)
 225                      (assq 'quoted-string elt))
 226                  (cons (cons 'word elt) rest)
 227                  )
 228                 ((assq 'comment elt)
 229                  (cons (cons 'comment-word elt) rest)
 230                  ))
 231           ))))
 232
 233 (defun rfc822/parse-phrase (lal)
 234   (let (ret phrase)
 235     (while (setq ret (rfc822/parse-word-or-comment lal))
 236       (setq phrase (append phrase (cdr (car ret))))
 237       (setq lal (cdr ret))
 238       )
 239     (if phrase
 240         (cons (cons 'phrase phrase) lal)
 241       )))
 242
 243 (defun rfc822/parse-local-part (lal)
 244   (let ((ret (rfc822/parse-word lal)))
 245     (if ret
 246         (let ((local-part (cdr (car ret))) dot)
 247           (setq lal (cdr ret))
 248           (while (and (setq ret (rfc822/parse-token lal))
 249                       (setq dot (car ret))
 250                       (equal (cdr (assq 'specials dot)) ".")
 251                       (setq ret (rfc822/parse-word (cdr ret)))
 252                       (setq local-part
 253                             (append local-part dot (cdr (car ret)))
 254                             )
 255                       (setq lal (cdr ret))
 256                       ))
 257           (cons (cons 'local-part local-part) lal)
 258           ))))
 259
 260 (defun rfc822/parse-sub-domain (lal)
 261   (let ((ret (rfc822/parse-token lal)))
 262     (if ret
 263         (let ((sub-domain (car ret)))
 264           (if (or (assq 'atom sub-domain)
 265                   (assq 'domain-literal sub-domain)
 266                   )
 267               (cons (cons 'sub-domain sub-domain)
 268                     (cdr ret)
 269                     )
 270             )))))
 271
 272 (defun rfc822/parse-domain (lal)
 273   (let ((ret (rfc822/parse-sub-domain lal)))
 274     (if ret
 275         (let ((domain (cdr (car ret))) dot)
 276           (setq lal (cdr ret))
 277           (while (and (setq ret (rfc822/parse-token lal))
 278                       (setq dot (car ret))
 279                       (equal (cdr (assq 'specials dot)) ".")
 280                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 281                       (setq domain
 282                             (append domain dot (cdr (car ret)))
 283                             )
 284                       (setq lal (cdr ret))
 285                       ))
 286           (cons (cons 'domain domain) lal)
 287           ))))
 288
 289 (defun rfc822/parse-at-domain (lal)
 290   (let ((ret (rfc822/parse-token lal)) at-sign)
 291     (if (and ret
 292              (setq at-sign (car ret))
 293              (equal (cdr (assq 'specials at-sign)) "@")
 294              (setq ret (rfc822/parse-domain (cdr ret)))
 295              )
 296         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 297               (cdr ret))
 298       )))
 299
 300 (defun rfc822/parse-addr-spec (lal)
 301   (let ((ret (rfc822/parse-local-part lal))
 302         addr at-sign)
 303     (if (and ret
 304              (prog1
 305                  (setq addr (cdr (car ret)))
 306                (setq lal (cdr ret))
 307                (and (setq ret (rfc822/parse-at-domain lal))
 308                     (setq addr (append addr (cdr (car ret))))
 309                     (setq lal (cdr ret))
 310                     )))
 311         (cons (cons 'addr-spec addr) lal)
 312       )))
 313
 314 (defun rfc822/parse-route (lal)
 315   (let ((ret (rfc822/parse-at-domain lal))
 316         route comma colon)
 317     (if (and ret
 318              (progn
 319                (setq route (cdr (car ret)))
 320                (setq lal (cdr ret))
 321                (while (and (setq ret (rfc822/parse-token lal))
 322                            (setq comma (car ret))
 323                            (equal (cdr (assq 'specials comma)) ",")
 324                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 325                            )
 326                  (setq route (append route comma (cdr (car ret))))
 327                  (setq lal (cdr ret))
 328                  )
 329                (and (setq ret (rfc822/parse-token lal))
 330                     (setq colon (car ret))
 331                     (equal (cdr (assq 'specials colon)) ":")
 332                     (setq route (append route colon))
 333                     )
 334                ))
 335         (cons (cons 'route route)
 336               (cdr ret)
 337               )
 338       )))
 339
 340 (defun rfc822/parse-route-addr (lal)
 341   (let ((ret (rfc822/parse-token lal))
 342         < route addr-spec >)
 343     (if (and ret
 344              (setq < (car ret))
 345              (equal (cdr (assq 'specials <)) "<")
 346              (setq lal (cdr ret))
 347              (progn (and (setq ret (rfc822/parse-route lal))
 348                          (setq route (cdr (car ret)))
 349                          (setq lal (cdr ret))
 350                          )
 351                     (setq ret (rfc822/parse-addr-spec lal))
 352                     )
 353              (setq addr-spec (cdr (car ret)))
 354              (setq lal (cdr ret))
 355              (setq ret (rfc822/parse-token lal))
 356              (setq > (car ret))
 357              (equal (cdr (assq 'specials >)) ">")
 358              )
 359         (cons (cons 'route-addr (append route addr-spec))
 360               (cdr ret)
 361               )
 362       )))
 363
 364 (defun rfc822/parse-phrase-route-addr (lal)
 365   (let ((ret (rfc822/parse-phrase lal)) phrase)
 366     (if ret
 367         (progn
 368           (setq phrase (cdr (car ret)))
 369           (setq lal (cdr ret))
 370           ))
 371     (if (setq ret (rfc822/parse-route-addr lal))
 372         (cons (list 'phrase-route-addr
 373                     phrase
 374                     (cdr (car ret)))
 375               (cdr ret))
 376       )))
 377
 378 (defun rfc822/parse-mailbox (lal)
 379   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 380                  (rfc822/parse-addr-spec lal)))
 381         mbox comment)
 382     (if (and ret
 383              (prog1
 384                  (setq mbox (car ret))
 385                (setq lal (cdr ret))
 386                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 387                         (setq comment (cdr (assq 'comment (car ret))))
 388                         )
 389                    (setq lal (cdr ret))
 390                  )))
 391         (cons (list 'mailbox mbox comment)
 392               lal)
 393       )))
 394
 395 (defun rfc822/parse-group (lal)
 396   (let ((ret (rfc822/parse-phrase lal))
 397         phrase : comma mbox semicolon)
 398     (if (and ret
 399              (setq phrase (cdr (car ret)))
 400              (setq lal (cdr ret))
 401              (setq ret (rfc822/parse-token lal))
 402              (setq : (car ret))
 403              (equal (cdr (assq 'specials :)) ":")
 404              (setq lal (cdr ret))
 405              (progn
 406                (and (setq ret (rfc822/parse-mailbox lal))
 407                     (setq mbox (list (car ret)))
 408                     (setq lal (cdr ret))
 409                     (progn
 410                       (while (and (setq ret (rfc822/parse-token lal))
 411                                   (setq comma (car ret))
 412                                   (equal (cdr (assq 'specials comma)) ",")
 413                                   (setq lal (cdr ret))
 414                                   (setq ret (rfc822/parse-mailbox lal))
 415                                   (setq mbox (cons (car ret) mbox))
 416                                   (setq lal (cdr ret))
 417                                   )
 418                         )))
 419                (and (setq ret (rfc822/parse-token lal))
 420                     (setq semicolon (car ret))
 421                     (equal (cdr (assq 'specials semicolon)) ";")
 422                     )))
 423         (cons (list 'group phrase (reverse mbox))
 424               (cdr ret)
 425               )
 426       )))
 427
 428 (defun rfc822/parse-address (lal)
 429   (or (rfc822/parse-group lal)
 430       (rfc822/parse-mailbox lal)
 431       ))
 432
 433 (defun rfc822/parse-addresses (lal)
 434   (let ((ret (rfc822/parse-address lal)))
 435     (if ret
 436         (let ((dest (list (car ret))))
 437           (setq lal (cdr ret))
 438           (while (and (setq ret (rfc822/parse-token lal))
 439                       (equal (cdr (assq 'specials (car ret))) ",")
 440                       (setq ret (rfc822/parse-address (cdr ret)))
 441                       )
 442             (setq dest (cons (car ret) dest))
 443             (setq lal (cdr ret))
 444             )
 445           (reverse dest)
 446           ))))
 447
 448 (defun rfc822/addr-to-string (seq)
 449   (mapconcat (function
 450               (lambda (token)
 451                 (if (eq (car token) 'spaces)
 452                     ""
 453                   (cdr token)
 454                   )))
 455              seq "")
 456   )
 457
 458 (defun rfc822/address-string (address)
 459   (if (eq (car address) 'mailbox)
 460       (let ((addr (nth 1 address))
 461             addr-spec)
 462         (rfc822/addr-to-string
 463          (if (eq (car addr) 'phrase-route-addr)
 464              (nth 2 addr)
 465            (cdr addr)
 466            )
 467          ))))
 468
 469 (defun rfc822/full-name-string (address)
 470   (if (eq (car address) 'mailbox)
 471       (let ((addr (nth 1 address))
 472             (comment (nth 2 address))
 473             phrase)
 474         (if (eq (car addr) 'phrase-route-addr)
 475             (setq phrase (mapconcat (function
 476                                      (lambda (token)
 477                                        (cdr token)
 478                                        ))
 479                                     (nth 1 addr) ""))
 480           )
 481         (or phrase comment)
 482         )))
 483
 484
 485 ;;; @ end
 486 ;;;
 487
 488 (provide 'tl-822)