std11.el

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