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