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