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     ;; unlimited patch by simm-emacs@fan.gr.jp
 219     ;;   Mon, 10 Jan 2000 13:03:02 +0900
 220     (if mime-decode-unlimited
 221         (eword-encode-string (concat dest (substring string b)))
 222       (concat dest (substring string b)))))
 223
 224 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
 225
 226 ;; unlimited patch by simm-emacs@fan.gr.jp
 227 ;;   Mon, 10 Jan 2000 13:03:02 +0900
 228 (defvar std11-filename-coding-system nil
 229   "Define coding-system for non-ASCII filename when send.
 230 Set this variable coding system symbol (ie. 'iso-2022-jp) or nil.
 231 If non-nil, std11-wrap-as-quoted-string use encode-coding-string.")
 232
 233 (defun std11-wrap-as-quoted-string (string)
 234   "Wrap STRING as RFC 822 quoted-string."
 235   (concat "\""
 236           ;; unlimited patch by simm-emacs@fan.gr.jp
 237           ;;   Mon, 10 Jan 2000 13:03:02 +0900
 238           (if std11-filename-coding-system
 239               (encode-coding-system string std11-filename-coding-system)
 240             (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list))
 241           "\""))
 242
 243 (defun std11-strip-quoted-pair (string)
 244   "Strip quoted-pairs in STRING."
 245   (let (dest
 246         (b 0)
 247         (i 0)
 248         (len (length string))
 249         )
 250     (while (< i len)
 251       (let ((chr (aref string i)))
 252         (if (eq chr ?\\)
 253             (setq dest (concat dest (substring string b i))
 254                   b (1+ i)
 255                   i (+ i 2))
 256           (setq i (1+ i))
 257           )))
 258     (concat dest (substring string b))
 259     ))
 260
 261 (defun std11-strip-quoted-string (string)
 262   "Strip quoted-string STRING."
 263   (let ((len (length string)))
 264     (or (and (>= len 2)
 265              (let ((max (1- len)))
 266                (and (eq (aref string 0) ?\")
 267                     (eq (aref string max) ?\")
 268                     (std11-strip-quoted-pair (substring string 1 max))
 269                     )))
 270         string)))
 271
 272
 273 ;;; @ lexical analyze
 274 ;;;
 275
 276 (defcustom std11-lexical-analyzer
 277   '(std11-analyze-quoted-string
 278     std11-analyze-domain-literal
 279     std11-analyze-comment
 280     std11-analyze-spaces
 281     std11-analyze-special
 282     std11-analyze-atom)
 283   "*List of functions to return result of lexical analyze.
 284 Each function must have two arguments: STRING and START.
 285 STRING is the target string to be analyzed.
 286 START is start position of STRING to analyze.
 287
 288 Previous function is preferred to next function.  If a function
 289 returns nil, next function is used.  Otherwise the return value will
 290 be the result."
 291   :group 'news
 292   :group 'mail
 293   :type '(repeat function))
 294
 295 (eval-and-compile
 296   (defconst std11-space-char-list '(?  ?\t ?\n))
 297   (defconst std11-special-char-list '(?\] ?\[
 298                                           ?\( ?\) ?< ?> ?@
 299                                           ?, ?\; ?: ?\\ ?\"
 300                                           ?.))
 301   )
 302 ;; (defconst std11-spaces-regexp
 303 ;;   (eval-when-compile (concat "[" std11-space-char-list "]+")))
 304
 305 (defconst std11-non-atom-regexp
 306   (eval-when-compile
 307     (concat "[" std11-special-char-list std11-space-char-list "]")))
 308
 309 (defconst std11-atom-regexp
 310   (eval-when-compile
 311     (concat "[^" std11-special-char-list std11-space-char-list "]+")))
 312
 313 (defun std11-analyze-spaces (string start)
 314   (if (and (string-match (eval-when-compile
 315                            (concat "[" std11-space-char-list "]+"))
 316                          string start)
 317            (= (match-beginning 0) start))
 318       (let ((end (match-end 0)))
 319         (cons (cons 'spaces (substring string start end))
 320               ;;(substring string end)
 321               end)
 322         )))
 323
 324 (defun std11-analyze-special (string start)
 325   (if (and (> (length string) start)
 326            (memq (aref string start) std11-special-char-list))
 327       (cons (cons 'specials (substring string start (1+ start)))
 328             ;;(substring string 1)
 329             (1+ start))
 330     ))
 331
 332 (defun std11-analyze-atom (string start)
 333   (if (string-match std11-non-atom-regexp string start)
 334       (if (> (match-beginning 0) start)
 335           (cons (cons 'atom (substring string start (match-beginning 0)))
 336                 (match-beginning 0))
 337         nil)
 338     (cons (cons 'atom (substring string start))
 339           (length string)))
 340   ;; (if (and (string-match std11-atom-regexp string start)
 341   ;;          (= (match-beginning 0) start))
 342   ;;     (let ((end (match-end 0)))
 343   ;;       (cons (cons 'atom (substring string start end))
 344   ;;             ;;(substring string end)
 345   ;;             end)
 346   ;;       ))
 347   )
 348
 349 (defun std11-check-enclosure (string open close &optional recursive from)
 350   (let ((len (length string))
 351         (i (or from 0))
 352         )
 353     (if (and (> len i)
 354              (eq (aref string i) open))
 355         (let (p chr)
 356           (setq i (1+ i))
 357           (catch 'tag
 358             (while (< i len)
 359               (setq chr (aref string i))
 360               (cond ((eq chr ?\\)
 361                      (setq i (1+ i))
 362                      (if (>= i len)
 363                          (throw 'tag nil)
 364                        )
 365                      (setq i (1+ i))
 366                      )
 367                     ((eq chr close)
 368                      (throw 'tag (1+ i))
 369                      )
 370                     ((eq chr open)
 371                      (if (and recursive
 372                               (setq p (std11-check-enclosure
 373                                        string open close recursive i))
 374                               )
 375                          (setq i p)
 376                        (throw 'tag nil)
 377                        ))
 378                     (t
 379                      (setq i (1+ i))
 380                      ))
 381               ))))))
 382
 383 (defun std11-analyze-quoted-string (string start)
 384   (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
 385     (if p
 386         (cons (cons 'quoted-string (substring string (1+ start) (1- p)))
 387               ;;(substring string p))
 388               p)
 389       )))
 390
 391 (defun std11-analyze-domain-literal (string start)
 392   (let ((p (std11-check-enclosure string ?\[ ?\] nil start)))
 393     (if p
 394         (cons (cons 'domain-literal (substring string (1+ start) (1- p)))
 395               ;;(substring string p))
 396               p)
 397       )))
 398
 399 (defun std11-analyze-comment (string start)
 400   (let ((p (std11-check-enclosure string ?\( ?\) t start)))
 401     (if p
 402         (cons (cons 'comment (substring string (1+ start) (1- p)))
 403               ;;(substring string p))
 404               p)
 405       )))
 406
 407 ;;;###autoload
 408 (defun std11-lexical-analyze (string &optional analyzer start)
 409   "Analyze STRING as lexical tokens of STD 11."
 410   (or analyzer
 411       (setq analyzer std11-lexical-analyzer))
 412   (or start
 413       (setq start 0))
 414   (let ((len (length string))
 415         dest ret)
 416     (while (< start len)
 417       (setq ret
 418             (let ((rest analyzer)
 419                   func r)
 420               (while (and (setq func (car rest))
 421                           (null (setq r (funcall func string start))))
 422                 (setq rest (cdr rest)))
 423               (or r
 424                   (cons (cons 'error (substring string start)) (1+ len)))
 425               ))
 426       (setq dest (cons (car ret) dest)
 427             start (cdr ret))
 428       )
 429     (nreverse dest)
 430     ))
 431
 432
 433 ;;; @ parser
 434 ;;;
 435
 436 (defun std11-ignored-token-p (token)
 437   (let ((type (car token)))
 438     (or (eq type 'spaces)(eq type 'comment))
 439     ))
 440
 441 (defun std11-parse-token (lal)
 442   (let (token itl)
 443     (while (and lal
 444                 (progn
 445                   (setq token (car lal))
 446                   (std11-ignored-token-p token)
 447                   ))
 448       (setq lal (cdr lal))
 449       (setq itl (cons token itl))
 450       )
 451     (cons (nreverse (cons token itl))
 452           (cdr lal))
 453     ))
 454
 455 (defun std11-parse-ascii-token (lal)
 456   (let (token itl parsed token-value)
 457     (while (and lal
 458                 (setq token (car lal))
 459                 (or (std11-ignored-token-p token)
 460                     (if (and (setq token-value (cdr token))
 461                              (delq 'ascii (find-charset-string token-value)))
 462                         (setq token nil)
 463                       )))
 464       (setq lal (cdr lal))
 465       (setq itl (cons token itl))
 466       )
 467     (if (and token
 468              (setq parsed (nreverse (cons token itl)))
 469              )
 470         (cons parsed (cdr lal))
 471       )))
 472
 473 (defun std11-parse-token-or-comment (lal)
 474   (let (token itl)
 475     (while (and lal
 476                 (progn
 477                   (setq token (car lal))
 478                   (eq (car token) 'spaces)
 479                   ))
 480       (setq lal (cdr lal))
 481       (setq itl (cons token itl))
 482       )
 483     (cons (nreverse (cons token itl))
 484           (cdr lal))
 485     ))
 486
 487 (defun std11-parse-word (lal)
 488   (let ((ret (std11-parse-ascii-token lal)))
 489     (if ret
 490         (let ((elt (car ret))
 491               (rest (cdr ret))
 492               )
 493           (if (or (assq 'atom elt)
 494                   (assq 'quoted-string elt))
 495               (cons (cons 'word elt) rest)
 496             )))))
 497
 498 (defun std11-parse-word-or-comment (lal)
 499   (let ((ret (std11-parse-token-or-comment lal)))
 500     (if ret
 501         (let ((elt (car ret))
 502               (rest (cdr ret))
 503               )
 504           (cond ((or (assq 'atom elt)
 505                      (assq 'quoted-string elt))
 506                  (cons (cons 'word elt) rest)
 507                  )
 508                 ((assq 'comment elt)
 509                  (cons (cons 'comment-word elt) rest)
 510                  ))
 511           ))))
 512
 513 (defun std11-parse-phrase (lal)
 514   (let (ret phrase)
 515     (while (setq ret (std11-parse-word-or-comment lal))
 516       (setq phrase (append phrase (cdr (car ret))))
 517       (setq lal (cdr ret))
 518       )
 519     (if phrase
 520         (cons (cons 'phrase phrase) lal)
 521       )))
 522
 523 (defun std11-parse-local-part (lal)
 524   (let ((ret (std11-parse-word lal)))
 525     (if ret
 526         (let ((local-part (cdr (car ret))) dot)
 527           (setq lal (cdr ret))
 528           (while (and (setq ret (std11-parse-ascii-token lal))
 529                       (setq dot (car ret))
 530                       (string-equal (cdr (assq 'specials dot)) ".")
 531                       (setq ret (std11-parse-word (cdr ret)))
 532                       (setq local-part
 533                             (append local-part dot (cdr (car ret)))
 534                             )
 535                       (setq lal (cdr ret))
 536                       ))
 537           (cons (cons 'local-part local-part) lal)
 538           ))))
 539
 540 (defun std11-parse-sub-domain (lal)
 541   (let ((ret (std11-parse-ascii-token lal)))
 542     (if ret
 543         (let ((sub-domain (car ret)))
 544           (if (or (assq 'atom sub-domain)
 545                   (assq 'domain-literal sub-domain)
 546                   )
 547               (cons (cons 'sub-domain sub-domain)
 548                     (cdr ret)
 549                     )
 550             )))))
 551
 552 (defun std11-parse-domain (lal)
 553   (let ((ret (std11-parse-sub-domain lal)))
 554     (if ret
 555         (let ((domain (cdr (car ret))) dot)
 556           (setq lal (cdr ret))
 557           (while (and (setq ret (std11-parse-ascii-token lal))
 558                       (setq dot (car ret))
 559                       (string-equal (cdr (assq 'specials dot)) ".")
 560                       (setq ret (std11-parse-sub-domain (cdr ret)))
 561                       (setq domain
 562                             (append domain dot (cdr (car ret)))
 563                             )
 564                       (setq lal (cdr ret))
 565                       ))
 566           (cons (cons 'domain domain) lal)
 567           ))))
 568
 569 (defun std11-parse-at-domain (lal)
 570   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 571     (if (and ret
 572              (setq at-sign (car ret))
 573              (string-equal (cdr (assq 'specials at-sign)) "@")
 574              (setq ret (std11-parse-domain (cdr ret)))
 575              )
 576         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 577               (cdr ret))
 578       )))
 579
 580 (defun std11-parse-addr-spec (lal)
 581   (let ((ret (std11-parse-local-part lal))
 582         addr)
 583     (if (and ret
 584              (prog1
 585                  (setq addr (cdr (car ret)))
 586                (setq lal (cdr ret))
 587                (and (setq ret (std11-parse-at-domain lal))
 588                     (setq addr (append addr (cdr (car ret))))
 589                     (setq lal (cdr ret))
 590                     )))
 591         (cons (cons 'addr-spec addr) lal)
 592       )))
 593
 594 (defun std11-parse-route (lal)
 595   (let ((ret (std11-parse-at-domain lal))
 596         route comma colon)
 597     (if (and ret
 598              (progn
 599                (setq route (cdr (car ret)))
 600                (setq lal (cdr ret))
 601                (while (and (setq ret (std11-parse-ascii-token lal))
 602                            (setq comma (car ret))
 603                            (string-equal (cdr (assq 'specials comma)) ",")
 604                            (setq ret (std11-parse-at-domain (cdr ret)))
 605                            )
 606                  (setq route (append route comma (cdr (car ret))))
 607                  (setq lal (cdr ret))
 608                  )
 609                (and (setq ret (std11-parse-ascii-token lal))
 610                     (setq colon (car ret))
 611                     (string-equal (cdr (assq 'specials colon)) ":")
 612                     (setq route (append route colon))
 613                     )
 614                ))
 615         (cons (cons 'route route)
 616               (cdr ret)
 617               )
 618       )))
 619
 620 (defun std11-parse-route-addr (lal)
 621   (let ((ret (std11-parse-ascii-token lal))
 622         < route addr-spec >)
 623     (if (and ret
 624              (setq < (car ret))
 625              (string-equal (cdr (assq 'specials <)) "<")
 626              (setq lal (cdr ret))
 627              (progn (and (setq ret (std11-parse-route lal))
 628                          (setq route (cdr (car ret)))
 629                          (setq lal (cdr ret))
 630                          )
 631                     (setq ret (std11-parse-addr-spec lal))
 632                     )
 633              (setq addr-spec (cdr (car ret)))
 634              (setq lal (cdr ret))
 635              (setq ret (std11-parse-ascii-token lal))
 636              (setq > (car ret))
 637              (string-equal (cdr (assq 'specials >)) ">")
 638              )
 639         (cons (cons 'route-addr (append route addr-spec))
 640               (cdr ret)
 641               )
 642       )))
 643
 644 (defun std11-parse-phrase-route-addr (lal)
 645   (let ((ret (std11-parse-phrase lal)) phrase)
 646     (if ret
 647         (progn
 648           (setq phrase (cdr (car ret)))
 649           (setq lal (cdr ret))
 650           ))
 651     (if (setq ret (std11-parse-route-addr lal))
 652         (cons (list 'phrase-route-addr
 653                     phrase
 654                     (cdr (car ret)))
 655               (cdr ret))
 656       )))
 657
 658 (defun std11-parse-mailbox (lal)
 659   (let ((ret (or (std11-parse-phrase-route-addr lal)
 660                  (std11-parse-addr-spec lal)))
 661         mbox comment)
 662     (if (and ret
 663              (prog1
 664                  (setq mbox (car ret))
 665                (setq lal (cdr ret))
 666                (if (and (setq ret (std11-parse-token-or-comment lal))
 667                         (setq comment (cdr (assq 'comment (car ret))))
 668                         )
 669                    (setq lal (cdr ret))
 670                  )))
 671         (cons (list 'mailbox mbox comment)
 672               lal)
 673       )))
 674
 675 (defun std11-parse-group (lal)
 676   (let ((ret (std11-parse-phrase lal))
 677         phrase colon comma mbox semicolon)
 678     (if (and ret
 679              (setq phrase (cdr (car ret)))
 680              (setq lal (cdr ret))
 681              (setq ret (std11-parse-ascii-token lal))
 682              (setq colon (car ret))
 683              (string-equal (cdr (assq 'specials colon)) ":")
 684              (setq lal (cdr ret))
 685              (progn
 686                (and (setq ret (std11-parse-mailbox lal))
 687                     (setq mbox (list (car ret)))
 688                     (setq lal (cdr ret))
 689                     (progn
 690                       (while (and (setq ret (std11-parse-ascii-token lal))
 691                                   (setq comma (car ret))
 692                                   (string-equal
 693                                    (cdr (assq 'specials comma)) ",")
 694                                   (setq lal (cdr ret))
 695                                   (setq ret (std11-parse-mailbox lal))
 696                                   (setq mbox (cons (car ret) mbox))
 697                                   (setq lal (cdr ret))
 698                                   )
 699                         )))
 700                (and (setq ret (std11-parse-ascii-token lal))
 701                     (setq semicolon (car ret))
 702                     (string-equal (cdr (assq 'specials semicolon)) ";")
 703                     )))
 704         (cons (list 'group phrase (nreverse mbox))
 705               (cdr ret)
 706               )
 707       )))
 708
 709 (defun std11-parse-address (lal)
 710   (or (std11-parse-group lal)
 711       (std11-parse-mailbox lal)
 712       ))
 713
 714 (defun std11-parse-addresses (lal)
 715   (let ((ret (std11-parse-address lal)))
 716     (if ret
 717         (let ((dest (list (car ret))))
 718           (setq lal (cdr ret))
 719           (while (and (setq ret (std11-parse-ascii-token lal))
 720                       (string-equal (cdr (assq 'specials (car ret))) ",")
 721                       (setq ret (std11-parse-address (cdr ret)))
 722                       )
 723             (setq dest (cons (car ret) dest))
 724             (setq lal (cdr ret))
 725             )
 726           (nreverse dest)
 727           ))))
 728
 729 (defun std11-parse-msg-id (lal)
 730   (let ((ret (std11-parse-ascii-token lal))
 731         < addr-spec >)
 732     (if (and ret
 733              (setq < (car ret))
 734              (string-equal (cdr (assq 'specials <)) "<")
 735              (setq lal (cdr ret))
 736              (setq ret (std11-parse-addr-spec lal))
 737              (setq addr-spec (car ret))
 738              (setq lal (cdr ret))
 739              (setq ret (std11-parse-ascii-token lal))
 740              (setq > (car ret))
 741              (string-equal (cdr (assq 'specials >)) ">")
 742              )
 743         (cons (cons 'msg-id (cdr addr-spec))
 744               (cdr ret))
 745       )))
 746
 747 (defun std11-parse-msg-ids (tokens)
 748   "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result."
 749   (let ((ret (or (std11-parse-msg-id tokens)
 750                  (std11-parse-phrase tokens))))
 751     (if ret
 752         (let ((dest (list (car ret))))
 753           (setq tokens (cdr ret))
 754           (while (setq ret (or (std11-parse-msg-id tokens)
 755                                (std11-parse-phrase tokens)))
 756             (setq dest (cons (car ret) dest))
 757             (setq tokens (cdr ret))
 758             )
 759           (nreverse dest)
 760           ))))
 761
 762 (defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 763 (make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 764
 765
 766 ;;; @ composer
 767 ;;;
 768
 769 (defun std11-addr-to-string (seq)
 770   "Return string from lexical analyzed list SEQ
 771 represents addr-spec of RFC 822."
 772   (mapconcat (function
 773               (lambda (token)
 774                 (let ((name (car token)))
 775                   (cond
 776                    ((eq name 'spaces) "")
 777                    ((eq name 'comment) "")
 778                    ((eq name 'quoted-string)
 779                     (concat "\"" (cdr token) "\""))
 780                    (t (cdr token)))
 781                   )))
 782              seq "")
 783   )
 784
 785 ;;;###autoload
 786 (defun std11-address-string (address)
 787   "Return string of address part from parsed ADDRESS of RFC 822."
 788   (cond ((eq (car address) 'group)
 789          (mapconcat (function std11-address-string)
 790                     (nth 2 address)
 791                     ", ")
 792          )
 793         ((eq (car address) 'mailbox)
 794          (let ((addr (nth 1 address)))
 795            (std11-addr-to-string
 796             (if (eq (car addr) 'phrase-route-addr)
 797                 (nth 2 addr)
 798               (cdr addr)
 799               )
 800             )))))
 801
 802 (defun std11-comment-value-to-string (value)
 803   (if (stringp value)
 804       (std11-strip-quoted-pair value)
 805     (let ((dest ""))
 806       (while value
 807         (setq dest
 808               (concat dest
 809                       (if (stringp (car value))
 810                           (car value)
 811                         (concat "("
 812                                 (std11-comment-value-to-string
 813                                  (cdr (car value)))
 814                                 ")")
 815                         ))
 816               value (cdr value))
 817         )
 818       dest)))
 819
 820 ;;;###autoload
 821 (defun std11-full-name-string (address)
 822   "Return string of full-name part from parsed ADDRESS of RFC 822."
 823   (cond ((eq (car address) 'group)
 824          (mapconcat (function
 825                      (lambda (token)
 826                        (cdr token)
 827                        ))
 828                     (nth 1 address) "")
 829          )
 830         ((eq (car address) 'mailbox)
 831          (let ((addr (nth 1 address))
 832                (comment (nth 2 address))
 833                phrase)
 834            (if (eq (car addr) 'phrase-route-addr)
 835                (setq phrase
 836                      (mapconcat
 837                       (function
 838                        (lambda (token)
 839                          (let ((type (car token)))
 840                            (cond ((eq type 'quoted-string)
 841                                   (std11-strip-quoted-pair (cdr token))
 842                                   )
 843                                  ((eq type 'comment)
 844                                   (concat "("
 845                                           (std11-comment-value-to-string
 846                                            (cdr token))
 847                                           ")")
 848                                   )
 849                                  (t
 850                                   (cdr token)
 851                                   )))))
 852                       (nth 1 addr) ""))
 853              )
 854            (cond ((> (length phrase) 0) phrase)
 855                  (comment (std11-comment-value-to-string comment))
 856                  )
 857            ))))
 858
 859 ;;;###autoload
 860 (defun std11-msg-id-string (msg-id)
 861   "Return string from parsed MSG-ID of RFC 822."
 862   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 863   )
 864
 865 ;;;###autoload
 866 (defun std11-fill-msg-id-list-string (string &optional column)
 867   "Fill list of msg-id in STRING, and return the result."
 868   (or column
 869       (setq column 12))
 870   (let ((lal (std11-lexical-analyze string))
 871         dest)
 872     (let ((ret (std11-parse-msg-id lal)))
 873       (if ret
 874           (let* ((str (std11-msg-id-string (car ret)))
 875                  (len (length str)))
 876             (setq lal (cdr ret))
 877             (if (> (+ len column) 76)
 878                 (setq dest (concat dest "\n " str)
 879                       column (1+ len))
 880               (setq dest str
 881                     column (+ column len))
 882               ))
 883         (setq dest (concat dest (cdr (car lal)))
 884               lal (cdr lal))
 885         ))
 886     (while lal
 887       (let ((ret (std11-parse-msg-id lal)))
 888         (if ret
 889             (let* ((str (std11-msg-id-string (car ret)))
 890                    (len (1+ (length str))))
 891               (setq lal (cdr ret))
 892               (if (> (+ len column) 76)
 893                   (setq dest (concat dest "\n " str)
 894                         column len)
 895                 (setq dest (concat dest " " str)
 896                       column (+ column len))
 897                 ))
 898           (setq dest (concat dest (cdr (car lal)))
 899                 lal (cdr lal))
 900           )))
 901     dest))
 902
 903
 904 ;;; @ parser with lexical analyzer
 905 ;;;
 906
 907 ;;;###autoload
 908 (defun std11-parse-address-string (string)
 909   "Parse STRING as mail address."
 910   (std11-parse-address (std11-lexical-analyze string))
 911   )
 912
 913 ;;;###autoload
 914 (defun std11-parse-addresses-string (string)
 915   "Parse STRING as mail address list."
 916   (std11-parse-addresses (std11-lexical-analyze string))
 917   )
 918
 919 ;;;###autoload
 920 (defun std11-parse-msg-id-string (string)
 921   "Parse STRING as msg-id."
 922   (std11-parse-msg-id (std11-lexical-analyze string))
 923   )
 924
 925 ;;;###autoload
 926 (defun std11-parse-msg-ids-string (string)
 927   "Parse STRING as `*(phrase / msg-id)'."
 928   (std11-parse-msg-ids (std11-lexical-analyze string))
 929   )
 930
 931 ;;;###autoload
 932 (defun std11-extract-address-components (string)
 933   "Extract full name and canonical address from STRING.
 934 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 935 If no name can be extracted, FULL-NAME will be nil."
 936   (let* ((structure (car (std11-parse-address-string
 937                           (std11-unfold-string string))))
 938          (phrase  (std11-full-name-string structure))
 939          (address (std11-address-string structure))
 940          )
 941     (list phrase address)
 942     ))
 943
 944
 945 ;;; @ end
 946 ;;;
 947
 948 (provide 'std11)
 949
 950 ;;; std11.el ends here