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