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