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.25 1996-05-17 08:12:46 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             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 ret)
 360     (while (not (string-equal str ""))
 361       (setq ret
 362             (or (rfc822/analyze-quoted-string str)
 363                 (rfc822/analyze-domain-literal str)
 364                 (rfc822/analyze-comment str)
 365                 (rfc822/analyze-spaces str)
 366                 (rfc822/analyze-special str)
 367                 (rfc822/analyze-atom str)
 368                 '((error) . "")
 369                 ))
 370       (setq dest (cons (car ret) dest))
 371       (setq str (cdr ret))
 372       )
 373     (nreverse dest)
 374     ))
 375
 376
 377 ;;; @ parser
 378 ;;;
 379
 380 (defun rfc822/ignored-token-p (token)
 381   (let ((type (car token)))
 382     (or (eq type 'spaces)(eq type 'comment))
 383     ))
 384
 385 (defun rfc822/parse-token (lal)
 386   (let (token itl)
 387     (while (and lal
 388                 (progn
 389                   (setq token (car lal))
 390                   (rfc822/ignored-token-p token)
 391                   ))
 392       (setq lal (cdr lal))
 393       (setq itl (cons token itl))
 394       )
 395     (cons (nreverse (cons token itl))
 396           (cdr lal))
 397     ))
 398
 399 (defun rfc822/parse-ascii-token (lal)
 400   (let (token itl parsed token-value)
 401     (while (and lal
 402                 (setq token (car lal))
 403                 (if (and (setq token-value (cdr token))
 404                          (find-charset-string token-value)
 405                          )
 406                     (setq token nil)
 407                   (rfc822/ignored-token-p token)
 408                   ))
 409       (setq lal (cdr lal))
 410       (setq itl (cons token itl))
 411       )
 412     (if (and token
 413              (setq parsed (nreverse (cons token itl)))
 414              )
 415         (cons parsed (cdr lal))
 416       )))
 417
 418 (defun rfc822/parse-token-or-comment (lal)
 419   (let (token itl)
 420     (while (and lal
 421                 (progn
 422                   (setq token (car lal))
 423                   (eq (car token) 'spaces)
 424                   ))
 425       (setq lal (cdr lal))
 426       (setq itl (cons token itl))
 427       )
 428     (cons (nreverse (cons token itl))
 429           (cdr lal))
 430     ))
 431
 432 (defun rfc822/parse-word (lal)
 433   (let ((ret (rfc822/parse-ascii-token lal)))
 434     (if ret
 435         (let ((elt (car ret))
 436               (rest (cdr ret))
 437               )
 438           (if (or (assq 'atom elt)
 439                   (assq 'quoted-string elt))
 440               (cons (cons 'word elt) rest)
 441             )))))
 442
 443 (defun rfc822/parse-word-or-comment (lal)
 444   (let ((ret (rfc822/parse-token-or-comment lal)))
 445     (if ret
 446         (let ((elt (car ret))
 447               (rest (cdr ret))
 448               )
 449           (cond ((or (assq 'atom elt)
 450                      (assq 'quoted-string elt))
 451                  (cons (cons 'word elt) rest)
 452                  )
 453                 ((assq 'comment elt)
 454                  (cons (cons 'comment-word elt) rest)
 455                  ))
 456           ))))
 457
 458 (defun rfc822/parse-phrase (lal)
 459   (let (ret phrase)
 460     (while (setq ret (rfc822/parse-word-or-comment lal))
 461       (setq phrase (append phrase (cdr (car ret))))
 462       (setq lal (cdr ret))
 463       )
 464     (if phrase
 465         (cons (cons 'phrase phrase) lal)
 466       )))
 467
 468 (defun rfc822/parse-local-part (lal)
 469   (let ((ret (rfc822/parse-word lal)))
 470     (if ret
 471         (let ((local-part (cdr (car ret))) dot)
 472           (setq lal (cdr ret))
 473           (while (and (setq ret (rfc822/parse-ascii-token lal))
 474                       (setq dot (car ret))
 475                       (string-equal (cdr (assq 'specials dot)) ".")
 476                       (setq ret (rfc822/parse-word (cdr ret)))
 477                       (setq local-part
 478                             (append local-part dot (cdr (car ret)))
 479                             )
 480                       (setq lal (cdr ret))
 481                       ))
 482           (cons (cons 'local-part local-part) lal)
 483           ))))
 484
 485 (defun rfc822/parse-sub-domain (lal)
 486   (let ((ret (rfc822/parse-ascii-token lal)))
 487     (if ret
 488         (let ((sub-domain (car ret)))
 489           (if (or (assq 'atom sub-domain)
 490                   (assq 'domain-literal sub-domain)
 491                   )
 492               (cons (cons 'sub-domain sub-domain)
 493                     (cdr ret)
 494                     )
 495             )))))
 496
 497 (defun rfc822/parse-domain (lal)
 498   (let ((ret (rfc822/parse-sub-domain lal)))
 499     (if ret
 500         (let ((domain (cdr (car ret))) dot)
 501           (setq lal (cdr ret))
 502           (while (and (setq ret (rfc822/parse-ascii-token lal))
 503                       (setq dot (car ret))
 504                       (string-equal (cdr (assq 'specials dot)) ".")
 505                       (setq ret (rfc822/parse-sub-domain (cdr ret)))
 506                       (setq domain
 507                             (append domain dot (cdr (car ret)))
 508                             )
 509                       (setq lal (cdr ret))
 510                       ))
 511           (cons (cons 'domain domain) lal)
 512           ))))
 513
 514 (defun rfc822/parse-at-domain (lal)
 515   (let ((ret (rfc822/parse-ascii-token lal)) at-sign)
 516     (if (and ret
 517              (setq at-sign (car ret))
 518              (string-equal (cdr (assq 'specials at-sign)) "@")
 519              (setq ret (rfc822/parse-domain (cdr ret)))
 520              )
 521         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 522               (cdr ret))
 523       )))
 524
 525 (defun rfc822/parse-addr-spec (lal)
 526   (let ((ret (rfc822/parse-local-part lal))
 527         addr at-sign)
 528     (if (and ret
 529              (prog1
 530                  (setq addr (cdr (car ret)))
 531                (setq lal (cdr ret))
 532                (and (setq ret (rfc822/parse-at-domain lal))
 533                     (setq addr (append addr (cdr (car ret))))
 534                     (setq lal (cdr ret))
 535                     )))
 536         (cons (cons 'addr-spec addr) lal)
 537       )))
 538
 539 (defun rfc822/parse-route (lal)
 540   (let ((ret (rfc822/parse-at-domain lal))
 541         route comma colon)
 542     (if (and ret
 543              (progn
 544                (setq route (cdr (car ret)))
 545                (setq lal (cdr ret))
 546                (while (and (setq ret (rfc822/parse-ascii-token lal))
 547                            (setq comma (car ret))
 548                            (string-equal (cdr (assq 'specials comma)) ",")
 549                            (setq ret (rfc822/parse-at-domain (cdr ret)))
 550                            )
 551                  (setq route (append route comma (cdr (car ret))))
 552                  (setq lal (cdr ret))
 553                  )
 554                (and (setq ret (rfc822/parse-ascii-token lal))
 555                     (setq colon (car ret))
 556                     (string-equal (cdr (assq 'specials colon)) ":")
 557                     (setq route (append route colon))
 558                     )
 559                ))
 560         (cons (cons 'route route)
 561               (cdr ret)
 562               )
 563       )))
 564
 565 (defun rfc822/parse-route-addr (lal)
 566   (let ((ret (rfc822/parse-ascii-token lal))
 567         < route addr-spec >)
 568     (if (and ret
 569              (setq < (car ret))
 570              (string-equal (cdr (assq 'specials <)) "<")
 571              (setq lal (cdr ret))
 572              (progn (and (setq ret (rfc822/parse-route lal))
 573                          (setq route (cdr (car ret)))
 574                          (setq lal (cdr ret))
 575                          )
 576                     (setq ret (rfc822/parse-addr-spec lal))
 577                     )
 578              (setq addr-spec (cdr (car ret)))
 579              (setq lal (cdr ret))
 580              (setq ret (rfc822/parse-ascii-token lal))
 581              (setq > (car ret))
 582              (string-equal (cdr (assq 'specials >)) ">")
 583              )
 584         (cons (cons 'route-addr (append route addr-spec))
 585               (cdr ret)
 586               )
 587       )))
 588
 589 (defun rfc822/parse-phrase-route-addr (lal)
 590   (let ((ret (rfc822/parse-phrase lal)) phrase)
 591     (if ret
 592         (progn
 593           (setq phrase (cdr (car ret)))
 594           (setq lal (cdr ret))
 595           ))
 596     (if (setq ret (rfc822/parse-route-addr lal))
 597         (cons (list 'phrase-route-addr
 598                     phrase
 599                     (cdr (car ret)))
 600               (cdr ret))
 601       )))
 602
 603 (defun rfc822/parse-mailbox (lal)
 604   (let ((ret (or (rfc822/parse-phrase-route-addr lal)
 605                  (rfc822/parse-addr-spec lal)))
 606         mbox comment)
 607     (if (and ret
 608              (prog1
 609                  (setq mbox (car ret))
 610                (setq lal (cdr ret))
 611                (if (and (setq ret (rfc822/parse-token-or-comment lal))
 612                         (setq comment (cdr (assq 'comment (car ret))))
 613                         )
 614                    (setq lal (cdr ret))
 615                  )))
 616         (cons (list 'mailbox mbox comment)
 617               lal)
 618       )))
 619
 620 (defun rfc822/parse-group (lal)
 621   (let ((ret (rfc822/parse-phrase lal))
 622         phrase colon comma mbox semicolon)
 623     (if (and ret
 624              (setq phrase (cdr (car ret)))
 625              (setq lal (cdr ret))
 626              (setq ret (rfc822/parse-ascii-token lal))
 627              (setq colon (car ret))
 628              (string-equal (cdr (assq 'specials colon)) ":")
 629              (setq lal (cdr ret))
 630              (progn
 631                (and (setq ret (rfc822/parse-mailbox lal))
 632                     (setq mbox (list (car ret)))
 633                     (setq lal (cdr ret))
 634                     (progn
 635                       (while (and (setq ret (rfc822/parse-ascii-token lal))
 636                                   (setq comma (car ret))
 637                                   (string-equal
 638                                    (cdr (assq 'specials comma)) ",")
 639                                   (setq lal (cdr ret))
 640                                   (setq ret (rfc822/parse-mailbox lal))
 641                                   (setq mbox (cons (car ret) mbox))
 642                                   (setq lal (cdr ret))
 643                                   )
 644                         )))
 645                (and (setq ret (rfc822/parse-ascii-token lal))
 646                     (setq semicolon (car ret))
 647                     (string-equal (cdr (assq 'specials semicolon)) ";")
 648                     )))
 649         (cons (list 'group phrase (nreverse mbox))
 650               (cdr ret)
 651               )
 652       )))
 653
 654 (defun rfc822/parse-address (lal)
 655   (or (rfc822/parse-group lal)
 656       (rfc822/parse-mailbox lal)
 657       ))
 658
 659 (defun rfc822/parse-addresses (lal)
 660   (let ((ret (rfc822/parse-address lal)))
 661     (if ret
 662         (let ((dest (list (car ret))))
 663           (setq lal (cdr ret))
 664           (while (and (setq ret (rfc822/parse-ascii-token lal))
 665                       (string-equal (cdr (assq 'specials (car ret))) ",")
 666                       (setq ret (rfc822/parse-address (cdr ret)))
 667                       )
 668             (setq dest (cons (car ret) dest))
 669             (setq lal (cdr ret))
 670             )
 671           (nreverse dest)
 672           ))))
 673
 674 (defun rfc822/addr-to-string (seq)
 675   (mapconcat (function
 676               (lambda (token)
 677                 (if (eq (car token) 'spaces)
 678                     ""
 679                   (cdr token)
 680                   )))
 681              seq "")
 682   )
 683
 684 (defun rfc822/address-string (address)
 685   (cond ((eq (car address) 'group)
 686          (mapconcat (function rfc822/address-string)
 687                     (nth 2 address)
 688                     ", ")
 689          )
 690         ((eq (car address) 'mailbox)
 691          (let ((addr (nth 1 address))
 692                addr-spec)
 693            (rfc822/addr-to-string
 694             (if (eq (car addr) 'phrase-route-addr)
 695                 (nth 2 addr)
 696               (cdr addr)
 697               )
 698             )))))
 699
 700 (defun rfc822/full-name-string (address)
 701   (cond ((eq (car address) 'group)
 702          (mapconcat (function
 703                      (lambda (token)
 704                        (cdr token)
 705                        ))
 706                     (nth 1 address) "")
 707          )
 708         ((eq (car address) 'mailbox)
 709          (let ((addr (nth 1 address))
 710                (comment (nth 2 address))
 711                phrase)
 712            (if (eq (car addr) 'phrase-route-addr)
 713                (setq phrase (mapconcat (function
 714                                         (lambda (token)
 715                                           (cdr token)
 716                                           ))
 717                                        (nth 1 addr) ""))
 718              )
 719            (or phrase comment)
 720            ))))
 721
 722 (defun rfc822/extract-address-components (str)
 723   "Extract full name and canonical address from STR.
 724 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 725 If no name can be extracted, FULL-NAME will be nil. [tl-822.el]"
 726   (let* ((structure (car
 727                      (rfc822/parse-address
 728                       (rfc822/lexical-analyze str)
 729                       )))
 730          (phrase  (rfc822/full-name-string structure))
 731          (address (rfc822/address-string structure))
 732          )
 733     (list phrase address)
 734     ))
 735
 736
 737 ;;; @ end
 738 ;;;
 739
 740 (provide 'tl-822)
 741
 742 ;;; tl-822.el ends here