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