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