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.28 1996-06-13 17:09:18 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-pair (str)
 270   (if (and (>= (length str) 2)
 271            (eq (elt str 0) ?\\)
 272            )
 273       (cons (cons 'quoted-pair (substring str 0 2))
 274             (substring str 2)
 275             ))
 276   )
 277
 278 (defun rfc822/analyze-quoted-string (str)
 279   (let ((len (length str)))
 280     (if (and (> len 0)
 281              (eq (elt str 0) ?\")
 282              )
 283         (let ((i 1) chr dest)
 284           (catch 'tag
 285             (while (< i len)
 286               (setq chr (aref str i))
 287               (cond ((eq chr ?\\)
 288                      (setq i (1+ i))
 289                      (if (>= i len)
 290                          (throw 'tag nil)
 291                        )
 292                      (setq dest (concat dest (char-to-string (aref str i))))
 293                      )
 294                     ((eq chr ?\")
 295                      (throw 'tag
 296                             (cons (cons 'quoted-string dest)
 297                                   (substring str (1+ i)))
 298                             )
 299                      )
 300                     (t
 301                      (setq dest (concat dest (char-to-string (aref str i))))
 302                      ))
 303               (setq i (1+ i))
 304               ))))))
 305
 306 (defun rfc822/analyze-domain-literal (str)
 307   (if (and (> (length str) 0)
 308            (eq (elt str 0) ?\[)
 309            )
 310       (let* ((i (position-mismatched
 311                  (function
 312                   (lambda (elt)
 313                     (not (find elt rfc822/non-dtext-chars))
 314                     ))
 315                  (setq str (substring str 1))
 316                  ))
 317              (rest (substring str i))
 318              )
 319         (if (and (> i 0)
 320                  (> (length rest) 0)
 321                  (eq (elt rest 0) ?\])
 322                  )
 323             (cons (cons 'domain-literal (substring str 0 i))
 324                   (substring rest 1)
 325                   )
 326           ))))
 327
 328 (defun rfc822/analyze-comment (str)
 329   (if (and (> (length str) 0)
 330            (eq (elt str 0) ?\()
 331            )
 332       (let ((dest "")
 333             p ret)
 334         (setq str (substring str 1))
 335         (catch 'tag
 336           (while (not (string-equal str ""))
 337             (setq p (position-mismatched
 338                      (function
 339                       (lambda (elt)
 340                         (not (find elt rfc822/non-ctext-chars))
 341                         )) str))
 342             (cond ((> p 0)
 343                    (setq dest (concat dest (substring str 0 p)))
 344                    (setq str (substring str p))
 345                    )
 346                   ((setq ret (rfc822/analyze-comment str))
 347                    (setq dest (concat dest "(" (cdr (car ret)) ")"))
 348                    (setq str (cdr ret))
 349                    )
 350                   (t (throw 'tag nil))
 351                   )
 352             ))
 353         (if (and (> (length str) 0)
 354                  (eq (elt str 0) ?\))
 355                  )
 356             (cons (cons 'comment dest)
 357                   (substring str 1)
 358                   )
 359           ))))
 360
 361 (defun rfc822/lexical-analyze (str)
 362   (let (dest ret)
 363     (while (not (string-equal str ""))
 364       (setq ret
 365             (or (rfc822/analyze-quoted-string str)
 366                 (rfc822/analyze-domain-literal str)
 367                 (rfc822/analyze-comment str)
 368                 (rfc822/analyze-spaces str)
 369                 (rfc822/analyze-special str)
 370                 (rfc822/analyze-atom str)
 371                 '((error) . "")
 372                 ))
 373       (setq dest (cons (car ret) dest))
 374       (setq str (cdr ret))
 375       )
 376     (nreverse dest)
 377     ))
 378
 379
 380 ;;; @ parser
 381 ;;;
 382
 383 (defun rfc822/ignored-token-p (token)
 384   (let ((type (car token)))
 385     (or (eq type 'spaces)(eq type 'comment))
 386     ))
 387
 388 (defun rfc822/parse-token (lal)
 389   (let (token itl)
 390     (while (and lal
 391                 (progn
 392                   (setq token (car lal))
 393                   (rfc822/ignored-token-p token)
 394                   ))
 395       (setq lal (cdr lal))
 396       (setq itl (cons token itl))
 397       )
 398     (cons (nreverse (cons token itl))
 399           (cdr lal))
 400     ))
 401
 402 (defun rfc822/parse-ascii-token (lal)
 403   (let (token itl parsed token-value)
 404     (while (and lal
 405                 (setq token (car lal))
 406                 (if (and (setq token-value (cdr token))
 407                          (find-charset-string token-value)
 408                          )
 409                     (setq token nil)
 410                   (rfc822/ignored-token-p token)
 411                   ))
 412       (setq lal (cdr lal))
 413       (setq itl (cons token itl))
 414       )
 415     (if (and token
 416              (setq parsed (nreverse (cons token itl)))
 417              )
 418         (cons parsed (cdr lal))
 419       )))
 420
 421 (defun rfc822/parse-token-or-comment (lal)
 422   (let (token itl)
 423     (while (and lal
 424                 (progn
 425                   (setq token (car lal))
 426                   (eq (car token) 'spaces)
 427                   ))
 428       (setq lal (cdr lal))
 429       (setq itl (cons token itl))
 430       )
 431     (cons (nreverse (cons token itl))
 432           (cdr lal))
 433     ))
 434
 435 (defun rfc822/parse-word (lal)
 436   (let ((ret (rfc822/parse-ascii-token lal)))
 437     (if ret
 438         (let ((elt (car ret))
 439               (rest (cdr ret))
 440               )
 441           (if (or (assq 'atom elt)
 442                   (assq 'quoted-string elt))
 443               (cons (cons 'word elt) rest)
 444             )))))
 445
 446 (defun rfc822/parse-word-or-comment (lal)
 447   (let ((ret (rfc822/parse-token-or-comment lal)))
 448     (if ret
 449         (let ((elt (car ret))
 450               (rest (cdr ret))
 451               )
 452           (cond ((or (assq 'atom elt)
 453                      (assq 'quoted-string elt))
 454                  (cons (cons 'word elt) rest)
 455                  )
 456                 ((assq 'comment elt)
 457                  (cons (cons 'comment-word elt) rest)
 458                  ))
 459           ))))
 460
 461 (defun rfc822/parse-phrase (lal)
 462   (let (ret phrase)
 463     (while (setq ret (rfc822/parse-word-or-comment lal))
 464       (setq phrase (append phrase (cdr (car ret))))
 465       (setq lal (cdr ret))
 466       )
 467     (if phrase
 468         (cons (cons 'phrase phrase) lal)
 469       )))
 470
 471 (defun rfc822/parse-local-part (lal)
 472   (let ((ret (rfc822/parse-word lal)))
 473     (if ret
 474         (let ((local-part (cdr (car ret))) dot)
 475           (setq lal (cdr ret))
 476           (while (and (setq ret (rfc822/parse-ascii-token lal))
 477                       (setq dot (car ret))
 478                       (string-equal (cdr (assq 'specials dot)) ".")
 479                       (setq ret (rfc822/parse-word (cdr ret)))
 480                       (setq local-part
 481                             (append local-part dot (cdr (car ret)))
 482                             )
 483                       (setq lal (cdr ret))
 484                       ))
 485           (cons (cons 'local-part local-part) lal)
 486           ))))
 487
 488 (defun rfc822/parse-sub-domain (lal)
 489   (let ((ret (rfc822/parse-ascii-token lal)))
 490     (if ret
 491         (let ((sub-domain (car ret)))
 492           (if (or (assq 'atom sub-domain)
 493                   (assq 'domain-literal sub-domain)
 494                   )
 495               (cons (cons 'sub-domain sub-domain)
 496                     (cdr ret)
 497                     )
 498             )))))
 499
 500 (defun rfc822/parse-domain (lal)
 501   (let ((ret (rfc822/parse-sub-domain lal)))
 502     (if ret
 503         (let ((domain (cdr (car ret))) dot)
 504           (setq lal (cdr ret))
 505           (while (and (setq ret (rfc822/parse-ascii-token lal))
 506                       (setq dot (car ret))
 507                       (string-equal (cdr (assq 'specials dot)) ".")
 508                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 509                       (setq domain
 510                             (append domain dot (cdr (car ret)))
 511                             )
 512                       (setq lal (cdr ret))
 513                       ))
 514           (cons (cons 'domain domain) lal)
 515           ))))
 516
 517 (defun rfc822/parse-at-domain (lal)
 518   (let ((ret (rfc822/parse-ascii-token lal)) at-sign)
 519     (if (and ret
 520              (setq at-sign (car ret))
 521              (string-equal (cdr (assq 'specials at-sign)) "@")
 522              (setq ret (rfc822/parse-domain (cdr ret)))
 523              )
 524         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 525               (cdr ret))
 526       )))
 527
 528 (defun rfc822/parse-addr-spec (lal)
 529   (let ((ret (rfc822/parse-local-part lal))
 530         addr)
 531     (if (and ret
 532              (prog1
 533                  (setq addr (cdr (car ret)))
 534                (setq lal (cdr ret))
 535                (and (setq ret (rfc822/parse-at-domain lal))
 536                     (setq addr (append addr (cdr (car ret))))
 537                     (setq lal (cdr ret))
 538                     )))
 539         (cons (cons 'addr-spec addr) lal)
 540       )))
 541
 542 (defun rfc822/parse-route (lal)
 543   (let ((ret (rfc822/parse-at-domain lal))
 544         route comma colon)
 545     (if (and ret
 546              (progn
 547                (setq route (cdr (car ret)))
 548                (setq lal (cdr ret))
 549                (while (and (setq ret (rfc822/parse-ascii-token lal))
 550                            (setq comma (car ret))
 551                            (string-equal (cdr (assq 'specials comma)) ",")
 552                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 553                            )
 554                  (setq route (append route comma (cdr (car ret))))
 555                  (setq lal (cdr ret))
 556                  )
 557                (and (setq ret (rfc822/parse-ascii-token lal))
 558                     (setq colon (car ret))
 559                     (string-equal (cdr (assq 'specials colon)) ":")
 560                     (setq route (append route colon))
 561                     )
 562                ))
 563         (cons (cons 'route route)
 564               (cdr ret)
 565               )
 566       )))
 567
 568 (defun rfc822/parse-route-addr (lal)
 569   (let ((ret (rfc822/parse-ascii-token lal))
 570         < route addr-spec >)
 571     (if (and ret
 572              (setq < (car ret))
 573              (string-equal (cdr (assq 'specials <)) "<")
 574              (setq lal (cdr ret))
 575              (progn (and (setq ret (rfc822/parse-route lal))
 576                          (setq route (cdr (car ret)))
 577                          (setq lal (cdr ret))
 578                          )
 579                     (setq ret (rfc822/parse-addr-spec lal))
 580                     )
 581              (setq addr-spec (cdr (car ret)))
 582              (setq lal (cdr ret))
 583              (setq ret (rfc822/parse-ascii-token lal))
 584              (setq > (car ret))
 585              (string-equal (cdr (assq 'specials >)) ">")
 586              )
 587         (cons (cons 'route-addr (append route addr-spec))
 588               (cdr ret)
 589               )
 590       )))
 591
 592 (defun rfc822/parse-phrase-route-addr (lal)
 593   (let ((ret (rfc822/parse-phrase lal)) phrase)
 594     (if ret
 595         (progn
 596           (setq phrase (cdr (car ret)))
 597           (setq lal (cdr ret))
 598           ))
 599     (if (setq ret (rfc822/parse-route-addr lal))
 600         (cons (list 'phrase-route-addr
 601                     phrase
 602                     (cdr (car ret)))
 603               (cdr ret))
 604       )))
 605
 606 (defun rfc822/parse-mailbox (lal)
 607   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 608                  (rfc822/parse-addr-spec lal)))
 609         mbox comment)
 610     (if (and ret
 611              (prog1
 612                  (setq mbox (car ret))
 613                (setq lal (cdr ret))
 614                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 615                         (setq comment (cdr (assq 'comment (car ret))))
 616                         )
 617                    (setq lal (cdr ret))
 618                  )))
 619         (cons (list 'mailbox mbox comment)
 620               lal)
 621       )))
 622
 623 (defun rfc822/parse-group (lal)
 624   (let ((ret (rfc822/parse-phrase lal))
 625         phrase colon comma mbox semicolon)
 626     (if (and ret
 627              (setq phrase (cdr (car ret)))
 628              (setq lal (cdr ret))
 629              (setq ret (rfc822/parse-ascii-token lal))
 630              (setq colon (car ret))
 631              (string-equal (cdr (assq 'specials colon)) ":")
 632              (setq lal (cdr ret))
 633              (progn
 634                (and (setq ret (rfc822/parse-mailbox lal))
 635                     (setq mbox (list (car ret)))
 636                     (setq lal (cdr ret))
 637                     (progn
 638                       (while (and (setq ret (rfc822/parse-ascii-token lal))
 639                                   (setq comma (car ret))
 640                                   (string-equal
 641                                    (cdr (assq 'specials comma)) ",")
 642                                   (setq lal (cdr ret))
 643                                   (setq ret (rfc822/parse-mailbox lal))
 644                                   (setq mbox (cons (car ret) mbox))
 645                                   (setq lal (cdr ret))
 646                                   )
 647                         )))
 648                (and (setq ret (rfc822/parse-ascii-token lal))
 649                     (setq semicolon (car ret))
 650                     (string-equal (cdr (assq 'specials semicolon)) ";")
 651                     )))
 652         (cons (list 'group phrase (nreverse mbox))
 653               (cdr ret)
 654               )
 655       )))
 656
 657 (defun rfc822/parse-address (lal)
 658   (or (rfc822/parse-group lal)
 659       (rfc822/parse-mailbox lal)
 660       ))
 661
 662 (defun rfc822/parse-addresses (lal)
 663   (let ((ret (rfc822/parse-address lal)))
 664     (if ret
 665         (let ((dest (list (car ret))))
 666           (setq lal (cdr ret))
 667           (while (and (setq ret (rfc822/parse-ascii-token lal))
 668                       (string-equal (cdr (assq 'specials (car ret))) ",")
 669                       (setq ret (rfc822/parse-address (cdr ret)))
 670                       )
 671             (setq dest (cons (car ret) dest))
 672             (setq lal (cdr ret))
 673             )
 674           (nreverse dest)
 675           ))))
 676
 677 (defun rfc822/addr-to-string (seq)
 678   (mapconcat (function
 679               (lambda (token)
 680                 (if (eq (car token) 'spaces)
 681                     ""
 682                   (cdr token)
 683                   )))
 684              seq "")
 685   )
 686
 687 (defun rfc822/address-string (address)
 688   (cond ((eq (car address) 'group)
 689          (mapconcat (function rfc822/address-string)
 690                     (nth 2 address)
 691                     ", ")
 692          )
 693         ((eq (car address) 'mailbox)
 694          (let ((addr (nth 1 address)))
 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