std11.el

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