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