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