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