tl-822.el

   1 ;;; tl-822.el --- RFC 822 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
   7
   8 ;; This file is part of tl (Tiny Library).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with This program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'tl-seq)
  28 (require 'tl-str)
  29 (require 'std11)
  30
  31
  32 (defconst rfc822/RCS-ID
  33   "$Id: tl-822.el,v 7.40 1996-08-28 13:05:04 morioka Exp $")
  34 (defconst rfc822/version (get-version-string rfc822/RCS-ID))
  35
  36
  37 ;;; @ header
  38 ;;;
  39
  40 (defalias 'rfc822/narrow-to-header 'std11-narrow-to-header)
  41 (defalias 'rfc822/get-header-string 'std11-header-string)
  42 (defalias 'rfc822/get-header-string-except 'std11-header-string-except)
  43 (defalias 'rfc822/get-field-names 'std11-field-names)
  44
  45
  46 ;;; @ field
  47 ;;;
  48
  49 (defconst rfc822/field-name-regexp "[!-9;-~]+")
  50
  51 (defalias `rfc822/field-end             'std11-field-end)
  52 (defalias 'rfc822/get-field-body        'std11-field-body)
  53
  54 (defun rfc822/get-field-bodies (field-names &optional default-value boundary)
  55   (let ((case-fold-search t))
  56     (save-excursion
  57       (save-restriction
  58         (rfc822/narrow-to-header boundary)
  59         (let* ((dest (make-list (length field-names) default-value))
  60                (s-rest field-names)
  61                (d-rest dest)
  62                field-name)
  63           (while (setq field-name (car s-rest))
  64             (goto-char (point-min))
  65             (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  66                 (setcar d-rest
  67                         (buffer-substring-no-properties
  68                          (match-end 0)
  69                          (rfc822/field-end))))
  70             (setq s-rest (cdr s-rest)
  71                   d-rest (cdr d-rest))
  72             )
  73           dest)))))
  74
  75
  76 ;;; @ quoting
  77 ;;;
  78
  79 (defconst rfc822/linear-white-space-regexp "\\(\n?[ \t]\\)+")
  80 (defconst rfc822/quoted-pair-regexp "\\\\.")
  81 (defconst rfc822/non-qtext-char-list '(?\" ?\\ ?\r ?\n))
  82 (defconst rfc822/qtext-regexp
  83   (concat "[^" (char-list-to-string rfc822/non-qtext-char-list) "]"))
  84 (defconst rfc822/quoted-string-regexp
  85   (concat "\""
  86           (regexp-*
  87            (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
  88            )
  89           "\""))
  90
  91 (defun rfc822/wrap-as-quoted-string (str)
  92   "Wrap string STR as RFC 822 quoted-string. [tl-822.el]"
  93   (concat "\""
  94           (mapconcat (function
  95                       (lambda (chr)
  96                         (if (memq chr rfc822/non-qtext-char-list)
  97                             (concat "\\" (char-to-string chr))
  98                           (char-to-string chr)
  99                           )
 100                         )) str "")
 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-dtext-chars "][")
 154 (defconst rfc822/non-ctext-chars "()")
 155
 156 (defun rfc822/analyze-spaces (str)
 157   (let ((i (string-match (concat "[^" rfc822/space-chars "]") str)))
 158     (if i
 159         (if (> i 0)
 160             (cons (cons 'spaces (substring str 0 i))
 161                   (substring str i)
 162                   ))
 163       (if (not (string-equal str ""))
 164           (cons (cons 'spaces str) "")
 165         ))))
 166
 167 (defun rfc822/analyze-special (str)
 168   (if (and (> (length str) 0)
 169            (find (elt str 0) rfc822/special-chars)
 170            )
 171       (cons (cons 'specials (substring str 0 1))
 172             (substring str 1)
 173             ))
 174   )
 175
 176 (defun rfc822/analyze-atom (str)
 177   (let ((i (string-match (concat "[" rfc822/non-atom-chars "]") str)))
 178     (if i
 179         (if (> i 0)
 180             (cons (cons 'atom (substring str 0 i))
 181                   (substring str i)
 182                   ))
 183       (if (not (string-equal str ""))
 184           (cons (cons 'spaces str) "")
 185         ))))
 186
 187 (defun rfc822/analyze-quoted-string (str)
 188   (let ((len (length str)))
 189     (if (and (> len 0)
 190              (eq (elt str 0) ?\")
 191              )
 192         (let ((i 1) chr dest)
 193           (catch 'tag
 194             (while (< i len)
 195               (setq chr (aref str i))
 196               (cond ((eq chr ?\\)
 197                      (setq i (1+ i))
 198                      (if (>= i len)
 199                          (throw 'tag nil)
 200                        )
 201                      (setq dest (concat dest (char-to-string (aref str i))))
 202                      )
 203                     ((eq chr ?\")
 204                      (throw 'tag
 205                             (cons (cons 'quoted-string dest)
 206                                   (substring str (1+ i)))
 207                             )
 208                      )
 209                     (t
 210                      (setq dest (concat dest (char-to-string (aref str i))))
 211                      ))
 212               (setq i (1+ i))
 213               ))))))
 214
 215 (defun rfc822/analyze-domain-literal (str)
 216   (if (and (> (length str) 0)
 217            (eq (aref str 0) ?\[)
 218            )
 219       (let* ((i (string-match (concat "[" rfc822/non-dtext-chars "]") str 1))
 220              (rest (and i (substring str i)))
 221              )
 222         (if (and i
 223                  (> (length rest) 0)
 224                  (eq (aref rest 0) ?\])
 225                  )
 226             (cons (cons 'domain-literal (substring str 1 i))
 227                   (substring rest 1)
 228                   )
 229           ))))
 230
 231 (defun rfc822/analyze-comment (str)
 232   (if (and (> (length str) 0)
 233            (eq (elt str 0) ?\()
 234            )
 235       (let ((dest "")
 236             p ret)
 237         (setq str (substring str 1))
 238         (catch 'tag
 239           (while (not (string-equal str ""))
 240             (setq p (string-match (concat "[" rfc822/non-ctext-chars "]") str))
 241             (cond ((> p 0)
 242                    (setq dest (concat dest (substring str 0 p)))
 243                    (setq str (substring str p))
 244                    )
 245                   ((setq ret (rfc822/analyze-comment str))
 246                    (setq dest (concat dest "(" (cdr (car ret)) ")"))
 247                    (setq str (cdr ret))
 248                    )
 249                   (t (throw 'tag nil))
 250                   )
 251             ))
 252         (if (and (> (length str) 0)
 253                  (eq (elt str 0) ?\))
 254                  )
 255             (cons (cons 'comment dest)
 256                   (substring str 1)
 257                   )
 258           ))))
 259
 260 (defun rfc822/lexical-analyze (str)
 261   (let (dest ret)
 262     (while (not (string-equal str ""))
 263       (setq ret
 264             (or (rfc822/analyze-quoted-string str)
 265                 (rfc822/analyze-domain-literal str)
 266                 (rfc822/analyze-comment str)
 267                 (rfc822/analyze-spaces str)
 268                 (rfc822/analyze-special str)
 269                 (rfc822/analyze-atom str)
 270                 '((error) . "")
 271                 ))
 272       (setq dest (cons (car ret) dest))
 273       (setq str (cdr ret))
 274       )
 275     (nreverse dest)
 276     ))
 277
 278
 279 ;;; @ parser
 280 ;;;
 281
 282 (defun rfc822/ignored-token-p (token)
 283   (let ((type (car token)))
 284     (or (eq type 'spaces)(eq type 'comment))
 285     ))
 286
 287 (defun rfc822/parse-token (lal)
 288   (let (token itl)
 289     (while (and lal
 290                 (progn
 291                   (setq token (car lal))
 292                   (rfc822/ignored-token-p token)
 293                   ))
 294       (setq lal (cdr lal))
 295       (setq itl (cons token itl))
 296       )
 297     (cons (nreverse (cons token itl))
 298           (cdr lal))
 299     ))
 300
 301 (defun rfc822/parse-ascii-token (lal)
 302   (let (token itl parsed token-value)
 303     (while (and lal
 304                 (setq token (car lal))
 305                 (if (and (setq token-value (cdr token))
 306                          (find-charset-string token-value)
 307                          )
 308                     (setq token nil)
 309                   (rfc822/ignored-token-p token)
 310                   ))
 311       (setq lal (cdr lal))
 312       (setq itl (cons token itl))
 313       )
 314     (if (and token
 315              (setq parsed (nreverse (cons token itl)))
 316              )
 317         (cons parsed (cdr lal))
 318       )))
 319
 320 (defun rfc822/parse-token-or-comment (lal)
 321   (let (token itl)
 322     (while (and lal
 323                 (progn
 324                   (setq token (car lal))
 325                   (eq (car token) 'spaces)
 326                   ))
 327       (setq lal (cdr lal))
 328       (setq itl (cons token itl))
 329       )
 330     (cons (nreverse (cons token itl))
 331           (cdr lal))
 332     ))
 333
 334 (defun rfc822/parse-word (lal)
 335   (let ((ret (rfc822/parse-ascii-token lal)))
 336     (if ret
 337         (let ((elt (car ret))
 338               (rest (cdr ret))
 339               )
 340           (if (or (assq 'atom elt)
 341                   (assq 'quoted-string elt))
 342               (cons (cons 'word elt) rest)
 343             )))))
 344
 345 (defun rfc822/parse-word-or-comment (lal)
 346   (let ((ret (rfc822/parse-token-or-comment lal)))
 347     (if ret
 348         (let ((elt (car ret))
 349               (rest (cdr ret))
 350               )
 351           (cond ((or (assq 'atom elt)
 352                      (assq 'quoted-string elt))
 353                  (cons (cons 'word elt) rest)
 354                  )
 355                 ((assq 'comment elt)
 356                  (cons (cons 'comment-word elt) rest)
 357                  ))
 358           ))))
 359
 360 (defun rfc822/parse-phrase (lal)
 361   (let (ret phrase)
 362     (while (setq ret (rfc822/parse-word-or-comment lal))
 363       (setq phrase (append phrase (cdr (car ret))))
 364       (setq lal (cdr ret))
 365       )
 366     (if phrase
 367         (cons (cons 'phrase phrase) lal)
 368       )))
 369
 370 (defun rfc822/parse-local-part (lal)
 371   (let ((ret (rfc822/parse-word lal)))
 372     (if ret
 373         (let ((local-part (cdr (car ret))) dot)
 374           (setq lal (cdr ret))
 375           (while (and (setq ret (rfc822/parse-ascii-token lal))
 376                       (setq dot (car ret))
 377                       (string-equal (cdr (assq 'specials dot)) ".")
 378                       (setq ret (rfc822/parse-word (cdr ret)))
 379                       (setq local-part
 380                             (append local-part dot (cdr (car ret)))
 381                             )
 382                       (setq lal (cdr ret))
 383                       ))
 384           (cons (cons 'local-part local-part) lal)
 385           ))))
 386
 387 (defun rfc822/parse-sub-domain (lal)
 388   (let ((ret (rfc822/parse-ascii-token lal)))
 389     (if ret
 390         (let ((sub-domain (car ret)))
 391           (if (or (assq 'atom sub-domain)
 392                   (assq 'domain-literal sub-domain)
 393                   )
 394               (cons (cons 'sub-domain sub-domain)
 395                     (cdr ret)
 396                     )
 397             )))))
 398
 399 (defun rfc822/parse-domain (lal)
 400   (let ((ret (rfc822/parse-sub-domain lal)))
 401     (if ret
 402         (let ((domain (cdr (car ret))) dot)
 403           (setq lal (cdr ret))
 404           (while (and (setq ret (rfc822/parse-ascii-token lal))
 405                       (setq dot (car ret))
 406                       (string-equal (cdr (assq 'specials dot)) ".")
 407                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 408                       (setq domain
 409                             (append domain dot (cdr (car ret)))
 410                             )
 411                       (setq lal (cdr ret))
 412                       ))
 413           (cons (cons 'domain domain) lal)
 414           ))))
 415
 416 (defun rfc822/parse-at-domain (lal)
 417   (let ((ret (rfc822/parse-ascii-token lal)) at-sign)
 418     (if (and ret
 419              (setq at-sign (car ret))
 420              (string-equal (cdr (assq 'specials at-sign)) "@")
 421              (setq ret (rfc822/parse-domain (cdr ret)))
 422              )
 423         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 424               (cdr ret))
 425       )))
 426
 427 (defun rfc822/parse-addr-spec (lal)
 428   (let ((ret (rfc822/parse-local-part lal))
 429         addr)
 430     (if (and ret
 431              (prog1
 432                  (setq addr (cdr (car ret)))
 433                (setq lal (cdr ret))
 434                (and (setq ret (rfc822/parse-at-domain lal))
 435                     (setq addr (append addr (cdr (car ret))))
 436                     (setq lal (cdr ret))
 437                     )))
 438         (cons (cons 'addr-spec addr) lal)
 439       )))
 440
 441 (defun rfc822/parse-route (lal)
 442   (let ((ret (rfc822/parse-at-domain lal))
 443         route comma colon)
 444     (if (and ret
 445              (progn
 446                (setq route (cdr (car ret)))
 447                (setq lal (cdr ret))
 448                (while (and (setq ret (rfc822/parse-ascii-token lal))
 449                            (setq comma (car ret))
 450                            (string-equal (cdr (assq 'specials comma)) ",")
 451                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 452                            )
 453                  (setq route (append route comma (cdr (car ret))))
 454                  (setq lal (cdr ret))
 455                  )
 456                (and (setq ret (rfc822/parse-ascii-token lal))
 457                     (setq colon (car ret))
 458                     (string-equal (cdr (assq 'specials colon)) ":")
 459                     (setq route (append route colon))
 460                     )
 461                ))
 462         (cons (cons 'route route)
 463               (cdr ret)
 464               )
 465       )))
 466
 467 (defun rfc822/parse-route-addr (lal)
 468   (let ((ret (rfc822/parse-ascii-token lal))
 469         < route addr-spec >)
 470     (if (and ret
 471              (setq < (car ret))
 472              (string-equal (cdr (assq 'specials <)) "<")
 473              (setq lal (cdr ret))
 474              (progn (and (setq ret (rfc822/parse-route lal))
 475                          (setq route (cdr (car ret)))
 476                          (setq lal (cdr ret))
 477                          )
 478                     (setq ret (rfc822/parse-addr-spec lal))
 479                     )
 480              (setq addr-spec (cdr (car ret)))
 481              (setq lal (cdr ret))
 482              (setq ret (rfc822/parse-ascii-token lal))
 483              (setq > (car ret))
 484              (string-equal (cdr (assq 'specials >)) ">")
 485              )
 486         (cons (cons 'route-addr (append route addr-spec))
 487               (cdr ret)
 488               )
 489       )))
 490
 491 (defun rfc822/parse-phrase-route-addr (lal)
 492   (let ((ret (rfc822/parse-phrase lal)) phrase)
 493     (if ret
 494         (progn
 495           (setq phrase (cdr (car ret)))
 496           (setq lal (cdr ret))
 497           ))
 498     (if (setq ret (rfc822/parse-route-addr lal))
 499         (cons (list 'phrase-route-addr
 500                     phrase
 501                     (cdr (car ret)))
 502               (cdr ret))
 503       )))
 504
 505 (defun rfc822/parse-mailbox (lal)
 506   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 507                  (rfc822/parse-addr-spec lal)))
 508         mbox comment)
 509     (if (and ret
 510              (prog1
 511                  (setq mbox (car ret))
 512                (setq lal (cdr ret))
 513                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 514                         (setq comment (cdr (assq 'comment (car ret))))
 515                         )
 516                    (setq lal (cdr ret))
 517                  )))
 518         (cons (list 'mailbox mbox comment)
 519               lal)
 520       )))
 521
 522 (defun rfc822/parse-group (lal)
 523   (let ((ret (rfc822/parse-phrase lal))
 524         phrase colon comma mbox semicolon)
 525     (if (and ret
 526              (setq phrase (cdr (car ret)))
 527              (setq lal (cdr ret))
 528              (setq ret (rfc822/parse-ascii-token lal))
 529              (setq colon (car ret))
 530              (string-equal (cdr (assq 'specials colon)) ":")
 531              (setq lal (cdr ret))
 532              (progn
 533                (and (setq ret (rfc822/parse-mailbox lal))
 534                     (setq mbox (list (car ret)))
 535                     (setq lal (cdr ret))
 536                     (progn
 537                       (while (and (setq ret (rfc822/parse-ascii-token lal))
 538                                   (setq comma (car ret))
 539                                   (string-equal
 540                                    (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-ascii-token lal))
 548                     (setq semicolon (car ret))
 549                     (string-equal (cdr (assq 'specials semicolon)) ";")
 550                     )))
 551         (cons (list 'group phrase (nreverse 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-ascii-token lal))
 567                       (string-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           (nreverse 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   (cond ((eq (car address) 'group)
 588          (mapconcat (function rfc822/address-string)
 589                     (nth 2 address)
 590                     ", ")
 591          )
 592         ((eq (car address) 'mailbox)
 593          (let ((addr (nth 1 address)))
 594            (rfc822/addr-to-string
 595             (if (eq (car addr) 'phrase-route-addr)
 596                 (nth 2 addr)
 597               (cdr addr)
 598               )
 599             )))))
 600
 601 (defun rfc822/full-name-string (address)
 602   (cond ((eq (car address) 'group)
 603          (mapconcat (function
 604                      (lambda (token)
 605                        (cdr token)
 606                        ))
 607                     (nth 1 address) "")
 608          )
 609         ((eq (car address) 'mailbox)
 610          (let ((addr (nth 1 address))
 611                (comment (nth 2 address))
 612                phrase)
 613            (if (eq (car addr) 'phrase-route-addr)
 614                (setq phrase (mapconcat (function
 615                                         (lambda (token)
 616                                           (cdr token)
 617                                           ))
 618                                        (nth 1 addr) ""))
 619              )
 620            (or phrase comment)
 621            ))))
 622
 623 (defun rfc822/extract-address-components (str)
 624   "Extract full name and canonical address from STR.
 625 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 626 If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
 627   (let* ((structure (car
 628                      (rfc822/parse-address
 629                       (rfc822/lexical-analyze str)
 630                       )))
 631          (phrase  (rfc822/full-name-string structure))
 632          (address (rfc822/address-string structure))
 633          )
 634     (list phrase address)
 635     ))
 636
 637
 638 ;;; @ end
 639 ;;;
 640
 641 (provide 'tl-822)
 642
 643 ;;; tl-822.el ends here