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