std11.el

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