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