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