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