std11.el

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