tl-822.el

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