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