std11.el

   1 ;;; std11.el --- STD 11 functions for GNU Emacs
   2
   3 ;; Copyright (C) 1995,96,97,98,99,2000,01,02 Free Software Foundation, Inc.
   4
   5 ;; Author:   MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: mail, news, RFC 822, STD 11
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require '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
 295 (defconst std11-non-atom-regexp
 296   (eval-when-compile
 297     (concat "[" std11-special-char-list std11-space-char-list "]")))
 298
 299 (defconst std11-atom-regexp
 300   (eval-when-compile
 301     (concat "[^" std11-special-char-list std11-space-char-list "]+")))
 302
 303 (defun std11-analyze-spaces (string start)
 304   (if (and (string-match (eval-when-compile
 305                            (concat "[" std11-space-char-list "]+"))
 306                          string start)
 307            (= (match-beginning 0) start))
 308       (let ((end (match-end 0)))
 309         (cons (cons 'spaces (substring string start end))
 310               ;;(substring string end)
 311               end)
 312         )))
 313
 314 (defun std11-analyze-special (string start)
 315   (if (and (> (length string) start)
 316            (memq (aref string start) std11-special-char-list))
 317       (cons (cons 'specials (substring string start (1+ start)))
 318             ;;(substring string 1)
 319             (1+ start))
 320     ))
 321
 322 (defun std11-analyze-atom (string start)
 323   (if (string-match std11-non-atom-regexp string start)
 324       (if (> (match-beginning 0) start)
 325           (cons (cons 'atom (substring string start (match-beginning 0)))
 326                 (match-beginning 0))
 327         nil)
 328     (cons (cons 'atom (substring string start))
 329           (length string)))
 330   ;; (if (and (string-match std11-atom-regexp string start)
 331   ;;          (= (match-beginning 0) start))
 332   ;;     (let ((end (match-end 0)))
 333   ;;       (cons (cons 'atom (substring string start end))
 334   ;;             ;;(substring string end)
 335   ;;             end)
 336   ;;       ))
 337   )
 338
 339 (defun std11-check-enclosure (string open close &optional recursive from)
 340   (let ((len (length string))
 341         (i (or from 0))
 342         )
 343     (if (and (> len i)
 344              (eq (aref string i) open))
 345         (let (p chr)
 346           (setq i (1+ i))
 347           (catch 'tag
 348             (while (< i len)
 349               (setq chr (aref string i))
 350               (cond ((eq chr ?\\)
 351                      (setq i (1+ i))
 352                      (if (>= i len)
 353                          (throw 'tag nil)
 354                        )
 355                      (setq i (1+ i))
 356                      )
 357                     ((eq chr close)
 358                      (throw 'tag (1+ i))
 359                      )
 360                     ((eq chr open)
 361                      (if (and recursive
 362                               (setq p (std11-check-enclosure
 363                                        string open close recursive i))
 364                               )
 365                          (setq i p)
 366                        (throw 'tag nil)
 367                        ))
 368                     (t
 369                      (setq i (1+ i))
 370                      ))
 371               ))))))
 372
 373 (defun std11-analyze-quoted-string (string start)
 374   (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
 375     (if p
 376         (cons (cons 'quoted-string (substring string (1+ start) (1- p)))
 377               ;;(substring string p))
 378               p)
 379       )))
 380
 381 (defun std11-analyze-domain-literal (string start)
 382   (let ((p (std11-check-enclosure string ?\[ ?\] nil start)))
 383     (if p
 384         (cons (cons 'domain-literal (substring string (1+ start) (1- p)))
 385               ;;(substring string p))
 386               p)
 387       )))
 388
 389 (defun std11-analyze-comment (string start)
 390   (let ((p (std11-check-enclosure string ?\( ?\) t start)))
 391     (if p
 392         (cons (cons 'comment (substring string (1+ start) (1- p)))
 393               ;;(substring string p))
 394               p)
 395       )))
 396
 397 ;;;###autoload
 398 (defun std11-lexical-analyze (string &optional analyzer start)
 399   "Analyze STRING as lexical tokens of STD 11."
 400   (or analyzer
 401       (setq analyzer std11-lexical-analyzer))
 402   (or start
 403       (setq start 0))
 404   (let ((len (length string))
 405         dest ret)
 406     (while (< start len)
 407       (setq ret
 408             (let ((rest analyzer)
 409                   func r)
 410               (while (and (setq func (car rest))
 411                           (null (setq r (funcall func string start))))
 412                 (setq rest (cdr rest)))
 413               (or r
 414                   (cons (cons 'error (substring string start)) (1+ len)))
 415               ))
 416       (setq dest (cons (car ret) dest)
 417             start (cdr ret))
 418       )
 419     (nreverse dest)
 420     ))
 421
 422
 423 ;;; @ parser
 424 ;;;
 425
 426 (defun std11-ignored-token-p (token)
 427   (let ((type (car token)))
 428     (or (eq type 'spaces)(eq type 'comment))
 429     ))
 430
 431 (defun std11-parse-token (lal)
 432   (let (token itl)
 433     (while (and lal
 434                 (progn
 435                   (setq token (car lal))
 436                   (std11-ignored-token-p token)
 437                   ))
 438       (setq lal (cdr lal))
 439       (setq itl (cons token itl))
 440       )
 441     (cons (nreverse (cons token itl))
 442           (cdr lal))
 443     ))
 444
 445 (defun std11-parse-ascii-token (lal)
 446   (let (token itl parsed token-value)
 447     (while (and lal
 448                 (setq token (car lal))
 449                 (or (std11-ignored-token-p token)
 450                     (if (and (setq token-value (cdr token))
 451                              (find-non-ascii-charset-string token-value))
 452                         (setq token nil)
 453                       )))
 454       (setq lal (cdr lal))
 455       (setq itl (cons token itl))
 456       )
 457     (if (and token
 458              (setq parsed (nreverse (cons token itl)))
 459              )
 460         (cons parsed (cdr lal))
 461       )))
 462
 463 (defun std11-parse-token-or-comment (lal)
 464   (let (token itl)
 465     (while (and lal
 466                 (progn
 467                   (setq token (car lal))
 468                   (eq (car token) 'spaces)
 469                   ))
 470       (setq lal (cdr lal))
 471       (setq itl (cons token itl))
 472       )
 473     (cons (nreverse (cons token itl))
 474           (cdr lal))
 475     ))
 476
 477 (defun std11-parse-word (lal)
 478   (let ((ret (std11-parse-ascii-token lal)))
 479     (if ret
 480         (let ((elt (car ret))
 481               (rest (cdr ret))
 482               )
 483           (if (or (assq 'atom elt)
 484                   (assq 'quoted-string elt))
 485               (cons (cons 'word elt) rest)
 486             )))))
 487
 488 (defun std11-parse-word-or-comment (lal)
 489   (let ((ret (std11-parse-token-or-comment lal)))
 490     (if ret
 491         (let ((elt (car ret))
 492               (rest (cdr ret))
 493               )
 494           (cond ((or (assq 'atom elt)
 495                      (assq 'quoted-string elt))
 496                  (cons (cons 'word elt) rest)
 497                  )
 498                 ((assq 'comment elt)
 499                  (cons (cons 'comment-word elt) rest)
 500                  ))
 501           ))))
 502
 503 (defun std11-parse-phrase (lal)
 504   (let (ret phrase)
 505     (while (setq ret (std11-parse-word-or-comment lal))
 506       (setq phrase (append phrase (cdr (car ret))))
 507       (setq lal (cdr ret))
 508       )
 509     (if phrase
 510         (cons (cons 'phrase phrase) lal)
 511       )))
 512
 513 (defun std11-parse-local-part (lal)
 514   (let ((ret (std11-parse-word lal)))
 515     (if ret
 516         (let ((local-part (cdr (car ret))) dot)
 517           (setq lal (cdr ret))
 518           (while (and (setq ret (std11-parse-ascii-token lal))
 519                       (setq dot (car ret))
 520                       (string-equal (cdr (assq 'specials dot)) ".")
 521                       (setq ret (std11-parse-word (cdr ret)))
 522                       (setq local-part
 523                             (append local-part dot (cdr (car ret)))
 524                             )
 525                       (setq lal (cdr ret))
 526                       ))
 527           (cons (cons 'local-part local-part) lal)
 528           ))))
 529
 530 (defun std11-parse-sub-domain (lal)
 531   (let ((ret (std11-parse-ascii-token lal)))
 532     (if ret
 533         (let ((sub-domain (car ret)))
 534           (if (or (assq 'atom sub-domain)
 535                   (assq 'domain-literal sub-domain)
 536                   )
 537               (cons (cons 'sub-domain sub-domain)
 538                     (cdr ret)
 539                     )
 540             )))))
 541
 542 (defun std11-parse-domain (lal)
 543   (let ((ret (std11-parse-sub-domain lal)))
 544     (if ret
 545         (let ((domain (cdr (car ret))) dot)
 546           (setq lal (cdr ret))
 547           (while (and (setq ret (std11-parse-ascii-token lal))
 548                       (setq dot (car ret))
 549                       (string-equal (cdr (assq 'specials dot)) ".")
 550                       (setq ret (std11-parse-sub-domain (cdr ret)))
 551                       (setq domain
 552                             (append domain dot (cdr (car ret)))
 553                             )
 554                       (setq lal (cdr ret))
 555                       ))
 556           (cons (cons 'domain domain) lal)
 557           ))))
 558
 559 (defun std11-parse-at-domain (lal)
 560   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 561     (if (and ret
 562              (setq at-sign (car ret))
 563              (string-equal (cdr (assq 'specials at-sign)) "@")
 564              (setq ret (std11-parse-domain (cdr ret)))
 565              )
 566         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 567               (cdr ret))
 568       )))
 569
 570 (defun std11-parse-addr-spec (lal)
 571   (let ((ret (std11-parse-local-part lal))
 572         addr)
 573     (if (and ret
 574              (prog1
 575                  (setq addr (cdr (car ret)))
 576                (setq lal (cdr ret))
 577                (and (setq ret (std11-parse-at-domain lal))
 578                     (setq addr (append addr (cdr (car ret))))
 579                     (setq lal (cdr ret))
 580                     )))
 581         (cons (cons 'addr-spec addr) lal)
 582       )))
 583
 584 (defun std11-parse-route (lal)
 585   (let ((ret (std11-parse-at-domain lal))
 586         route comma colon)
 587     (if (and ret
 588              (progn
 589                (setq route (cdr (car ret)))
 590                (setq lal (cdr ret))
 591                (while (and (setq ret (std11-parse-ascii-token lal))
 592                            (setq comma (car ret))
 593                            (string-equal (cdr (assq 'specials comma)) ",")
 594                            (setq ret (std11-parse-at-domain (cdr ret)))
 595                            )
 596                  (setq route (append route comma (cdr (car ret))))
 597                  (setq lal (cdr ret))
 598                  )
 599                (and (setq ret (std11-parse-ascii-token lal))
 600                     (setq colon (car ret))
 601                     (string-equal (cdr (assq 'specials colon)) ":")
 602                     (setq route (append route colon))
 603                     )
 604                ))
 605         (cons (cons 'route route)
 606               (cdr ret)
 607               )
 608       )))
 609
 610 (defun std11-parse-route-addr (lal)
 611   (let ((ret (std11-parse-ascii-token lal))
 612         < route addr-spec >)
 613     (if (and ret
 614              (setq < (car ret))
 615              (string-equal (cdr (assq 'specials <)) "<")
 616              (setq lal (cdr ret))
 617              (progn (and (setq ret (std11-parse-route lal))
 618                          (setq route (cdr (car ret)))
 619                          (setq lal (cdr ret))
 620                          )
 621                     (setq ret (std11-parse-addr-spec lal))
 622                     )
 623              (setq addr-spec (cdr (car ret)))
 624              (setq lal (cdr ret))
 625              (setq ret (std11-parse-ascii-token lal))
 626              (setq > (car ret))
 627              (string-equal (cdr (assq 'specials >)) ">")
 628              )
 629         (cons (cons 'route-addr (append route addr-spec))
 630               (cdr ret)
 631               )
 632       )))
 633
 634 (defun std11-parse-phrase-route-addr (lal)
 635   (let ((ret (std11-parse-phrase lal)) phrase)
 636     (if ret
 637         (progn
 638           (setq phrase (cdr (car ret)))
 639           (setq lal (cdr ret))
 640           ))
 641     (if (setq ret (std11-parse-route-addr lal))
 642         (cons (list 'phrase-route-addr
 643                     phrase
 644                     (cdr (car ret)))
 645               (cdr ret))
 646       )))
 647
 648 (defun std11-parse-mailbox (lal)
 649   (let ((ret (or (std11-parse-phrase-route-addr lal)
 650                  (std11-parse-addr-spec lal)))
 651         mbox comment)
 652     (if (and ret
 653              (prog1
 654                  (setq mbox (car ret))
 655                (setq lal (cdr ret))
 656                (if (and (setq ret (std11-parse-token-or-comment lal))
 657                         (setq comment (cdr (assq 'comment (car ret))))
 658                         )
 659                    (setq lal (cdr ret))
 660                  )))
 661         (cons (list 'mailbox mbox comment)
 662               lal)
 663       )))
 664
 665 (defun std11-parse-group (lal)
 666   (let ((ret (std11-parse-phrase lal))
 667         phrase colon comma mbox semicolon)
 668     (if (and ret
 669              (setq phrase (cdr (car ret)))
 670              (setq lal (cdr ret))
 671              (setq ret (std11-parse-ascii-token lal))
 672              (setq colon (car ret))
 673              (string-equal (cdr (assq 'specials colon)) ":")
 674              (setq lal (cdr ret))
 675              (progn
 676                (and (setq ret (std11-parse-mailbox lal))
 677                     (setq mbox (list (car ret)))
 678                     (setq lal (cdr ret))
 679                     (progn
 680                       (while (and (setq ret (std11-parse-ascii-token lal))
 681                                   (setq comma (car ret))
 682                                   (string-equal
 683                                    (cdr (assq 'specials comma)) ",")
 684                                   (setq lal (cdr ret))
 685                                   (setq ret (std11-parse-mailbox lal))
 686                                   (setq mbox (cons (car ret) mbox))
 687                                   (setq lal (cdr ret))
 688                                   )
 689                         )))
 690                (and (setq ret (std11-parse-ascii-token lal))
 691                     (setq semicolon (car ret))
 692                     (string-equal (cdr (assq 'specials semicolon)) ";")
 693                     )))
 694         (cons (list 'group phrase (nreverse mbox))
 695               (cdr ret)
 696               )
 697       )))
 698
 699 (defun std11-parse-address (lal)
 700   (or (std11-parse-group lal)
 701       (std11-parse-mailbox lal)
 702       ))
 703
 704 (defun std11-parse-addresses (lal)
 705   (let ((ret (std11-parse-address lal)))
 706     (if ret
 707         (let ((dest (list (car ret))))
 708           (setq lal (cdr ret))
 709           (while (and (setq ret (std11-parse-ascii-token lal))
 710                       (string-equal (cdr (assq 'specials (car ret))) ",")
 711                       (setq ret (std11-parse-address (cdr ret)))
 712                       )
 713             (setq dest (cons (car ret) dest))
 714             (setq lal (cdr ret))
 715             )
 716           (nreverse dest)
 717           ))))
 718
 719 (defun std11-parse-msg-id (lal)
 720   (let ((ret (std11-parse-ascii-token lal))
 721         < addr-spec >)
 722     (if (and ret
 723              (setq < (car ret))
 724              (string-equal (cdr (assq 'specials <)) "<")
 725              (setq lal (cdr ret))
 726              (setq ret (std11-parse-addr-spec lal))
 727              (setq addr-spec (car ret))
 728              (setq lal (cdr ret))
 729              (setq ret (std11-parse-ascii-token lal))
 730              (setq > (car ret))
 731              (string-equal (cdr (assq 'specials >)) ">")
 732              )
 733         (cons (cons 'msg-id (cdr addr-spec))
 734               (cdr ret))
 735       )))
 736
 737 (defun std11-parse-msg-ids (tokens)
 738   "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result."
 739   (let ((ret (or (std11-parse-msg-id tokens)
 740                  (std11-parse-phrase tokens))))
 741     (if ret
 742         (let ((dest (list (car ret))))
 743           (setq tokens (cdr ret))
 744           (while (setq ret (or (std11-parse-msg-id tokens)
 745                                (std11-parse-phrase tokens)))
 746             (setq dest (cons (car ret) dest))
 747             (setq tokens (cdr ret))
 748             )
 749           (nreverse dest)
 750           ))))
 751
 752 (defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 753 (make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 754
 755
 756 ;;; @ composer
 757 ;;;
 758
 759 (defun std11-addr-to-string (seq)
 760   "Return string from lexical analyzed list SEQ
 761 represents addr-spec of RFC 822."
 762   (mapconcat (function
 763               (lambda (token)
 764                 (let ((name (car token)))
 765                   (cond
 766                    ((eq name 'spaces) "")
 767                    ((eq name 'comment) "")
 768                    ((eq name 'quoted-string)
 769                     (concat "\"" (cdr token) "\""))
 770                    (t (cdr token)))
 771                   )))
 772              seq "")
 773   )
 774
 775 ;;;###autoload
 776 (defun std11-address-string (address)
 777   "Return string of address part from parsed ADDRESS of RFC 822."
 778   (cond ((eq (car address) 'group)
 779          (mapconcat (function std11-address-string)
 780                     (nth 2 address)
 781                     ", ")
 782          )
 783         ((eq (car address) 'mailbox)
 784          (let ((addr (nth 1 address)))
 785            (std11-addr-to-string
 786             (if (eq (car addr) 'phrase-route-addr)
 787                 (nth 2 addr)
 788               (cdr addr)
 789               )
 790             )))))
 791
 792 (defun std11-comment-value-to-string (value)
 793   (if (stringp value)
 794       (std11-strip-quoted-pair value)
 795     (let ((dest ""))
 796       (while value
 797         (setq dest
 798               (concat dest
 799                       (if (stringp (car value))
 800                           (car value)
 801                         (concat "("
 802                                 (std11-comment-value-to-string
 803                                  (cdr (car value)))
 804                                 ")")
 805                         ))
 806               value (cdr value))
 807         )
 808       dest)))
 809
 810 ;;;###autoload
 811 (defun std11-full-name-string (address)
 812   "Return string of full-name part from parsed ADDRESS of RFC 822."
 813   (cond ((eq (car address) 'group)
 814          (mapconcat (function
 815                      (lambda (token)
 816                        (cdr token)
 817                        ))
 818                     (nth 1 address) "")
 819          )
 820         ((eq (car address) 'mailbox)
 821          (let ((addr (nth 1 address))
 822                (comment (nth 2 address))
 823                phrase)
 824            (if (eq (car addr) 'phrase-route-addr)
 825                (setq phrase
 826                      (mapconcat
 827                       (function
 828                        (lambda (token)
 829                          (let ((type (car token)))
 830                            (cond ((eq type 'quoted-string)
 831                                   (std11-strip-quoted-pair (cdr token))
 832                                   )
 833                                  ((eq type 'comment)
 834                                   (concat "("
 835                                           (std11-comment-value-to-string
 836                                            (cdr token))
 837                                           ")")
 838                                   )
 839                                  (t
 840                                   (cdr token)
 841                                   )))))
 842                       (nth 1 addr) ""))
 843              )
 844            (cond ((> (length phrase) 0) phrase)
 845                  (comment (std11-comment-value-to-string comment))
 846                  )
 847            ))))
 848
 849 ;;;###autoload
 850 (defun std11-msg-id-string (msg-id)
 851   "Return string from parsed MSG-ID of RFC 822."
 852   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 853   )
 854
 855 ;;;###autoload
 856 (defun std11-fill-msg-id-list-string (string &optional column)
 857   "Fill list of msg-id in STRING, and return the result."
 858   (or column
 859       (setq column 12))
 860   (let ((lal (std11-lexical-analyze string))
 861         dest)
 862     (let ((ret (std11-parse-msg-id lal)))
 863       (if ret
 864           (let* ((str (std11-msg-id-string (car ret)))
 865                  (len (length str)))
 866             (setq lal (cdr ret))
 867             (if (> (+ len column) 76)
 868                 (setq dest (concat dest "\n " str)
 869                       column (1+ len))
 870               (setq dest str
 871                     column (+ column len))
 872               ))
 873         (setq dest (concat dest (cdr (car lal)))
 874               lal (cdr lal))
 875         ))
 876     (while lal
 877       (let ((ret (std11-parse-msg-id lal)))
 878         (if ret
 879             (let* ((str (std11-msg-id-string (car ret)))
 880                    (len (1+ (length str))))
 881               (setq lal (cdr ret))
 882               (if (> (+ len column) 76)
 883                   (setq dest (concat dest "\n " str)
 884                         column len)
 885                 (setq dest (concat dest " " str)
 886                       column (+ column len))
 887                 ))
 888           (setq dest (concat dest (cdr (car lal)))
 889                 lal (cdr lal))
 890           )))
 891     dest))
 892
 893
 894 ;;; @ parser with lexical analyzer
 895 ;;;
 896
 897 ;;;###autoload
 898 (defun std11-parse-address-string (string)
 899   "Parse STRING as mail address."
 900   (std11-parse-address (std11-lexical-analyze string))
 901   )
 902
 903 ;;;###autoload
 904 (defun std11-parse-addresses-string (string)
 905   "Parse STRING as mail address list."
 906   (std11-parse-addresses (std11-lexical-analyze string))
 907   )
 908
 909 ;;;###autoload
 910 (defun std11-parse-msg-id-string (string)
 911   "Parse STRING as msg-id."
 912   (std11-parse-msg-id (std11-lexical-analyze string))
 913   )
 914
 915 ;;;###autoload
 916 (defun std11-parse-msg-ids-string (string)
 917   "Parse STRING as `*(phrase / msg-id)'."
 918   (std11-parse-msg-ids (std11-lexical-analyze string))
 919   )
 920
 921 ;;;###autoload
 922 (defun std11-extract-address-components (string)
 923   "Extract full name and canonical address from STRING.
 924 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 925 If no name can be extracted, FULL-NAME will be nil."
 926   (let* ((structure (car (std11-parse-address-string
 927                           (std11-unfold-string string))))
 928          (phrase  (std11-full-name-string structure))
 929          (address (std11-address-string structure))
 930          )
 931     (list phrase address)
 932     ))
 933
 934
 935 ;;; @ end
 936 ;;;
 937
 938 (provide 'std11)
 939
 940 ;;; std11.el ends here