std11.el

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