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 2.0 1995-10-05 11:26:43 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 ;;; @ field
  19 ;;;
  20
  21 (defconst rfc822/field-name-regexp "[!-9;-~]+")
  22
  23 (defconst rfc822::next-field-top-regexp
  24   (concat "\n" rfc822/field-name-regexp ":"))
  25
  26 (defun rfc822/field-end ()
  27   (if (re-search-forward rfc822::next-field-top-regexp nil t)
  28       (goto-char (match-beginning 0))
  29     (if (re-search-forward "^$" nil t)
  30         (goto-char (1- (match-beginning 0)))
  31       (end-of-line)
  32       ))
  33   (point)
  34   )
  35
  36 (defun rfc822/get-field-body (name)
  37   (let ((case-fold-search t))
  38     (save-excursion
  39       (save-restriction
  40         (narrow-to-region
  41          (goto-char (point-min))
  42          (or (and (re-search-forward "^$" nil t) (match-end 0))
  43              (point-max)
  44              ))
  45         (goto-char (point-min))
  46         (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
  47             (buffer-substring-no-properties
  48              (match-end 0)
  49              (rfc822/field-end)
  50              ))
  51         ))))
  52
  53
  54 ;;; @ quoted-string
  55 ;;;
  56
  57 (defun rfc822/strip-quoted-pair (str)
  58   (let ((dest "")
  59         (i 0)
  60         (len (length str))
  61         chr flag)
  62     (while (< i len)
  63       (setq chr (elt str i))
  64       (if (or flag (not (eq chr ?\\)))
  65           (progn
  66             (setq dest (concat dest (char-to-string chr)))
  67             (setq flag nil)
  68             )
  69         (setq flag t)
  70         )
  71       (setq i (+ i 1))
  72       )
  73     dest))
  74
  75 (defun rfc822/strip-quoted-string (str)
  76   (rfc822/strip-quoted-pair
  77    (let ((max (- (length str) 1))
  78          )
  79      (if (and (eq (elt str 0) ?\")
  80               (eq (elt str max) ?\")
  81               )
  82          (substring str 1 max)
  83        str)
  84      )))
  85
  86
  87 ;;; @ unfolding
  88 ;;;
  89
  90 (defun rfc822/unfolding-string (str)
  91   (let ((dest ""))
  92     (while (string-match "\n\\s +" str)
  93       (setq dest (concat dest (substring str 0 (match-beginning 0)) " "))
  94       (setq str (substring str (match-end 0)))
  95       )
  96     (concat dest str)
  97     ))
  98
  99
 100 ;;; @ lexical analyze
 101 ;;;
 102
 103 (defconst rfc822/special-chars "][()<>@,;:\\<>.\"")
 104 (defconst rfc822/space-chars " \t\n")
 105 (defconst rfc822/non-atom-chars
 106   (concat rfc822/special-chars rfc822/space-chars))
 107 (defconst rfc822/non-qtext-chars "\"")
 108 (defconst rfc822/non-dtext-chars "[]")
 109 (defconst rfc822/non-ctext-chars "()")
 110
 111 (defun rfc822/analyze-spaces (str)
 112   (let ((i (position-mismatched
 113             (function
 114              (lambda (elt)
 115                (find elt rfc822/space-chars)
 116                )) str))
 117         )
 118     (if (> i 0)
 119         (cons (cons 'spaces (substring str 0 i))
 120               (substring str i)
 121               ))
 122     ))
 123
 124 (defun rfc822/analyze-special (str)
 125   (if (and (> (length str) 0)
 126            (find (elt str 0) rfc822/special-chars)
 127            )
 128       (cons (cons 'specials (substring str 0 1))
 129             (substring str 1)
 130             ))
 131   )
 132
 133 (defun rfc822/analyze-atom (str)
 134   (let ((i (position-mismatched
 135             (function
 136              (lambda (elt)
 137                (not (find elt rfc822/non-atom-chars))
 138                )) str))
 139         )
 140     (if (> i 0)
 141         (cons (cons 'atom (substring str 0 i))
 142               (substring str i)
 143               ))
 144     ))
 145
 146 (defun rfc822/analyze-quoted-pair (str)
 147   (if (and (>= (length str) 2)
 148            (eq (elt str 0) ?\\)
 149            )
 150       (cons (cons 'quoted-pair (substring str 0 2))
 151             (substring str 2)
 152             ))
 153   )
 154
 155 (defun rfc822/analyze-quoted-string (str)
 156   (if (and (> (length str) 0)
 157            (eq (elt str 0) ?\")
 158            )
 159       (let* ((i (position-mismatched
 160                  (function
 161                   (lambda (elt)
 162                     (not (find elt rfc822/non-qtext-chars))
 163                     ))
 164                  (setq str (substring str 1))
 165                  ))
 166              (rest (substring str i))
 167              )
 168         (if (and (> i 0)
 169                  (> (length rest) 0)
 170                  (eq (elt rest 0) ?\")
 171                  )
 172             (cons (cons 'quoted-string (substring str 0 i))
 173                   (substring rest 1)
 174                   )
 175           ))))
 176
 177 (defun rfc822/analyze-domain-literal (str)
 178   (if (and (> (length str) 0)
 179            (eq (elt str 0) ?\[)
 180            )
 181       (let* ((i (position-mismatched
 182                  (function
 183                   (lambda (elt)
 184                     (not (find elt rfc822/non-dtext-chars))
 185                     ))
 186                  (setq str (substring str 1))
 187                  ))
 188              (rest (substring str i))
 189              )
 190         (if (and (> i 0)
 191                  (> (length rest) 0)
 192                  (eq (elt rest 0) ?\])
 193                  )
 194             (cons (cons 'domain-literal (substring str 0 i))
 195                   (substring rest 1)
 196                   )
 197           ))))
 198
 199 (defun rfc822/analyze-comment (str)
 200   (if (and (> (length str) 0)
 201            (eq (elt str 0) ?\()
 202            )
 203       (let ((dest "")
 204             chr p ret)
 205         (setq str (substring str 1))
 206         (catch 'tag
 207           (while (not (string-equal str ""))
 208             (setq p (position-mismatched
 209                      (function
 210                       (lambda (elt)
 211                         (not (find elt rfc822/non-ctext-chars))
 212                         )) str))
 213             (cond ((> p 0)
 214                    (setq dest (concat dest (substring str 0 p)))
 215                    (setq str (substring str p))
 216                    )
 217                   ((setq ret (rfc822/analyze-comment str))
 218                    (setq dest (concat dest "(" (cdr (car ret)) ")"))
 219                    (setq str (cdr ret))
 220                    )
 221                   (t (throw 'tag nil))
 222                   )
 223             ))
 224         (if (and (> (length str) 0)
 225                  (eq (elt str 0) ?\))
 226                  )
 227             (cons (cons 'comment dest)
 228                   (substring str 1)
 229                   )
 230           ))))
 231
 232 (defun rfc822/lexical-analyze (str)
 233   (let (dest
 234         (i 0)(len (length str))
 235         ret)
 236     (while (not (string-equal str ""))
 237       (setq ret
 238             (or (rfc822/analyze-quoted-string str)
 239                 (rfc822/analyze-domain-literal str)
 240                 (rfc822/analyze-comment str)
 241                 (rfc822/analyze-spaces str)
 242                 (rfc822/analyze-special str)
 243                 (rfc822/analyze-atom str)
 244                 '((error) . "")
 245                 ))
 246       (setq dest (cons (car ret) dest))
 247       (setq str (cdr ret))
 248       )
 249     (reverse dest)
 250     ))
 251
 252
 253 ;;; @ parser
 254 ;;;
 255
 256 (defun rfc822/ignored-token-p (token)
 257   (let ((type (car token)))
 258     (or (eq type 'spaces)(eq type 'comment))
 259     ))
 260
 261 (defun rfc822/parse-token (lal)
 262   (let (token itl)
 263     (while (and lal
 264                 (progn
 265                   (setq token (car lal))
 266                   (rfc822/ignored-token-p token)
 267                   ))
 268       (setq lal (cdr lal))
 269       (setq itl (cons token itl))
 270       )
 271     (cons (reverse (cons token itl))
 272           (cdr lal))
 273     ))
 274
 275 (defun rfc822/parse-token-or-comment (lal)
 276   (let (token itl)
 277     (while (and lal
 278                 (progn
 279                   (setq token (car lal))
 280                   (eq (car token) 'spaces)
 281                   ))
 282       (setq lal (cdr lal))
 283       (setq itl (cons token itl))
 284       )
 285     (cons (reverse (cons token itl))
 286           (cdr lal))
 287     ))
 288
 289 (defun rfc822/parse-word (lal)
 290   (let ((ret (rfc822/parse-token lal)))
 291     (if ret
 292         (let ((elt (car ret))
 293               (rest (cdr ret))
 294               )
 295           (if (or (assq 'atom elt)
 296                   (assq 'quoted-string elt))
 297               (cons (cons 'word elt) rest)
 298             )))))
 299
 300 (defun rfc822/parse-word-or-comment (lal)
 301   (let ((ret (rfc822/parse-token-or-comment lal)))
 302     (if ret
 303         (let ((elt (car ret))
 304               (rest (cdr ret))
 305               )
 306           (cond ((or (assq 'atom elt)
 307                      (assq 'quoted-string elt))
 308                  (cons (cons 'word elt) rest)
 309                  )
 310                 ((assq 'comment elt)
 311                  (cons (cons 'comment-word elt) rest)
 312                  ))
 313           ))))
 314
 315 (defun rfc822/parse-phrase (lal)
 316   (let (ret phrase)
 317     (while (setq ret (rfc822/parse-word-or-comment lal))
 318       (setq phrase (append phrase (cdr (car ret))))
 319       (setq lal (cdr ret))
 320       )
 321     (if phrase
 322         (cons (cons 'phrase phrase) lal)
 323       )))
 324
 325 (defun rfc822/parse-local-part (lal)
 326   (let ((ret (rfc822/parse-word lal)))
 327     (if ret
 328         (let ((local-part (cdr (car ret))) dot)
 329           (setq lal (cdr ret))
 330           (while (and (setq ret (rfc822/parse-token lal))
 331                       (setq dot (car ret))
 332                       (equal (cdr (assq 'specials dot)) ".")
 333                       (setq ret (rfc822/parse-word (cdr ret)))
 334                       (setq local-part
 335                             (append local-part dot (cdr (car ret)))
 336                             )
 337                       (setq lal (cdr ret))
 338                       ))
 339           (cons (cons 'local-part local-part) lal)
 340           ))))
 341
 342 (defun rfc822/parse-sub-domain (lal)
 343   (let ((ret (rfc822/parse-token lal)))
 344     (if ret
 345         (let ((sub-domain (car ret)))
 346           (if (or (assq 'atom sub-domain)
 347                   (assq 'domain-literal sub-domain)
 348                   )
 349               (cons (cons 'sub-domain sub-domain)
 350                     (cdr ret)
 351                     )
 352             )))))
 353
 354 (defun rfc822/parse-domain (lal)
 355   (let ((ret (rfc822/parse-sub-domain lal)))
 356     (if ret
 357         (let ((domain (cdr (car ret))) dot)
 358           (setq lal (cdr ret))
 359           (while (and (setq ret (rfc822/parse-token lal))
 360                       (setq dot (car ret))
 361                       (equal (cdr (assq 'specials dot)) ".")
 362                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 363                       (setq domain
 364                             (append domain dot (cdr (car ret)))
 365                             )
 366                       (setq lal (cdr ret))
 367                       ))
 368           (cons (cons 'domain domain) lal)
 369           ))))
 370
 371 (defun rfc822/parse-at-domain (lal)
 372   (let ((ret (rfc822/parse-token lal)) at-sign)
 373     (if (and ret
 374              (setq at-sign (car ret))
 375              (equal (cdr (assq 'specials at-sign)) "@")
 376              (setq ret (rfc822/parse-domain (cdr ret)))
 377              )
 378         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 379               (cdr ret))
 380       )))
 381
 382 (defun rfc822/parse-addr-spec (lal)
 383   (let ((ret (rfc822/parse-local-part lal))
 384         addr at-sign)
 385     (if (and ret
 386              (prog1
 387                  (setq addr (cdr (car ret)))
 388                (setq lal (cdr ret))
 389                (and (setq ret (rfc822/parse-at-domain lal))
 390                     (setq addr (append addr (cdr (car ret))))
 391                     (setq lal (cdr ret))
 392                     )))
 393         (cons (cons 'addr-spec addr) lal)
 394       )))
 395
 396 (defun rfc822/parse-route (lal)
 397   (let ((ret (rfc822/parse-at-domain lal))
 398         route comma colon)
 399     (if (and ret
 400              (progn
 401                (setq route (cdr (car ret)))
 402                (setq lal (cdr ret))
 403                (while (and (setq ret (rfc822/parse-token lal))
 404                            (setq comma (car ret))
 405                            (equal (cdr (assq 'specials comma)) ",")
 406                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 407                            )
 408                  (setq route (append route comma (cdr (car ret))))
 409                  (setq lal (cdr ret))
 410                  )
 411                (and (setq ret (rfc822/parse-token lal))
 412                     (setq colon (car ret))
 413                     (equal (cdr (assq 'specials colon)) ":")
 414                     (setq route (append route colon))
 415                     )
 416                ))
 417         (cons (cons 'route route)
 418               (cdr ret)
 419               )
 420       )))
 421
 422 (defun rfc822/parse-route-addr (lal)
 423   (let ((ret (rfc822/parse-token lal))
 424         < route addr-spec >)
 425     (if (and ret
 426              (setq < (car ret))
 427              (equal (cdr (assq 'specials <)) "<")
 428              (setq lal (cdr ret))
 429              (progn (and (setq ret (rfc822/parse-route lal))
 430                          (setq route (cdr (car ret)))
 431                          (setq lal (cdr ret))
 432                          )
 433                     (setq ret (rfc822/parse-addr-spec lal))
 434                     )
 435              (setq addr-spec (cdr (car ret)))
 436              (setq lal (cdr ret))
 437              (setq ret (rfc822/parse-token lal))
 438              (setq > (car ret))
 439              (equal (cdr (assq 'specials >)) ">")
 440              )
 441         (cons (cons 'route-addr (append route addr-spec))
 442               (cdr ret)
 443               )
 444       )))
 445
 446 (defun rfc822/parse-phrase-route-addr (lal)
 447   (let ((ret (rfc822/parse-phrase lal)) phrase)
 448     (if ret
 449         (progn
 450           (setq phrase (cdr (car ret)))
 451           (setq lal (cdr ret))
 452           ))
 453     (if (setq ret (rfc822/parse-route-addr lal))
 454         (cons (list 'phrase-route-addr
 455                     phrase
 456                     (cdr (car ret)))
 457               (cdr ret))
 458       )))
 459
 460 (defun rfc822/parse-mailbox (lal)
 461   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 462                  (rfc822/parse-addr-spec lal)))
 463         mbox comment)
 464     (if (and ret
 465              (prog1
 466                  (setq mbox (car ret))
 467                (setq lal (cdr ret))
 468                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 469                         (setq comment (cdr (assq 'comment (car ret))))
 470                         )
 471                    (setq lal (cdr ret))
 472                  )))
 473         (cons (list 'mailbox mbox comment)
 474               lal)
 475       )))
 476
 477 (defun rfc822/parse-group (lal)
 478   (let ((ret (rfc822/parse-phrase lal))
 479         phrase : comma mbox semicolon)
 480     (if (and ret
 481              (setq phrase (cdr (car ret)))
 482              (setq lal (cdr ret))
 483              (setq ret (rfc822/parse-token lal))
 484              (setq : (car ret))
 485              (equal (cdr (assq 'specials :)) ":")
 486              (setq lal (cdr ret))
 487              (progn
 488                (and (setq ret (rfc822/parse-mailbox lal))
 489                     (setq mbox (list (car ret)))
 490                     (setq lal (cdr ret))
 491                     (progn
 492                       (while (and (setq ret (rfc822/parse-token lal))
 493                                   (setq comma (car ret))
 494                                   (equal (cdr (assq 'specials comma)) ",")
 495                                   (setq lal (cdr ret))
 496                                   (setq ret (rfc822/parse-mailbox lal))
 497                                   (setq mbox (cons (car ret) mbox))
 498                                   (setq lal (cdr ret))
 499                                   )
 500                         )))
 501                (and (setq ret (rfc822/parse-token lal))
 502                     (setq semicolon (car ret))
 503                     (equal (cdr (assq 'specials semicolon)) ";")
 504                     )))
 505         (cons (list 'group phrase (reverse mbox))
 506               (cdr ret)
 507               )
 508       )))
 509
 510 (defun rfc822/parse-address (lal)
 511   (or (rfc822/parse-group lal)
 512       (rfc822/parse-mailbox lal)
 513       ))
 514
 515 (defun rfc822/parse-addresses (lal)
 516   (let ((ret (rfc822/parse-address lal)))
 517     (if ret
 518         (let ((dest (list (car ret))))
 519           (setq lal (cdr ret))
 520           (while (and (setq ret (rfc822/parse-token lal))
 521                       (equal (cdr (assq 'specials (car ret))) ",")
 522                       (setq ret (rfc822/parse-address (cdr ret)))
 523                       )
 524             (setq dest (cons (car ret) dest))
 525             (setq lal (cdr ret))
 526             )
 527           (reverse dest)
 528           ))))
 529
 530 (defun rfc822/addr-to-string (seq)
 531   (mapconcat (function
 532               (lambda (token)
 533                 (if (eq (car token) 'spaces)
 534                     ""
 535                   (cdr token)
 536                   )))
 537              seq "")
 538   )
 539
 540 (defun rfc822/address-string (address)
 541   (if (eq (car address) 'mailbox)
 542       (let ((addr (nth 1 address))
 543             addr-spec)
 544         (rfc822/addr-to-string
 545          (if (eq (car addr) 'phrase-route-addr)
 546              (nth 2 addr)
 547            (cdr addr)
 548            )
 549          ))))
 550
 551 (defun rfc822/full-name-string (address)
 552   (if (eq (car address) 'mailbox)
 553       (let ((addr (nth 1 address))
 554             (comment (nth 2 address))
 555             phrase)
 556         (if (eq (car addr) 'phrase-route-addr)
 557             (setq phrase (mapconcat (function
 558                                      (lambda (token)
 559                                        (cdr token)
 560                                        ))
 561                                     (nth 1 addr) ""))
 562           )
 563         (or phrase comment)
 564         )))
 565
 566
 567 ;;; @ end
 568 ;;;
 569
 570 (provide 'tl-822)