std11.el

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