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-string 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-or-period (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                 ((string-equal (cdr (assq 'specials elt)) ".")
 512                  (cons (cons 'period elt) rest)
 513                  ))
 514           ))))
 515
 516 (defun std11-parse-phrase (lal)
 517   (let (ret phrase)
 518     (while (setq ret (std11-parse-word-or-comment-or-period lal))
 519       (setq phrase (append phrase (cdr (car ret))))
 520       (setq lal (cdr ret))
 521       )
 522     (if phrase
 523         (cons (cons 'phrase phrase) lal)
 524       )))
 525
 526 (defun std11-parse-local-part (lal)
 527   (let ((ret (std11-parse-word lal)))
 528     (if ret
 529         (let ((local-part (cdr (car ret))) dot)
 530           (setq lal (cdr ret))
 531           (while (and (setq ret (std11-parse-ascii-token lal))
 532                       (setq dot (car ret))
 533                       (string-equal (cdr (assq 'specials dot)) ".")
 534                       (setq ret (std11-parse-word (cdr ret)))
 535                       (setq local-part
 536                             (append local-part dot (cdr (car ret)))
 537                             )
 538                       (setq lal (cdr ret))
 539                       ))
 540           (cons (cons 'local-part local-part) lal)
 541           ))))
 542
 543 (defun std11-parse-sub-domain (lal)
 544   (let ((ret (std11-parse-ascii-token lal)))
 545     (if ret
 546         (let ((sub-domain (car ret)))
 547           (if (or (assq 'atom sub-domain)
 548                   (assq 'domain-literal sub-domain)
 549                   )
 550               (cons (cons 'sub-domain sub-domain)
 551                     (cdr ret)
 552                     )
 553             )))))
 554
 555 (defun std11-parse-domain (lal)
 556   (let ((ret (std11-parse-sub-domain lal)))
 557     (if ret
 558         (let ((domain (cdr (car ret))) dot)
 559           (setq lal (cdr ret))
 560           (while (and (setq ret (std11-parse-ascii-token lal))
 561                       (setq dot (car ret))
 562                       (string-equal (cdr (assq 'specials dot)) ".")
 563                       (setq ret (std11-parse-sub-domain (cdr ret)))
 564                       (setq domain
 565                             (append domain dot (cdr (car ret)))
 566                             )
 567                       (setq lal (cdr ret))
 568                       ))
 569           (cons (cons 'domain domain) lal)
 570           ))))
 571
 572 (defun std11-parse-at-domain (lal)
 573   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 574     (if (and ret
 575              (setq at-sign (car ret))
 576              (string-equal (cdr (assq 'specials at-sign)) "@")
 577              (setq ret (std11-parse-domain (cdr ret)))
 578              )
 579         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 580               (cdr ret))
 581       )))
 582
 583 (defun std11-parse-addr-spec (lal)
 584   (let ((ret (std11-parse-local-part lal))
 585         addr)
 586     (if (and ret
 587              (prog1
 588                  (setq addr (cdr (car ret)))
 589                (setq lal (cdr ret))
 590                (and (setq ret (std11-parse-at-domain lal))
 591                     (setq addr (append addr (cdr (car ret))))
 592                     (setq lal (cdr ret))
 593                     )))
 594         (cons (cons 'addr-spec addr) lal)
 595       )))
 596
 597 (defun std11-parse-route (lal)
 598   (let ((ret (std11-parse-at-domain lal))
 599         route comma colon)
 600     (if (and ret
 601              (progn
 602                (setq route (cdr (car ret)))
 603                (setq lal (cdr ret))
 604                (while (and (setq ret (std11-parse-ascii-token lal))
 605                            (setq comma (car ret))
 606                            (string-equal (cdr (assq 'specials comma)) ",")
 607                            (setq ret (std11-parse-at-domain (cdr ret)))
 608                            )
 609                  (setq route (append route comma (cdr (car ret))))
 610                  (setq lal (cdr ret))
 611                  )
 612                (and (setq ret (std11-parse-ascii-token lal))
 613                     (setq colon (car ret))
 614                     (string-equal (cdr (assq 'specials colon)) ":")
 615                     (setq route (append route colon))
 616                     )
 617                ))
 618         (cons (cons 'route route)
 619               (cdr ret)
 620               )
 621       )))
 622
 623 (defun std11-parse-route-addr (lal)
 624   (let ((ret (std11-parse-ascii-token lal))
 625         < route addr-spec >)
 626     (if (and ret
 627              (setq < (car ret))
 628              (string-equal (cdr (assq 'specials <)) "<")
 629              (setq lal (cdr ret))
 630              (progn (and (setq ret (std11-parse-route lal))
 631                          (setq route (cdr (car ret)))
 632                          (setq lal (cdr ret))
 633                          )
 634                     (setq ret (std11-parse-addr-spec lal))
 635                     )
 636              (setq addr-spec (cdr (car ret)))
 637              (setq lal (cdr ret))
 638              (setq ret (std11-parse-ascii-token lal))
 639              (setq > (car ret))
 640              (string-equal (cdr (assq 'specials >)) ">")
 641              )
 642         (cons (cons 'route-addr (append route addr-spec))
 643               (cdr ret)
 644               )
 645       )))
 646
 647 (defun std11-parse-phrase-route-addr (lal)
 648   (let ((ret (std11-parse-phrase lal)) phrase)
 649     (if ret
 650         (progn
 651           (setq phrase (cdr (car ret)))
 652           (setq lal (cdr ret))
 653           ))
 654     (if (setq ret (std11-parse-route-addr lal))
 655         (cons (list 'phrase-route-addr
 656                     phrase
 657                     (cdr (car ret)))
 658               (cdr ret))
 659       )))
 660
 661 (defun std11-parse-mailbox (lal)
 662   (let ((ret (or (std11-parse-phrase-route-addr lal)
 663                  (std11-parse-addr-spec lal)))
 664         mbox comment)
 665     (if (and ret
 666              (prog1
 667                  (setq mbox (car ret))
 668                (setq lal (cdr ret))
 669                (if (and (setq ret (std11-parse-token-or-comment lal))
 670                         (setq comment (cdr (assq 'comment (car ret))))
 671                         )
 672                    (setq lal (cdr ret))
 673                  )))
 674         (cons (list 'mailbox mbox comment)
 675               lal)
 676       )))
 677
 678 (defun std11-parse-group (lal)
 679   (let ((ret (std11-parse-phrase lal))
 680         phrase colon comma mbox semicolon)
 681     (if (and ret
 682              (setq phrase (cdr (car ret)))
 683              (setq lal (cdr ret))
 684              (setq ret (std11-parse-ascii-token lal))
 685              (setq colon (car ret))
 686              (string-equal (cdr (assq 'specials colon)) ":")
 687              (setq lal (cdr ret))
 688              (progn
 689                (and (setq ret (std11-parse-mailbox lal))
 690                     (setq mbox (list (car ret)))
 691                     (setq lal (cdr ret))
 692                     (progn
 693                       (while (and (setq ret (std11-parse-ascii-token lal))
 694                                   (setq comma (car ret))
 695                                   (string-equal
 696                                    (cdr (assq 'specials comma)) ",")
 697                                   (setq lal (cdr ret))
 698                                   (setq ret (std11-parse-mailbox lal))
 699                                   (setq mbox (cons (car ret) mbox))
 700                                   (setq lal (cdr ret))
 701                                   )
 702                         )))
 703                (and (setq ret (std11-parse-ascii-token lal))
 704                     (setq semicolon (car ret))
 705                     (string-equal (cdr (assq 'specials semicolon)) ";")
 706                     )))
 707         (cons (list 'group phrase (nreverse mbox))
 708               (cdr ret)
 709               )
 710       )))
 711
 712 (defun std11-parse-address (lal)
 713   (or (std11-parse-group lal)
 714       (std11-parse-mailbox lal)
 715       ))
 716
 717 (defun std11-parse-addresses (lal)
 718   (let ((ret (std11-parse-address lal)))
 719     (if ret
 720         (let ((dest (list (car ret))))
 721           (setq lal (cdr ret))
 722           (while (and (setq ret (std11-parse-ascii-token lal))
 723                       (string-equal (cdr (assq 'specials (car ret))) ",")
 724                       (setq ret (std11-parse-address (cdr ret)))
 725                       )
 726             (setq dest (cons (car ret) dest))
 727             (setq lal (cdr ret))
 728             )
 729           (nreverse dest)
 730           ))))
 731
 732 (defun std11-parse-msg-id (lal)
 733   (let ((ret (std11-parse-ascii-token lal))
 734         < addr-spec >)
 735     (if (and ret
 736              (setq < (car ret))
 737              (string-equal (cdr (assq 'specials <)) "<")
 738              (setq lal (cdr ret))
 739              (setq ret (std11-parse-addr-spec lal))
 740              (setq addr-spec (car ret))
 741              (setq lal (cdr ret))
 742              (setq ret (std11-parse-ascii-token lal))
 743              (setq > (car ret))
 744              (string-equal (cdr (assq 'specials >)) ">")
 745              )
 746         (cons (cons 'msg-id (cdr addr-spec))
 747               (cdr ret))
 748       )))
 749
 750 (defun std11-parse-msg-ids (tokens)
 751   "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result."
 752   (let ((ret (or (std11-parse-msg-id tokens)
 753                  (std11-parse-phrase tokens))))
 754     (if ret
 755         (let ((dest (list (car ret))))
 756           (setq tokens (cdr ret))
 757           (while (setq ret (or (std11-parse-msg-id tokens)
 758                                (std11-parse-phrase tokens)))
 759             (setq dest (cons (car ret) dest))
 760             (setq tokens (cdr ret))
 761             )
 762           (nreverse dest)
 763           ))))
 764
 765 (defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 766 (make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 767
 768
 769 ;;; @ composer
 770 ;;;
 771
 772 (defun std11-addr-to-string (seq)
 773   "Return string from lexical analyzed list SEQ
 774 represents addr-spec of RFC 822."
 775   (mapconcat (function
 776               (lambda (token)
 777                 (let ((name (car token)))
 778                   (cond
 779                    ((eq name 'spaces) "")
 780                    ((eq name 'comment) "")
 781                    ((eq name 'quoted-string)
 782                     (concat "\"" (cdr token) "\""))
 783                    (t (cdr token)))
 784                   )))
 785              seq "")
 786   )
 787
 788 ;;;###autoload
 789 (defun std11-address-string (address)
 790   "Return string of address part from parsed ADDRESS of RFC 822."
 791   (cond ((eq (car address) 'group)
 792          (mapconcat (function std11-address-string)
 793                     (nth 2 address)
 794                     ", ")
 795          )
 796         ((eq (car address) 'mailbox)
 797          (let ((addr (nth 1 address)))
 798            (std11-addr-to-string
 799             (if (eq (car addr) 'phrase-route-addr)
 800                 (nth 2 addr)
 801               (cdr addr)
 802               )
 803             )))))
 804
 805 (defun std11-comment-value-to-string (value)
 806   (if (stringp value)
 807       (std11-strip-quoted-pair value)
 808     (let ((dest ""))
 809       (while value
 810         (setq dest
 811               (concat dest
 812                       (if (stringp (car value))
 813                           (car value)
 814                         (concat "("
 815                                 (std11-comment-value-to-string
 816                                  (cdr (car value)))
 817                                 ")")
 818                         ))
 819               value (cdr value))
 820         )
 821       dest)))
 822
 823 ;;;###autoload
 824 (defun std11-full-name-string (address)
 825   "Return string of full-name part from parsed ADDRESS of RFC 822."
 826   (cond ((eq (car address) 'group)
 827          (mapconcat (function
 828                      (lambda (token)
 829                        (cdr token)
 830                        ))
 831                     (nth 1 address) "")
 832          )
 833         ((eq (car address) 'mailbox)
 834          (let ((addr (nth 1 address))
 835                (comment (nth 2 address))
 836                phrase)
 837            (if (eq (car addr) 'phrase-route-addr)
 838                (setq phrase
 839                      (mapconcat
 840                       (function
 841                        (lambda (token)
 842                          (let ((type (car token)))
 843                            (cond ((eq type 'quoted-string)
 844                                   (std11-strip-quoted-pair (cdr token))
 845                                   )
 846                                  ((eq type 'comment)
 847                                   (concat "("
 848                                           (std11-comment-value-to-string
 849                                            (cdr token))
 850                                           ")")
 851                                   )
 852                                  (t
 853                                   (cdr token)
 854                                   )))))
 855                       (nth 1 addr) ""))
 856              )
 857            (cond ((> (length phrase) 0) phrase)
 858                  (comment (std11-comment-value-to-string comment))
 859                  )
 860            ))))
 861
 862 ;;;###autoload
 863 (defun std11-msg-id-string (msg-id)
 864   "Return string from parsed MSG-ID of RFC 822."
 865   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 866   )
 867
 868 ;;;###autoload
 869 (defun std11-fill-msg-id-list-string (string &optional column)
 870   "Fill list of msg-id in STRING, and return the result."
 871   (or column
 872       (setq column 12))
 873   (let ((lal (std11-lexical-analyze string))
 874         dest)
 875     (let ((ret (std11-parse-msg-id lal)))
 876       (if ret
 877           (let* ((str (std11-msg-id-string (car ret)))
 878                  (len (length str)))
 879             (setq lal (cdr ret))
 880             (if (> (+ len column) 76)
 881                 (setq dest (concat dest "\n " str)
 882                       column (1+ len))
 883               (setq dest str
 884                     column (+ column len))
 885               ))
 886         (setq dest (concat dest (cdr (car lal)))
 887               lal (cdr lal))
 888         ))
 889     (while lal
 890       (let ((ret (std11-parse-msg-id lal)))
 891         (if ret
 892             (let* ((str (std11-msg-id-string (car ret)))
 893                    (len (1+ (length str))))
 894               (setq lal (cdr ret))
 895               (if (> (+ len column) 76)
 896                   (setq dest (concat dest "\n " str)
 897                         column len)
 898                 (setq dest (concat dest " " str)
 899                       column (+ column len))
 900                 ))
 901           (setq dest (concat dest (cdr (car lal)))
 902                 lal (cdr lal))
 903           )))
 904     dest))
 905
 906
 907 ;;; @ parser with lexical analyzer
 908 ;;;
 909
 910 ;;;###autoload
 911 (defun std11-parse-address-string (string)
 912   "Parse STRING as mail address."
 913   (std11-parse-address (std11-lexical-analyze string))
 914   )
 915
 916 ;;;###autoload
 917 (defun std11-parse-addresses-string (string)
 918   "Parse STRING as mail address list."
 919   (std11-parse-addresses (std11-lexical-analyze string))
 920   )
 921
 922 ;;;###autoload
 923 (defun std11-parse-msg-id-string (string)
 924   "Parse STRING as msg-id."
 925   (std11-parse-msg-id (std11-lexical-analyze string))
 926   )
 927
 928 ;;;###autoload
 929 (defun std11-parse-msg-ids-string (string)
 930   "Parse STRING as `*(phrase / msg-id)'."
 931   (std11-parse-msg-ids (std11-lexical-analyze string))
 932   )
 933
 934 ;;;###autoload
 935 (defun std11-extract-address-components (string)
 936   "Extract full name and canonical address from STRING.
 937 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 938 If no name can be extracted, FULL-NAME will be nil."
 939   (let* ((structure (car (std11-parse-address-string
 940                           (std11-unfold-string string))))
 941          (phrase  (std11-full-name-string structure))
 942          (address (std11-address-string structure))
 943          )
 944     (list phrase address)
 945     ))
 946
 947
 948 ;;; @ end
 949 ;;;
 950
 951 (provide 'std11)
 952
 953 ;;; std11.el ends here