std11.el

   1 ;;; std11.el --- STD 11 functions for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: mail, news, RFC 822, STD 11
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (or (fboundp 'buffer-substring-no-properties)
  28     (require 'poe))
  29
  30
  31 ;;; @ fetch
  32 ;;;
  33
  34 (defconst std11-field-name-regexp "[!-9;-~]+")
  35 (defconst std11-field-head-regexp
  36   (concat "^" std11-field-name-regexp ":"))
  37 (defconst std11-next-field-head-regexp
  38   (concat "\n" std11-field-name-regexp ":"))
  39
  40 (defun std11-field-end ()
  41   "Move to end of field and return this point."
  42   (if (re-search-forward std11-next-field-head-regexp nil t)
  43       (goto-char (match-beginning 0))
  44     (if (re-search-forward "^$" nil t)
  45         (goto-char (1- (match-beginning 0)))
  46       (end-of-line)
  47       ))
  48   (point)
  49   )
  50
  51 (defun std11-fetch-field (name)
  52   "Return the value of the header field NAME.
  53 The buffer is expected to be narrowed to just the headers of the message."
  54   (save-excursion
  55     (goto-char (point-min))
  56     (let ((case-fold-search t))
  57       (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
  58           (buffer-substring-no-properties (match-end 0) (std11-field-end))
  59         ))))
  60
  61 (defun std11-narrow-to-header (&optional boundary)
  62   "Narrow to the message header.
  63 If BOUNDARY is not nil, it is used as message header separator."
  64   (narrow-to-region
  65    (goto-char (point-min))
  66    (if (re-search-forward
  67         (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
  68         nil t)
  69        (match-beginning 0)
  70      (point-max)
  71      )))
  72
  73 (defun std11-field-body (name &optional boundary)
  74   "Return the value of the header field NAME.
  75 If BOUNDARY is not nil, it is used as message header separator."
  76   (save-excursion
  77     (save-restriction
  78       (inline (std11-narrow-to-header boundary)
  79               (std11-fetch-field name))
  80       )))
  81
  82 (defun std11-find-field-body (field-names &optional boundary)
  83   "Return the first found field-body specified by FIELD-NAMES
  84 of the message header in current buffer. If BOUNDARY is not nil, it is
  85 used as message header separator."
  86   (save-excursion
  87     (save-restriction
  88       (std11-narrow-to-header boundary)
  89       (let ((case-fold-search t)
  90             field-name)
  91         (catch 'tag
  92           (while (setq field-name (car field-names))
  93             (goto-char (point-min))
  94             (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  95                 (throw 'tag
  96                        (buffer-substring-no-properties
  97                         (match-end 0) (std11-field-end)))
  98               )
  99             (setq field-names (cdr field-names))
 100             ))))))
 101
 102 (defun std11-field-bodies (field-names &optional default-value boundary)
 103   "Return list of each field-bodies of FIELD-NAMES of the message header
 104 in current buffer. If BOUNDARY is not nil, it is used as message
 105 header separator."
 106   (save-excursion
 107     (save-restriction
 108       (std11-narrow-to-header boundary)
 109       (let* ((case-fold-search t)
 110              (dest (make-list (length field-names) default-value))
 111              (s-rest field-names)
 112              (d-rest dest)
 113              field-name)
 114         (while (setq field-name (car s-rest))
 115           (goto-char (point-min))
 116           (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
 117               (setcar d-rest
 118                       (buffer-substring-no-properties
 119                        (match-end 0) (std11-field-end)))
 120             )
 121           (setq s-rest (cdr s-rest)
 122                 d-rest (cdr d-rest))
 123           )
 124         dest))))
 125
 126 (defun std11-header-string (regexp &optional boundary)
 127   "Return string of message header fields matched by REGEXP.
 128 If BOUNDARY is not nil, it is used as message header separator.
 129 \[std11.el]"
 130   (let ((case-fold-search t))
 131     (save-excursion
 132       (save-restriction
 133         (std11-narrow-to-header boundary)
 134         (goto-char (point-min))
 135         (let (field header)
 136           (while (re-search-forward std11-field-head-regexp nil t)
 137             (setq field
 138                   (buffer-substring (match-beginning 0) (std11-field-end)))
 139             (if (string-match regexp field)
 140                 (setq header (concat header field "\n"))
 141               ))
 142           header)
 143         ))))
 144
 145 (defun std11-header-string-except (regexp &optional boundary)
 146   "Return string of message header fields not matched by REGEXP.
 147 If BOUNDARY is not nil, it is used as message header separator.
 148 \[std11.el]"
 149   (let ((case-fold-search t))
 150     (save-excursion
 151       (save-restriction
 152         (std11-narrow-to-header boundary)
 153         (goto-char (point-min))
 154         (let (field header)
 155           (while (re-search-forward std11-field-head-regexp nil t)
 156             (setq field
 157                   (buffer-substring (match-beginning 0) (std11-field-end)))
 158             (if (not (string-match regexp field))
 159                 (setq header (concat header field "\n"))
 160               ))
 161           header)
 162         ))))
 163
 164 (defun std11-collect-field-names (&optional boundary)
 165   "Return list of all field-names of the message header in current buffer.
 166 If BOUNDARY is not nil, it is used as message header separator.
 167 \[std11.el]"
 168   (save-excursion
 169     (save-restriction
 170       (std11-narrow-to-header boundary)
 171       (goto-char (point-min))
 172       (let (dest name)
 173         (while (re-search-forward std11-field-head-regexp nil t)
 174           (setq name (buffer-substring-no-properties
 175                       (match-beginning 0)(1- (match-end 0))))
 176           (or (member name dest)
 177               (setq dest (cons name dest))
 178               )
 179           )
 180         dest))))
 181
 182
 183 ;;; @ unfolding
 184 ;;;
 185
 186 (defun std11-unfold-string (string)
 187   "Unfold STRING as message header field."
 188   (let ((dest "")
 189         (p 0))
 190     (while (string-match "\n\\([ \t]\\)" string p)
 191       (setq dest (concat dest
 192                          (substring string p (match-beginning 0))
 193                          (substring string
 194                                     (match-beginning 1)
 195                                     (setq p (match-end 0)))
 196                          ))
 197       )
 198     (concat dest (substring string p))
 199     ))
 200
 201
 202 ;;; @ quoted-string
 203 ;;;
 204
 205 (defun std11-wrap-as-quoted-pairs (string specials)
 206   (let (dest
 207         (i 0)
 208         (b 0)
 209         (len (length string))
 210         )
 211     (while (< i len)
 212       (let ((chr (aref string i)))
 213         (if (memq chr specials)
 214             (setq dest (concat dest (substring string b i) "\\")
 215                   b i)
 216           ))
 217       (setq i (1+ i))
 218       )
 219     (concat dest (substring string b))
 220     ))
 221
 222 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
 223
 224 (defun std11-wrap-as-quoted-string (string)
 225   "Wrap STRING as RFC 822 quoted-string. [std11.el]"
 226   (concat "\""
 227           (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list)
 228           "\""))
 229
 230 (defun std11-strip-quoted-pair (string)
 231   "Strip quoted-pairs in STRING. [std11.el]"
 232   (let (dest
 233         (b 0)
 234         (i 0)
 235         (len (length string))
 236         )
 237     (while (< i len)
 238       (let ((chr (aref string i)))
 239         (if (eq chr ?\\)
 240             (setq dest (concat dest (substring string b i))
 241                   b (1+ i)
 242                   i (+ i 2))
 243           (setq i (1+ i))
 244           )))
 245     (concat dest (substring string b))
 246     ))
 247
 248 (defun std11-strip-quoted-string (string)
 249   "Strip quoted-string STRING."
 250   (let ((len (length string)))
 251     (or (and (>= len 2)
 252              (let ((max (1- len)))
 253                (and (eq (aref string 0) ?\")
 254                     (eq (aref string max) ?\")
 255                     (std11-strip-quoted-pair (substring string 1 max))
 256                     )))
 257         string)))
 258
 259
 260 ;;; @ lexical analyze
 261 ;;;
 262
 263 (eval-and-compile
 264   (defconst std11-space-char-list '(?  ?\t ?\n))
 265   (defconst std11-special-char-list '(?\] ?\[
 266                                           ?\( ?\) ?< ?> ?@
 267                                           ?, ?\; ?: ?\\ ?\"
 268                                           ?.))
 269   )
 270 ;; (defconst std11-spaces-regexp
 271 ;;   (eval-when-compile (concat "[" std11-space-char-list "]+")))
 272 (defconst std11-atom-regexp
 273   (eval-when-compile
 274     (concat "^[^" std11-special-char-list std11-space-char-list "]+")))
 275
 276 (defun std11-analyze-spaces (string)
 277   (if (and (string-match
 278             (eval-when-compile (concat "[" std11-space-char-list "]+"))
 279             string)
 280            (= (match-beginning 0) 0))
 281       (let ((end (match-end 0)))
 282         (cons (cons 'spaces (substring string 0 end))
 283               (substring string end)
 284               ))))
 285
 286 (defun std11-analyze-special (str)
 287   (if (and (> (length str) 0)
 288            (memq (aref str 0) std11-special-char-list))
 289       (cons (cons 'specials (substring str 0 1))
 290             (substring str 1)
 291             )))
 292
 293 (defun std11-analyze-atom (str)
 294   (if (string-match std11-atom-regexp str)
 295       (let ((end (match-end 0)))
 296         (cons (cons 'atom (substring str 0 end))
 297               (substring str end)
 298               ))))
 299
 300 (defun std11-check-enclosure (str open close &optional recursive from)
 301   (let ((len (length str))
 302         (i (or from 0))
 303         )
 304     (if (and (> len i)
 305              (eq (aref str i) open))
 306         (let (p chr)
 307           (setq i (1+ i))
 308           (catch 'tag
 309             (while (< i len)
 310               (setq chr (aref str i))
 311               (cond ((eq chr ?\\)
 312                      (setq i (1+ i))
 313                      (if (>= i len)
 314                          (throw 'tag nil)
 315                        )
 316                      (setq i (1+ i))
 317                      )
 318                     ((eq chr close)
 319                      (throw 'tag (1+ i))
 320                      )
 321                     ((eq chr open)
 322                      (if (and recursive
 323                               (setq p (std11-check-enclosure
 324                                        str open close recursive i))
 325                               )
 326                          (setq i p)
 327                        (throw 'tag nil)
 328                        ))
 329                     (t
 330                      (setq i (1+ i))
 331                      ))
 332               ))))))
 333
 334 (defun std11-analyze-quoted-string (str)
 335   (let ((p (std11-check-enclosure str ?\" ?\")))
 336     (if p
 337         (cons (cons 'quoted-string (substring str 1 (1- p)))
 338               (substring str p))
 339       )))
 340
 341 (defun std11-analyze-domain-literal (str)
 342   (let ((p (std11-check-enclosure str ?\[ ?\])))
 343     (if p
 344         (cons (cons 'domain-literal (substring str 1 (1- p)))
 345               (substring str p))
 346       )))
 347
 348 (defun std11-analyze-comment (str)
 349   (let ((p (std11-check-enclosure str ?\( ?\) t)))
 350     (if p
 351         (cons (cons 'comment (substring str 1 (1- p)))
 352               (substring str p))
 353       )))
 354
 355 (defun std11-lexical-analyze (str)
 356   (let (dest ret)
 357     (while (not (string-equal str ""))
 358       (setq ret
 359             (or (std11-analyze-quoted-string str)
 360                 (std11-analyze-domain-literal str)
 361                 (std11-analyze-comment str)
 362                 (std11-analyze-spaces str)
 363                 (std11-analyze-special str)
 364                 (std11-analyze-atom str)
 365                 '((error) . "")
 366                 ))
 367       (setq dest (cons (car ret) dest))
 368       (setq str (cdr ret))
 369       )
 370     (nreverse dest)
 371     ))
 372
 373
 374 ;;; @ parser
 375 ;;;
 376
 377 (defun std11-ignored-token-p (token)
 378   (let ((type (car token)))
 379     (or (eq type 'spaces)(eq type 'comment))
 380     ))
 381
 382 (defun std11-parse-token (lal)
 383   (let (token itl)
 384     (while (and lal
 385                 (progn
 386                   (setq token (car lal))
 387                   (std11-ignored-token-p token)
 388                   ))
 389       (setq lal (cdr lal))
 390       (setq itl (cons token itl))
 391       )
 392     (cons (nreverse (cons token itl))
 393           (cdr lal))
 394     ))
 395
 396 (defun std11-parse-ascii-token (lal)
 397   (let (token itl parsed token-value)
 398     (while (and lal
 399                 (setq token (car lal))
 400                 (or (std11-ignored-token-p token)
 401                     (if (and (setq token-value (cdr token))
 402                              (find-non-ascii-charset-string token-value)
 403                              )
 404                         (setq token nil)
 405                       )))
 406       (setq lal (cdr lal))
 407       (setq itl (cons token itl))
 408       )
 409     (if (and token
 410              (setq parsed (nreverse (cons token itl)))
 411              )
 412         (cons parsed (cdr lal))
 413       )))
 414
 415 (defun std11-parse-token-or-comment (lal)
 416   (let (token itl)
 417     (while (and lal
 418                 (progn
 419                   (setq token (car lal))
 420                   (eq (car token) 'spaces)
 421                   ))
 422       (setq lal (cdr lal))
 423       (setq itl (cons token itl))
 424       )
 425     (cons (nreverse (cons token itl))
 426           (cdr lal))
 427     ))
 428
 429 (defun std11-parse-word (lal)
 430   (let ((ret (std11-parse-ascii-token lal)))
 431     (if ret
 432         (let ((elt (car ret))
 433               (rest (cdr ret))
 434               )
 435           (if (or (assq 'atom elt)
 436                   (assq 'quoted-string elt))
 437               (cons (cons 'word elt) rest)
 438             )))))
 439
 440 (defun std11-parse-word-or-comment (lal)
 441   (let ((ret (std11-parse-token-or-comment lal)))
 442     (if ret
 443         (let ((elt (car ret))
 444               (rest (cdr ret))
 445               )
 446           (cond ((or (assq 'atom elt)
 447                      (assq 'quoted-string elt))
 448                  (cons (cons 'word elt) rest)
 449                  )
 450                 ((assq 'comment elt)
 451                  (cons (cons 'comment-word elt) rest)
 452                  ))
 453           ))))
 454
 455 (defun std11-parse-phrase (lal)
 456   (let (ret phrase)
 457     (while (setq ret (std11-parse-word-or-comment lal))
 458       (setq phrase (append phrase (cdr (car ret))))
 459       (setq lal (cdr ret))
 460       )
 461     (if phrase
 462         (cons (cons 'phrase phrase) lal)
 463       )))
 464
 465 (defun std11-parse-local-part (lal)
 466   (let ((ret (std11-parse-word lal)))
 467     (if ret
 468         (let ((local-part (cdr (car ret))) dot)
 469           (setq lal (cdr ret))
 470           (while (and (setq ret (std11-parse-ascii-token lal))
 471                       (setq dot (car ret))
 472                       (string-equal (cdr (assq 'specials dot)) ".")
 473                       (setq ret (std11-parse-word (cdr ret)))
 474                       (setq local-part
 475                             (append local-part dot (cdr (car ret)))
 476                             )
 477                       (setq lal (cdr ret))
 478                       ))
 479           (cons (cons 'local-part local-part) lal)
 480           ))))
 481
 482 (defun std11-parse-sub-domain (lal)
 483   (let ((ret (std11-parse-ascii-token lal)))
 484     (if ret
 485         (let ((sub-domain (car ret)))
 486           (if (or (assq 'atom sub-domain)
 487                   (assq 'domain-literal sub-domain)
 488                   )
 489               (cons (cons 'sub-domain sub-domain)
 490                     (cdr ret)
 491                     )
 492             )))))
 493
 494 (defun std11-parse-domain (lal)
 495   (let ((ret (std11-parse-sub-domain lal)))
 496     (if ret
 497         (let ((domain (cdr (car ret))) dot)
 498           (setq lal (cdr ret))
 499           (while (and (setq ret (std11-parse-ascii-token lal))
 500                       (setq dot (car ret))
 501                       (string-equal (cdr (assq 'specials dot)) ".")
 502                       (setq ret (std11-parse-sub-domain (cdr ret)))
 503                       (setq domain
 504                             (append domain dot (cdr (car ret)))
 505                             )
 506                       (setq lal (cdr ret))
 507                       ))
 508           (cons (cons 'domain domain) lal)
 509           ))))
 510
 511 (defun std11-parse-at-domain (lal)
 512   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 513     (if (and ret
 514              (setq at-sign (car ret))
 515              (string-equal (cdr (assq 'specials at-sign)) "@")
 516              (setq ret (std11-parse-domain (cdr ret)))
 517              )
 518         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 519               (cdr ret))
 520       )))
 521
 522 (defun std11-parse-addr-spec (lal)
 523   (let ((ret (std11-parse-local-part lal))
 524         addr)
 525     (if (and ret
 526              (prog1
 527                  (setq addr (cdr (car ret)))
 528                (setq lal (cdr ret))
 529                (and (setq ret (std11-parse-at-domain lal))
 530                     (setq addr (append addr (cdr (car ret))))
 531                     (setq lal (cdr ret))
 532                     )))
 533         (cons (cons 'addr-spec addr) lal)
 534       )))
 535
 536 (defun std11-parse-route (lal)
 537   (let ((ret (std11-parse-at-domain lal))
 538         route comma colon)
 539     (if (and ret
 540              (progn
 541                (setq route (cdr (car ret)))
 542                (setq lal (cdr ret))
 543                (while (and (setq ret (std11-parse-ascii-token lal))
 544                            (setq comma (car ret))
 545                            (string-equal (cdr (assq 'specials comma)) ",")
 546                            (setq ret (std11-parse-at-domain (cdr ret)))
 547                            )
 548                  (setq route (append route comma (cdr (car ret))))
 549                  (setq lal (cdr ret))
 550                  )
 551                (and (setq ret (std11-parse-ascii-token lal))
 552                     (setq colon (car ret))
 553                     (string-equal (cdr (assq 'specials colon)) ":")
 554                     (setq route (append route colon))
 555                     )
 556                ))
 557         (cons (cons 'route route)
 558               (cdr ret)
 559               )
 560       )))
 561
 562 (defun std11-parse-route-addr (lal)
 563   (let ((ret (std11-parse-ascii-token lal))
 564         < route addr-spec >)
 565     (if (and ret
 566              (setq < (car ret))
 567              (string-equal (cdr (assq 'specials <)) "<")
 568              (setq lal (cdr ret))
 569              (progn (and (setq ret (std11-parse-route lal))
 570                          (setq route (cdr (car ret)))
 571                          (setq lal (cdr ret))
 572                          )
 573                     (setq ret (std11-parse-addr-spec lal))
 574                     )
 575              (setq addr-spec (cdr (car ret)))
 576              (setq lal (cdr ret))
 577              (setq ret (std11-parse-ascii-token lal))
 578              (setq > (car ret))
 579              (string-equal (cdr (assq 'specials >)) ">")
 580              )
 581         (cons (cons 'route-addr (append route addr-spec))
 582               (cdr ret)
 583               )
 584       )))
 585
 586 (defun std11-parse-phrase-route-addr (lal)
 587   (let ((ret (std11-parse-phrase lal)) phrase)
 588     (if ret
 589         (progn
 590           (setq phrase (cdr (car ret)))
 591           (setq lal (cdr ret))
 592           ))
 593     (if (setq ret (std11-parse-route-addr lal))
 594         (cons (list 'phrase-route-addr
 595                     phrase
 596                     (cdr (car ret)))
 597               (cdr ret))
 598       )))
 599
 600 (defun std11-parse-mailbox (lal)
 601   (let ((ret (or (std11-parse-phrase-route-addr lal)
 602                  (std11-parse-addr-spec lal)))
 603         mbox comment)
 604     (if (and ret
 605              (prog1
 606                  (setq mbox (car ret))
 607                (setq lal (cdr ret))
 608                (if (and (setq ret (std11-parse-token-or-comment lal))
 609                         (setq comment (cdr (assq 'comment (car ret))))
 610                         )
 611                    (setq lal (cdr ret))
 612                  )))
 613         (cons (list 'mailbox mbox comment)
 614               lal)
 615       )))
 616
 617 (defun std11-parse-group (lal)
 618   (let ((ret (std11-parse-phrase lal))
 619         phrase colon comma mbox semicolon)
 620     (if (and ret
 621              (setq phrase (cdr (car ret)))
 622              (setq lal (cdr ret))
 623              (setq ret (std11-parse-ascii-token lal))
 624              (setq colon (car ret))
 625              (string-equal (cdr (assq 'specials colon)) ":")
 626              (setq lal (cdr ret))
 627              (progn
 628                (and (setq ret (std11-parse-mailbox lal))
 629                     (setq mbox (list (car ret)))
 630                     (setq lal (cdr ret))
 631                     (progn
 632                       (while (and (setq ret (std11-parse-ascii-token lal))
 633                                   (setq comma (car ret))
 634                                   (string-equal
 635                                    (cdr (assq 'specials comma)) ",")
 636                                   (setq lal (cdr ret))
 637                                   (setq ret (std11-parse-mailbox lal))
 638                                   (setq mbox (cons (car ret) mbox))
 639                                   (setq lal (cdr ret))
 640                                   )
 641                         )))
 642                (and (setq ret (std11-parse-ascii-token lal))
 643                     (setq semicolon (car ret))
 644                     (string-equal (cdr (assq 'specials semicolon)) ";")
 645                     )))
 646         (cons (list 'group phrase (nreverse mbox))
 647               (cdr ret)
 648               )
 649       )))
 650
 651 (defun std11-parse-address (lal)
 652   (or (std11-parse-group lal)
 653       (std11-parse-mailbox lal)
 654       ))
 655
 656 (defun std11-parse-addresses (lal)
 657   (let ((ret (std11-parse-address lal)))
 658     (if ret
 659         (let ((dest (list (car ret))))
 660           (setq lal (cdr ret))
 661           (while (and (setq ret (std11-parse-ascii-token lal))
 662                       (string-equal (cdr (assq 'specials (car ret))) ",")
 663                       (setq ret (std11-parse-address (cdr ret)))
 664                       )
 665             (setq dest (cons (car ret) dest))
 666             (setq lal (cdr ret))
 667             )
 668           (nreverse dest)
 669           ))))
 670
 671 (defun std11-parse-msg-id (lal)
 672   (let ((ret (std11-parse-ascii-token lal))
 673         < addr-spec >)
 674     (if (and ret
 675              (setq < (car ret))
 676              (string-equal (cdr (assq 'specials <)) "<")
 677              (setq lal (cdr ret))
 678              (setq ret (std11-parse-addr-spec lal))
 679              (setq addr-spec (car ret))
 680              (setq lal (cdr ret))
 681              (setq ret (std11-parse-ascii-token lal))
 682              (setq > (car ret))
 683              (string-equal (cdr (assq 'specials >)) ">")
 684              )
 685         (cons (cons 'msg-id (cdr addr-spec))
 686               (cdr ret))
 687       )))
 688
 689 (defun std11-parse-in-reply-to (tokens)
 690   "Parse lexical TOKENS as In-Reply-To field, and return the result."
 691   (let ((ret (or (std11-parse-msg-id tokens)
 692                  (std11-parse-phrase tokens))))
 693     (if ret
 694         (let ((dest (list (car ret))))
 695           (setq tokens (cdr ret))
 696           (while (setq ret (or (std11-parse-msg-id tokens)
 697                                (std11-parse-phrase tokens)))
 698             (setq dest (cons (car ret) dest))
 699             (setq tokens (cdr ret))
 700             )
 701           (nreverse dest)
 702           ))))
 703
 704
 705 ;;; @ composer
 706 ;;;
 707
 708 (defun std11-addr-to-string (seq)
 709   "Return string from lexical analyzed list SEQ
 710 represents addr-spec of RFC 822. [std11.el]"
 711   (mapconcat (function
 712               (lambda (token)
 713                 (let ((name (car token)))
 714                   (cond
 715                    ((eq name 'spaces) "")
 716                    ((eq name 'comment) "")
 717                    ((eq name 'quoted-string)
 718                     (concat "\"" (cdr token) "\""))
 719                    (t (cdr token)))
 720                   )))
 721              seq "")
 722   )
 723
 724 (defun std11-address-string (address)
 725   "Return string of address part from parsed ADDRESS of RFC 822.
 726 \[std11.el]"
 727   (cond ((eq (car address) 'group)
 728          (mapconcat (function std11-address-string)
 729                     (car (cdr address))
 730                     ", ")
 731          )
 732         ((eq (car address) 'mailbox)
 733          (let ((addr (nth 1 address)))
 734            (std11-addr-to-string
 735             (if (eq (car addr) 'phrase-route-addr)
 736                 (nth 2 addr)
 737               (cdr addr)
 738               )
 739             )))))
 740
 741 (defun std11-comment-value-to-string (value)
 742   (if (stringp value)
 743       (std11-strip-quoted-pair value)
 744     (let ((dest ""))
 745       (while value
 746         (setq dest
 747               (concat dest
 748                       (if (stringp (car value))
 749                           (car value)
 750                         (concat "("
 751                                 (std11-comment-value-to-string
 752                                  (cdr (car value)))
 753                                 ")")
 754                         ))
 755               value (cdr value))
 756         )
 757       dest)))
 758
 759 (defun std11-full-name-string (address)
 760   "Return string of full-name part from parsed ADDRESS of RFC 822."
 761   (cond ((eq (car address) 'group)
 762          (mapconcat (function
 763                      (lambda (token)
 764                        (cdr token)
 765                        ))
 766                     (nth 1 address) "")
 767          )
 768         ((eq (car address) 'mailbox)
 769          (let ((addr (nth 1 address))
 770                (comment (nth 2 address))
 771                phrase)
 772            (if (eq (car addr) 'phrase-route-addr)
 773                (setq phrase
 774                      (mapconcat
 775                       (function
 776                        (lambda (token)
 777                          (let ((type (car token)))
 778                            (cond ((eq type 'quoted-string)
 779                                   (std11-strip-quoted-pair (cdr token))
 780                                   )
 781                                  ((eq type 'comment)
 782                                   (concat "("
 783                                           (std11-comment-value-to-string
 784                                            (cdr token))
 785                                           ")")
 786                                   )
 787                                  (t
 788                                   (cdr token)
 789                                   )))))
 790                       (nth 1 addr) ""))
 791              )
 792            (cond ((> (length phrase) 0) phrase)
 793                  (comment (std11-comment-value-to-string comment))
 794                  )
 795            ))))
 796
 797 (defun std11-msg-id-string (msg-id)
 798   "Return string from parsed MSG-ID of RFC 822."
 799   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 800   )
 801
 802 (defun std11-fill-msg-id-list-string (string &optional column)
 803   "Fill list of msg-id in STRING, and return the result."
 804   (or column
 805       (setq column 12))
 806   (let ((lal (std11-lexical-analyze string))
 807         dest)
 808     (let ((ret (std11-parse-msg-id lal)))
 809       (if ret
 810           (let* ((str (std11-msg-id-string (car ret)))
 811                  (len (length str)))
 812             (setq lal (cdr ret))
 813             (if (> (+ len column) 76)
 814                 (setq dest (concat dest "\n " str)
 815                       column (1+ len))
 816               (setq dest str
 817                     column (+ column len))
 818               ))
 819         (setq dest (concat dest (cdr (car lal)))
 820               lal (cdr lal))
 821         ))
 822     (while lal
 823       (let ((ret (std11-parse-msg-id lal)))
 824         (if ret
 825             (let* ((str (std11-msg-id-string (car ret)))
 826                    (len (1+ (length str))))
 827               (setq lal (cdr ret))
 828               (if (> (+ len column) 76)
 829                   (setq dest (concat dest "\n " str)
 830                         column len)
 831                 (setq dest (concat dest " " str)
 832                       column (+ column len))
 833                 ))
 834           (setq dest (concat dest (cdr (car lal)))
 835                 lal (cdr lal))
 836           )))
 837     dest))
 838
 839
 840 ;;; @ parser with lexical analyzer
 841 ;;;
 842
 843 (defun std11-parse-address-string (string)
 844   "Parse STRING as mail address. [std11.el]"
 845   (std11-parse-address (std11-lexical-analyze string))
 846   )
 847
 848 (defun std11-parse-addresses-string (string)
 849   "Parse STRING as mail address list. [std11.el]"
 850   (std11-parse-addresses (std11-lexical-analyze string))
 851   )
 852
 853 (defun std11-extract-address-components (string)
 854   "Extract full name and canonical address from STRING.
 855 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 856 If no name can be extracted, FULL-NAME will be nil. [std11.el]"
 857   (let* ((structure (car (std11-parse-address-string
 858                           (std11-unfold-string string))))
 859          (phrase  (std11-full-name-string structure))
 860          (address (std11-address-string structure))
 861          )
 862     (list phrase address)
 863     ))
 864
 865
 866 ;;; @ end
 867 ;;;
 868
 869 (provide 'std11)
 870
 871 ;;; std11.el ends here