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