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
  31 ;;; @ fetch
  32 ;;;
  33
  34 (defconst std11-field-name-regexp "[!-9;-~]+")
  35 (defconst std11-field-head-regexp
  36   (concat "^" std11-field-name-regexp ":"))
  37 (defconst std11-next-field-head-regexp
  38   (concat "\n" std11-field-name-regexp ":"))
  39
  40 (defun std11-field-end ()
  41   "Move to end of field and return this point."
  42   (if (re-search-forward std11-next-field-head-regexp nil t)
  43       (goto-char (match-beginning 0))
  44     (if (re-search-forward "^$" nil 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                              (find-non-ascii-charset-string token-value)
 437                              )
 438                         (setq token nil)
 439                       )))
 440       (setq lal (cdr lal))
 441       (setq itl (cons token itl))
 442       )
 443     (if (and token
 444              (setq parsed (nreverse (cons token itl)))
 445              )
 446         (cons parsed (cdr lal))
 447       )))
 448
 449 (defun std11-parse-token-or-comment (lal)
 450   (let (token itl)
 451     (while (and lal
 452                 (progn
 453                   (setq token (car lal))
 454                   (eq (car token) 'spaces)
 455                   ))
 456       (setq lal (cdr lal))
 457       (setq itl (cons token itl))
 458       )
 459     (cons (nreverse (cons token itl))
 460           (cdr lal))
 461     ))
 462
 463 (defun std11-parse-word (lal)
 464   (let ((ret (std11-parse-ascii-token lal)))
 465     (if ret
 466         (let ((elt (car ret))
 467               (rest (cdr ret))
 468               )
 469           (if (or (assq 'atom elt)
 470                   (assq 'quoted-string elt))
 471               (cons (cons 'word elt) rest)
 472             )))))
 473
 474 (defun std11-parse-word-or-comment (lal)
 475   (let ((ret (std11-parse-token-or-comment lal)))
 476     (if ret
 477         (let ((elt (car ret))
 478               (rest (cdr ret))
 479               )
 480           (cond ((or (assq 'atom elt)
 481                      (assq 'quoted-string elt))
 482                  (cons (cons 'word elt) rest)
 483                  )
 484                 ((assq 'comment elt)
 485                  (cons (cons 'comment-word elt) rest)
 486                  ))
 487           ))))
 488
 489 (defun std11-parse-phrase (lal)
 490   (let (ret phrase)
 491     (while (setq ret (std11-parse-word-or-comment lal))
 492       (setq phrase (append phrase (cdr (car ret))))
 493       (setq lal (cdr ret))
 494       )
 495     (if phrase
 496         (cons (cons 'phrase phrase) lal)
 497       )))
 498
 499 (defun std11-parse-local-part (lal)
 500   (let ((ret (std11-parse-word lal)))
 501     (if ret
 502         (let ((local-part (cdr (car ret))) dot)
 503           (setq lal (cdr ret))
 504           (while (and (setq ret (std11-parse-ascii-token lal))
 505                       (setq dot (car ret))
 506                       (string-equal (cdr (assq 'specials dot)) ".")
 507                       (setq ret (std11-parse-word (cdr ret)))
 508                       (setq local-part
 509                             (append local-part dot (cdr (car ret)))
 510                             )
 511                       (setq lal (cdr ret))
 512                       ))
 513           (cons (cons 'local-part local-part) lal)
 514           ))))
 515
 516 (defun std11-parse-sub-domain (lal)
 517   (let ((ret (std11-parse-ascii-token lal)))
 518     (if ret
 519         (let ((sub-domain (car ret)))
 520           (if (or (assq 'atom sub-domain)
 521                   (assq 'domain-literal sub-domain)
 522                   )
 523               (cons (cons 'sub-domain sub-domain)
 524                     (cdr ret)
 525                     )
 526             )))))
 527
 528 (defun std11-parse-domain (lal)
 529   (let ((ret (std11-parse-sub-domain lal)))
 530     (if ret
 531         (let ((domain (cdr (car ret))) dot)
 532           (setq lal (cdr ret))
 533           (while (and (setq ret (std11-parse-ascii-token lal))
 534                       (setq dot (car ret))
 535                       (string-equal (cdr (assq 'specials dot)) ".")
 536                       (setq ret (std11-parse-sub-domain (cdr ret)))
 537                       (setq domain
 538                             (append domain dot (cdr (car ret)))
 539                             )
 540                       (setq lal (cdr ret))
 541                       ))
 542           (cons (cons 'domain domain) lal)
 543           ))))
 544
 545 (defun std11-parse-at-domain (lal)
 546   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 547     (if (and ret
 548              (setq at-sign (car ret))
 549              (string-equal (cdr (assq 'specials at-sign)) "@")
 550              (setq ret (std11-parse-domain (cdr ret)))
 551              )
 552         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 553               (cdr ret))
 554       )))
 555
 556 (defun std11-parse-addr-spec (lal)
 557   (let ((ret (std11-parse-local-part lal))
 558         addr)
 559     (if (and ret
 560              (prog1
 561                  (setq addr (cdr (car ret)))
 562                (setq lal (cdr ret))
 563                (and (setq ret (std11-parse-at-domain lal))
 564                     (setq addr (append addr (cdr (car ret))))
 565                     (setq lal (cdr ret))
 566                     )))
 567         (cons (cons 'addr-spec addr) lal)
 568       )))
 569
 570 (defun std11-parse-route (lal)
 571   (let ((ret (std11-parse-at-domain lal))
 572         route comma colon)
 573     (if (and ret
 574              (progn
 575                (setq route (cdr (car ret)))
 576                (setq lal (cdr ret))
 577                (while (and (setq ret (std11-parse-ascii-token lal))
 578                            (setq comma (car ret))
 579                            (string-equal (cdr (assq 'specials comma)) ",")
 580                            (setq ret (std11-parse-at-domain (cdr ret)))
 581                            )
 582                  (setq route (append route comma (cdr (car ret))))
 583                  (setq lal (cdr ret))
 584                  )
 585                (and (setq ret (std11-parse-ascii-token lal))
 586                     (setq colon (car ret))
 587                     (string-equal (cdr (assq 'specials colon)) ":")
 588                     (setq route (append route colon))
 589                     )
 590                ))
 591         (cons (cons 'route route)
 592               (cdr ret)
 593               )
 594       )))
 595
 596 (defun std11-parse-route-addr (lal)
 597   (let ((ret (std11-parse-ascii-token lal))
 598         < route addr-spec >)
 599     (if (and ret
 600              (setq < (car ret))
 601              (string-equal (cdr (assq 'specials <)) "<")
 602              (setq lal (cdr ret))
 603              (progn (and (setq ret (std11-parse-route lal))
 604                          (setq route (cdr (car ret)))
 605                          (setq lal (cdr ret))
 606                          )
 607                     (setq ret (std11-parse-addr-spec lal))
 608                     )
 609              (setq addr-spec (cdr (car ret)))
 610              (setq lal (cdr ret))
 611              (setq ret (std11-parse-ascii-token lal))
 612              (setq > (car ret))
 613              (string-equal (cdr (assq 'specials >)) ">")
 614              )
 615         (cons (cons 'route-addr (append route addr-spec))
 616               (cdr ret)
 617               )
 618       )))
 619
 620 (defun std11-parse-phrase-route-addr (lal)
 621   (let ((ret (std11-parse-phrase lal)) phrase)
 622     (if ret
 623         (progn
 624           (setq phrase (cdr (car ret)))
 625           (setq lal (cdr ret))
 626           ))
 627     (if (setq ret (std11-parse-route-addr lal))
 628         (cons (list 'phrase-route-addr
 629                     phrase
 630                     (cdr (car ret)))
 631               (cdr ret))
 632       )))
 633
 634 (defun std11-parse-mailbox (lal)
 635   (let ((ret (or (std11-parse-phrase-route-addr lal)
 636                  (std11-parse-addr-spec lal)))
 637         mbox comment)
 638     (if (and ret
 639              (prog1
 640                  (setq mbox (car ret))
 641                (setq lal (cdr ret))
 642                (if (and (setq ret (std11-parse-token-or-comment lal))
 643                         (setq comment (cdr (assq 'comment (car ret))))
 644                         )
 645                    (setq lal (cdr ret))
 646                  )))
 647         (cons (list 'mailbox mbox comment)
 648               lal)
 649       )))
 650
 651 (defun std11-parse-group (lal)
 652   (let ((ret (std11-parse-phrase lal))
 653         phrase colon comma mbox semicolon)
 654     (if (and ret
 655              (setq phrase (cdr (car ret)))
 656              (setq lal (cdr ret))
 657              (setq ret (std11-parse-ascii-token lal))
 658              (setq colon (car ret))
 659              (string-equal (cdr (assq 'specials colon)) ":")
 660              (setq lal (cdr ret))
 661              (progn
 662                (and (setq ret (std11-parse-mailbox lal))
 663                     (setq mbox (list (car ret)))
 664                     (setq lal (cdr ret))
 665                     (progn
 666                       (while (and (setq ret (std11-parse-ascii-token lal))
 667                                   (setq comma (car ret))
 668                                   (string-equal
 669                                    (cdr (assq 'specials comma)) ",")
 670                                   (setq lal (cdr ret))
 671                                   (setq ret (std11-parse-mailbox lal))
 672                                   (setq mbox (cons (car ret) mbox))
 673                                   (setq lal (cdr ret))
 674                                   )
 675                         )))
 676                (and (setq ret (std11-parse-ascii-token lal))
 677                     (setq semicolon (car ret))
 678                     (string-equal (cdr (assq 'specials semicolon)) ";")
 679                     )))
 680         (cons (list 'group phrase (nreverse mbox))
 681               (cdr ret)
 682               )
 683       )))
 684
 685 (defun std11-parse-address (lal)
 686   (or (std11-parse-group lal)
 687       (std11-parse-mailbox lal)
 688       ))
 689
 690 (defun std11-parse-addresses (lal)
 691   (let ((ret (std11-parse-address lal)))
 692     (if ret
 693         (let ((dest (list (car ret))))
 694           (setq lal (cdr ret))
 695           (while (and (setq ret (std11-parse-ascii-token lal))
 696                       (string-equal (cdr (assq 'specials (car ret))) ",")
 697                       (setq ret (std11-parse-address (cdr ret)))
 698                       )
 699             (setq dest (cons (car ret) dest))
 700             (setq lal (cdr ret))
 701             )
 702           (nreverse dest)
 703           ))))
 704
 705 (defun std11-parse-msg-id (lal)
 706   (let ((ret (std11-parse-ascii-token lal))
 707         < addr-spec >)
 708     (if (and ret
 709              (setq < (car ret))
 710              (string-equal (cdr (assq 'specials <)) "<")
 711              (setq lal (cdr ret))
 712              (setq ret (std11-parse-addr-spec lal))
 713              (setq addr-spec (car ret))
 714              (setq lal (cdr ret))
 715              (setq ret (std11-parse-ascii-token lal))
 716              (setq > (car ret))
 717              (string-equal (cdr (assq 'specials >)) ">")
 718              )
 719         (cons (cons 'msg-id (cdr addr-spec))
 720               (cdr ret))
 721       )))
 722
 723 (defun std11-parse-in-reply-to (tokens)
 724   "Parse lexical TOKENS as In-Reply-To field, and return the result."
 725   (let ((ret (or (std11-parse-msg-id tokens)
 726                  (std11-parse-phrase tokens))))
 727     (if ret
 728         (let ((dest (list (car ret))))
 729           (setq tokens (cdr ret))
 730           (while (setq ret (or (std11-parse-msg-id tokens)
 731                                (std11-parse-phrase tokens)))
 732             (setq dest (cons (car ret) dest))
 733             (setq tokens (cdr ret))
 734             )
 735           (nreverse dest)
 736           ))))
 737
 738
 739 ;;; @ composer
 740 ;;;
 741
 742 (defun std11-addr-to-string (seq)
 743   "Return string from lexical analyzed list SEQ
 744 represents addr-spec of RFC 822."
 745   (mapconcat (function
 746               (lambda (token)
 747                 (let ((name (car token)))
 748                   (cond
 749                    ((eq name 'spaces) "")
 750                    ((eq name 'comment) "")
 751                    ((eq name 'quoted-string)
 752                     (concat "\"" (cdr token) "\""))
 753                    (t (cdr token)))
 754                   )))
 755              seq "")
 756   )
 757
 758 ;;;###autoload
 759 (defun std11-address-string (address)
 760   "Return string of address part from parsed ADDRESS of RFC 822."
 761   (cond ((eq (car address) 'group)
 762          (mapconcat (function std11-address-string)
 763                     (car (cdr address))
 764                     ", ")
 765          )
 766         ((eq (car address) 'mailbox)
 767          (let ((addr (nth 1 address)))
 768            (std11-addr-to-string
 769             (if (eq (car addr) 'phrase-route-addr)
 770                 (nth 2 addr)
 771               (cdr addr)
 772               )
 773             )))))
 774
 775 (defun std11-comment-value-to-string (value)
 776   (if (stringp value)
 777       (std11-strip-quoted-pair value)
 778     (let ((dest ""))
 779       (while value
 780         (setq dest
 781               (concat dest
 782                       (if (stringp (car value))
 783                           (car value)
 784                         (concat "("
 785                                 (std11-comment-value-to-string
 786                                  (cdr (car value)))
 787                                 ")")
 788                         ))
 789               value (cdr value))
 790         )
 791       dest)))
 792
 793 ;;;###autoload
 794 (defun std11-full-name-string (address)
 795   "Return string of full-name part from parsed ADDRESS of RFC 822."
 796   (cond ((eq (car address) 'group)
 797          (mapconcat (function
 798                      (lambda (token)
 799                        (cdr token)
 800                        ))
 801                     (nth 1 address) "")
 802          )
 803         ((eq (car address) 'mailbox)
 804          (let ((addr (nth 1 address))
 805                (comment (nth 2 address))
 806                phrase)
 807            (if (eq (car addr) 'phrase-route-addr)
 808                (setq phrase
 809                      (mapconcat
 810                       (function
 811                        (lambda (token)
 812                          (let ((type (car token)))
 813                            (cond ((eq type 'quoted-string)
 814                                   (std11-strip-quoted-pair (cdr token))
 815                                   )
 816                                  ((eq type 'comment)
 817                                   (concat "("
 818                                           (std11-comment-value-to-string
 819                                            (cdr token))
 820                                           ")")
 821                                   )
 822                                  (t
 823                                   (cdr token)
 824                                   )))))
 825                       (nth 1 addr) ""))
 826              )
 827            (cond ((> (length phrase) 0) phrase)
 828                  (comment (std11-comment-value-to-string comment))
 829                  )
 830            ))))
 831
 832 ;;;###autoload
 833 (defun std11-msg-id-string (msg-id)
 834   "Return string from parsed MSG-ID of RFC 822."
 835   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 836   )
 837
 838 ;;;###autoload
 839 (defun std11-fill-msg-id-list-string (string &optional column)
 840   "Fill list of msg-id in STRING, and return the result."
 841   (or column
 842       (setq column 12))
 843   (let ((lal (std11-lexical-analyze string))
 844         dest)
 845     (let ((ret (std11-parse-msg-id lal)))
 846       (if ret
 847           (let* ((str (std11-msg-id-string (car ret)))
 848                  (len (length str)))
 849             (setq lal (cdr ret))
 850             (if (> (+ len column) 76)
 851                 (setq dest (concat dest "\n " str)
 852                       column (1+ len))
 853               (setq dest str
 854                     column (+ column len))
 855               ))
 856         (setq dest (concat dest (cdr (car lal)))
 857               lal (cdr lal))
 858         ))
 859     (while lal
 860       (let ((ret (std11-parse-msg-id lal)))
 861         (if ret
 862             (let* ((str (std11-msg-id-string (car ret)))
 863                    (len (1+ (length str))))
 864               (setq lal (cdr ret))
 865               (if (> (+ len column) 76)
 866                   (setq dest (concat dest "\n " str)
 867                         column len)
 868                 (setq dest (concat dest " " str)
 869                       column (+ column len))
 870                 ))
 871           (setq dest (concat dest (cdr (car lal)))
 872                 lal (cdr lal))
 873           )))
 874     dest))
 875
 876
 877 ;;; @ parser with lexical analyzer
 878 ;;;
 879
 880 ;;;###autoload
 881 (defun std11-parse-address-string (string)
 882   "Parse STRING as mail address."
 883   (std11-parse-address (std11-lexical-analyze string))
 884   )
 885
 886 ;;;###autoload
 887 (defun std11-parse-addresses-string (string)
 888   "Parse STRING as mail address list."
 889   (std11-parse-addresses (std11-lexical-analyze string))
 890   )
 891
 892 ;;;###autoload
 893 (defun std11-extract-address-components (string)
 894   "Extract full name and canonical address from STRING.
 895 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 896 If no name can be extracted, FULL-NAME will be nil."
 897   (let* ((structure (car (std11-parse-address-string
 898                           (std11-unfold-string string))))
 899          (phrase  (std11-full-name-string structure))
 900          (address (std11-address-string structure))
 901          )
 902     (list phrase address)
 903     ))
 904
 905
 906 ;;; @ end
 907 ;;;
 908
 909 (provide 'std11)
 910
 911 ;;; std11.el ends here