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     ;; unlimited patch by simm-emacs@fan.gr.jp
 221     ;;   Mon, 10 Jan 2000 13:03:02 +0900
 222     (if mime-decode-unlimited
 223         (eword-encode-string (concat dest (substring string b)))
 224       (concat dest (substring string b)))))
 225
 226 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
 227
 228 ;; unlimited patch by simm-emacs@fan.gr.jp
 229 ;;   Mon, 10 Jan 2000 13:03:02 +0900
 230 (defvar std11-filename-coding-system nil
 231   "Define coding-system for non-ASCII filename when send.
 232 Set this variable coding system symbol (ie. 'iso-2022-jp) or nil.
 233 If non-nil, std11-wrap-as-quoted-string use encode-coding-string.")
 234
 235 (defun std11-wrap-as-quoted-string (string)
 236   "Wrap STRING as RFC 822 quoted-string."
 237   (concat "\""
 238           ;; unlimited patch by simm-emacs@fan.gr.jp
 239           ;;   Mon, 10 Jan 2000 13:03:02 +0900
 240           (if std11-filename-coding-system
 241               (encode-coding-system string std11-filename-coding-system)
 242             (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list))
 243           "\""))
 244
 245 (defun std11-strip-quoted-pair (string)
 246   "Strip quoted-pairs in STRING."
 247   (let (dest
 248         (b 0)
 249         (i 0)
 250         (len (length string))
 251         )
 252     (while (< i len)
 253       (let ((chr (aref string i)))
 254         (if (eq chr ?\\)
 255             (setq dest (concat dest (substring string b i))
 256                   b (1+ i)
 257                   i (+ i 2))
 258           (setq i (1+ i))
 259           )))
 260     (concat dest (substring string b))
 261     ))
 262
 263 (defun std11-strip-quoted-string (string)
 264   "Strip quoted-string STRING."
 265   (let ((len (length string)))
 266     (or (and (>= len 2)
 267              (let ((max (1- len)))
 268                (and (eq (aref string 0) ?\")
 269                     (eq (aref string max) ?\")
 270                     (std11-strip-quoted-pair (substring string 1 max))
 271                     )))
 272         string)))
 273
 274
 275 ;;; @ lexical analyze
 276 ;;;
 277
 278 (defcustom std11-lexical-analyzer
 279   '(std11-analyze-quoted-string
 280     std11-analyze-domain-literal
 281     std11-analyze-comment
 282     std11-analyze-spaces
 283     std11-analyze-special
 284     std11-analyze-atom)
 285   "*List of functions to return result of lexical analyze.
 286 Each function must have two arguments: STRING and START.
 287 STRING is the target string to be analyzed.
 288 START is start position of STRING to analyze.
 289
 290 Previous function is preferred to next function.  If a function
 291 returns nil, next function is used.  Otherwise the return value will
 292 be the result."
 293   :group 'news
 294   :group 'mail
 295   :type '(repeat function))
 296
 297 (eval-and-compile
 298   (defconst std11-space-char-list '(?  ?\t ?\n))
 299   (defconst std11-special-char-list '(?\] ?\[
 300                                           ?\( ?\) ?< ?> ?@
 301                                           ?, ?\; ?: ?\\ ?\"
 302                                           ?.))
 303   )
 304 ;; (defconst std11-spaces-regexp
 305 ;;   (eval-when-compile (concat "[" std11-space-char-list "]+")))
 306 (defconst std11-atom-regexp
 307   (eval-when-compile
 308     (concat "[^" std11-special-char-list std11-space-char-list "]+")))
 309
 310 (defun std11-analyze-spaces (string start)
 311   (if (and (string-match (eval-when-compile
 312                            (concat "[" std11-space-char-list "]+"))
 313                          string start)
 314            (= (match-beginning 0) start))
 315       (let ((end (match-end 0)))
 316         (cons (cons 'spaces (substring string start end))
 317               ;;(substring string end)
 318               end)
 319         )))
 320
 321 (defun std11-analyze-special (string start)
 322   (if (and (> (length string) start)
 323            (memq (aref string start) std11-special-char-list))
 324       (cons (cons 'specials (substring string start (1+ start)))
 325             ;;(substring string 1)
 326             (1+ start))
 327     ))
 328
 329 (defun std11-analyze-atom (string start)
 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 (defun std11-check-enclosure (string open close &optional recursive from)
 339   (let ((len (length string))
 340         (i (or from 0))
 341         )
 342     (if (and (> len i)
 343              (eq (aref string i) open))
 344         (let (p chr)
 345           (setq i (1+ i))
 346           (catch 'tag
 347             (while (< i len)
 348               (setq chr (aref string i))
 349               (cond ((eq chr ?\\)
 350                      (setq i (1+ i))
 351                      (if (>= i len)
 352                          (throw 'tag nil)
 353                        )
 354                      (setq i (1+ i))
 355                      )
 356                     ((eq chr close)
 357                      (throw 'tag (1+ i))
 358                      )
 359                     ((eq chr open)
 360                      (if (and recursive
 361                               (setq p (std11-check-enclosure
 362                                        string open close recursive i))
 363                               )
 364                          (setq i p)
 365                        (throw 'tag nil)
 366                        ))
 367                     (t
 368                      (setq i (1+ i))
 369                      ))
 370               ))))))
 371
 372 (defun std11-analyze-quoted-string (string start)
 373   (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
 374     (if p
 375         (cons (cons 'quoted-string (substring string (1+ start) (1- p)))
 376               ;;(substring string p))
 377               p)
 378       )))
 379
 380 (defun std11-analyze-domain-literal (string start)
 381   (let ((p (std11-check-enclosure string ?\[ ?\] nil start)))
 382     (if p
 383         (cons (cons 'domain-literal (substring string (1+ start) (1- p)))
 384               ;;(substring string p))
 385               p)
 386       )))
 387
 388 (defun std11-analyze-comment (string start)
 389   (let ((p (std11-check-enclosure string ?\( ?\) t start)))
 390     (if p
 391         (cons (cons 'comment (substring string (1+ start) (1- p)))
 392               ;;(substring string p))
 393               p)
 394       )))
 395
 396 ;;;###autoload
 397 (defun std11-lexical-analyze (string &optional analyzer start)
 398   "Analyze STRING as lexical tokens of STD 11."
 399   (or analyzer
 400       (setq analyzer std11-lexical-analyzer))
 401   (or start
 402       (setq start 0))
 403   (let ((len (length string))
 404         dest ret)
 405     (while (< start len)
 406       (setq ret
 407             (let ((rest analyzer)
 408                   func r)
 409               (while (and (setq func (car rest))
 410                           (null (setq r (funcall func string start))))
 411                 (setq rest (cdr rest)))
 412               (or r
 413                   (cons (cons 'error (substring string start)) (1+ len)))
 414               ))
 415       (setq dest (cons (car ret) dest)
 416             start (cdr ret))
 417       )
 418     (nreverse dest)
 419     ))
 420
 421
 422 ;;; @ parser
 423 ;;;
 424
 425 (defun std11-ignored-token-p (token)
 426   (let ((type (car token)))
 427     (or (eq type 'spaces)(eq type 'comment))
 428     ))
 429
 430 (defun std11-parse-token (lal)
 431   (let (token itl)
 432     (while (and lal
 433                 (progn
 434                   (setq token (car lal))
 435                   (std11-ignored-token-p token)
 436                   ))
 437       (setq lal (cdr lal))
 438       (setq itl (cons token itl))
 439       )
 440     (cons (nreverse (cons token itl))
 441           (cdr lal))
 442     ))
 443
 444 (defun std11-parse-ascii-token (lal)
 445   (let (token itl parsed token-value)
 446     (while (and lal
 447                 (setq token (car lal))
 448                 (or (std11-ignored-token-p token)
 449                     (if (and (setq token-value (cdr token))
 450                              (delq 'ascii (find-charset-string token-value)))
 451                         (setq token nil)
 452                       )))
 453       (setq lal (cdr lal))
 454       (setq itl (cons token itl))
 455       )
 456     (if (and token
 457              (setq parsed (nreverse (cons token itl)))
 458              )
 459         (cons parsed (cdr lal))
 460       )))
 461
 462 (defun std11-parse-token-or-comment (lal)
 463   (let (token itl)
 464     (while (and lal
 465                 (progn
 466                   (setq token (car lal))
 467                   (eq (car token) 'spaces)
 468                   ))
 469       (setq lal (cdr lal))
 470       (setq itl (cons token itl))
 471       )
 472     (cons (nreverse (cons token itl))
 473           (cdr lal))
 474     ))
 475
 476 (defun std11-parse-word (lal)
 477   (let ((ret (std11-parse-ascii-token lal)))
 478     (if ret
 479         (let ((elt (car ret))
 480               (rest (cdr ret))
 481               )
 482           (if (or (assq 'atom elt)
 483                   (assq 'quoted-string elt))
 484               (cons (cons 'word elt) rest)
 485             )))))
 486
 487 (defun std11-parse-word-or-comment (lal)
 488   (let ((ret (std11-parse-token-or-comment lal)))
 489     (if ret
 490         (let ((elt (car ret))
 491               (rest (cdr ret))
 492               )
 493           (cond ((or (assq 'atom elt)
 494                      (assq 'quoted-string elt))
 495                  (cons (cons 'word elt) rest)
 496                  )
 497                 ((assq 'comment elt)
 498                  (cons (cons 'comment-word elt) rest)
 499                  ))
 500           ))))
 501
 502 (defun std11-parse-phrase (lal)
 503   (let (ret phrase)
 504     (while (setq ret (std11-parse-word-or-comment lal))
 505       (setq phrase (append phrase (cdr (car ret))))
 506       (setq lal (cdr ret))
 507       )
 508     (if phrase
 509         (cons (cons 'phrase phrase) lal)
 510       )))
 511
 512 (defun std11-parse-local-part (lal)
 513   (let ((ret (std11-parse-word lal)))
 514     (if ret
 515         (let ((local-part (cdr (car ret))) dot)
 516           (setq lal (cdr ret))
 517           (while (and (setq ret (std11-parse-ascii-token lal))
 518                       (setq dot (car ret))
 519                       (string-equal (cdr (assq 'specials dot)) ".")
 520                       (setq ret (std11-parse-word (cdr ret)))
 521                       (setq local-part
 522                             (append local-part dot (cdr (car ret)))
 523                             )
 524                       (setq lal (cdr ret))
 525                       ))
 526           (cons (cons 'local-part local-part) lal)
 527           ))))
 528
 529 (defun std11-parse-sub-domain (lal)
 530   (let ((ret (std11-parse-ascii-token lal)))
 531     (if ret
 532         (let ((sub-domain (car ret)))
 533           (if (or (assq 'atom sub-domain)
 534                   (assq 'domain-literal sub-domain)
 535                   )
 536               (cons (cons 'sub-domain sub-domain)
 537                     (cdr ret)
 538                     )
 539             )))))
 540
 541 (defun std11-parse-domain (lal)
 542   (let ((ret (std11-parse-sub-domain lal)))
 543     (if ret
 544         (let ((domain (cdr (car ret))) dot)
 545           (setq lal (cdr ret))
 546           (while (and (setq ret (std11-parse-ascii-token lal))
 547                       (setq dot (car ret))
 548                       (string-equal (cdr (assq 'specials dot)) ".")
 549                       (setq ret (std11-parse-sub-domain (cdr ret)))
 550                       (setq domain
 551                             (append domain dot (cdr (car ret)))
 552                             )
 553                       (setq lal (cdr ret))
 554                       ))
 555           (cons (cons 'domain domain) lal)
 556           ))))
 557
 558 (defun std11-parse-at-domain (lal)
 559   (let ((ret (std11-parse-ascii-token lal)) at-sign)
 560     (if (and ret
 561              (setq at-sign (car ret))
 562              (string-equal (cdr (assq 'specials at-sign)) "@")
 563              (setq ret (std11-parse-domain (cdr ret)))
 564              )
 565         (cons (cons 'at-domain (append at-sign (cdr (car ret))))
 566               (cdr ret))
 567       )))
 568
 569 (defun std11-parse-addr-spec (lal)
 570   (let ((ret (std11-parse-local-part lal))
 571         addr)
 572     (if (and ret
 573              (prog1
 574                  (setq addr (cdr (car ret)))
 575                (setq lal (cdr ret))
 576                (and (setq ret (std11-parse-at-domain lal))
 577                     (setq addr (append addr (cdr (car ret))))
 578                     (setq lal (cdr ret))
 579                     )))
 580         (cons (cons 'addr-spec addr) lal)
 581       )))
 582
 583 (defun std11-parse-route (lal)
 584   (let ((ret (std11-parse-at-domain lal))
 585         route comma colon)
 586     (if (and ret
 587              (progn
 588                (setq route (cdr (car ret)))
 589                (setq lal (cdr ret))
 590                (while (and (setq ret (std11-parse-ascii-token lal))
 591                            (setq comma (car ret))
 592                            (string-equal (cdr (assq 'specials comma)) ",")
 593                            (setq ret (std11-parse-at-domain (cdr ret)))
 594                            )
 595                  (setq route (append route comma (cdr (car ret))))
 596                  (setq lal (cdr ret))
 597                  )
 598                (and (setq ret (std11-parse-ascii-token lal))
 599                     (setq colon (car ret))
 600                     (string-equal (cdr (assq 'specials colon)) ":")
 601                     (setq route (append route colon))
 602                     )
 603                ))
 604         (cons (cons 'route route)
 605               (cdr ret)
 606               )
 607       )))
 608
 609 (defun std11-parse-route-addr (lal)
 610   (let ((ret (std11-parse-ascii-token lal))
 611         < route addr-spec >)
 612     (if (and ret
 613              (setq < (car ret))
 614              (string-equal (cdr (assq 'specials <)) "<")
 615              (setq lal (cdr ret))
 616              (progn (and (setq ret (std11-parse-route lal))
 617                          (setq route (cdr (car ret)))
 618                          (setq lal (cdr ret))
 619                          )
 620                     (setq ret (std11-parse-addr-spec lal))
 621                     )
 622              (setq addr-spec (cdr (car ret)))
 623              (setq lal (cdr ret))
 624              (setq ret (std11-parse-ascii-token lal))
 625              (setq > (car ret))
 626              (string-equal (cdr (assq 'specials >)) ">")
 627              )
 628         (cons (cons 'route-addr (append route addr-spec))
 629               (cdr ret)
 630               )
 631       )))
 632
 633 (defun std11-parse-phrase-route-addr (lal)
 634   (let ((ret (std11-parse-phrase lal)) phrase)
 635     (if ret
 636         (progn
 637           (setq phrase (cdr (car ret)))
 638           (setq lal (cdr ret))
 639           ))
 640     (if (setq ret (std11-parse-route-addr lal))
 641         (cons (list 'phrase-route-addr
 642                     phrase
 643                     (cdr (car ret)))
 644               (cdr ret))
 645       )))
 646
 647 (defun std11-parse-mailbox (lal)
 648   (let ((ret (or (std11-parse-phrase-route-addr lal)
 649                  (std11-parse-addr-spec lal)))
 650         mbox comment)
 651     (if (and ret
 652              (prog1
 653                  (setq mbox (car ret))
 654                (setq lal (cdr ret))
 655                (if (and (setq ret (std11-parse-token-or-comment lal))
 656                         (setq comment (cdr (assq 'comment (car ret))))
 657                         )
 658                    (setq lal (cdr ret))
 659                  )))
 660         (cons (list 'mailbox mbox comment)
 661               lal)
 662       )))
 663
 664 (defun std11-parse-group (lal)
 665   (let ((ret (std11-parse-phrase lal))
 666         phrase colon comma mbox semicolon)
 667     (if (and ret
 668              (setq phrase (cdr (car ret)))
 669              (setq lal (cdr ret))
 670              (setq ret (std11-parse-ascii-token lal))
 671              (setq colon (car ret))
 672              (string-equal (cdr (assq 'specials colon)) ":")
 673              (setq lal (cdr ret))
 674              (progn
 675                (and (setq ret (std11-parse-mailbox lal))
 676                     (setq mbox (list (car ret)))
 677                     (setq lal (cdr ret))
 678                     (progn
 679                       (while (and (setq ret (std11-parse-ascii-token lal))
 680                                   (setq comma (car ret))
 681                                   (string-equal
 682                                    (cdr (assq 'specials comma)) ",")
 683                                   (setq lal (cdr ret))
 684                                   (setq ret (std11-parse-mailbox lal))
 685                                   (setq mbox (cons (car ret) mbox))
 686                                   (setq lal (cdr ret))
 687                                   )
 688                         )))
 689                (and (setq ret (std11-parse-ascii-token lal))
 690                     (setq semicolon (car ret))
 691                     (string-equal (cdr (assq 'specials semicolon)) ";")
 692                     )))
 693         (cons (list 'group phrase (nreverse mbox))
 694               (cdr ret)
 695               )
 696       )))
 697
 698 (defun std11-parse-address (lal)
 699   (or (std11-parse-group lal)
 700       (std11-parse-mailbox lal)
 701       ))
 702
 703 (defun std11-parse-addresses (lal)
 704   (let ((ret (std11-parse-address lal)))
 705     (if ret
 706         (let ((dest (list (car ret))))
 707           (setq lal (cdr ret))
 708           (while (and (setq ret (std11-parse-ascii-token lal))
 709                       (string-equal (cdr (assq 'specials (car ret))) ",")
 710                       (setq ret (std11-parse-address (cdr ret)))
 711                       )
 712             (setq dest (cons (car ret) dest))
 713             (setq lal (cdr ret))
 714             )
 715           (nreverse dest)
 716           ))))
 717
 718 (defun std11-parse-msg-id (lal)
 719   (let ((ret (std11-parse-ascii-token lal))
 720         < addr-spec >)
 721     (if (and ret
 722              (setq < (car ret))
 723              (string-equal (cdr (assq 'specials <)) "<")
 724              (setq lal (cdr ret))
 725              (setq ret (std11-parse-addr-spec lal))
 726              (setq addr-spec (car ret))
 727              (setq lal (cdr ret))
 728              (setq ret (std11-parse-ascii-token lal))
 729              (setq > (car ret))
 730              (string-equal (cdr (assq 'specials >)) ">")
 731              )
 732         (cons (cons 'msg-id (cdr addr-spec))
 733               (cdr ret))
 734       )))
 735
 736 (defun std11-parse-msg-ids (tokens)
 737   "Parse lexical TOKENS as `*(phrase / msg-id)', and return the result."
 738   (let ((ret (or (std11-parse-msg-id tokens)
 739                  (std11-parse-phrase tokens))))
 740     (if ret
 741         (let ((dest (list (car ret))))
 742           (setq tokens (cdr ret))
 743           (while (setq ret (or (std11-parse-msg-id tokens)
 744                                (std11-parse-phrase tokens)))
 745             (setq dest (cons (car ret) dest))
 746             (setq tokens (cdr ret))
 747             )
 748           (nreverse dest)
 749           ))))
 750
 751 (defalias 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 752 (make-obsolete 'std11-parse-in-reply-to 'std11-parse-msg-ids)
 753
 754
 755 ;;; @ composer
 756 ;;;
 757
 758 (defun std11-addr-to-string (seq)
 759   "Return string from lexical analyzed list SEQ
 760 represents addr-spec of RFC 822."
 761   (mapconcat (function
 762               (lambda (token)
 763                 (let ((name (car token)))
 764                   (cond
 765                    ((eq name 'spaces) "")
 766                    ((eq name 'comment) "")
 767                    ((eq name 'quoted-string)
 768                     (concat "\"" (cdr token) "\""))
 769                    (t (cdr token)))
 770                   )))
 771              seq "")
 772   )
 773
 774 ;;;###autoload
 775 (defun std11-address-string (address)
 776   "Return string of address part from parsed ADDRESS of RFC 822."
 777   (cond ((eq (car address) 'group)
 778          (mapconcat (function std11-address-string)
 779                     (car (cdr address))
 780                     ", ")
 781          )
 782         ((eq (car address) 'mailbox)
 783          (let ((addr (nth 1 address)))
 784            (std11-addr-to-string
 785             (if (eq (car addr) 'phrase-route-addr)
 786                 (nth 2 addr)
 787               (cdr addr)
 788               )
 789             )))))
 790
 791 (defun std11-comment-value-to-string (value)
 792   (if (stringp value)
 793       (std11-strip-quoted-pair value)
 794     (let ((dest ""))
 795       (while value
 796         (setq dest
 797               (concat dest
 798                       (if (stringp (car value))
 799                           (car value)
 800                         (concat "("
 801                                 (std11-comment-value-to-string
 802                                  (cdr (car value)))
 803                                 ")")
 804                         ))
 805               value (cdr value))
 806         )
 807       dest)))
 808
 809 ;;;###autoload
 810 (defun std11-full-name-string (address)
 811   "Return string of full-name part from parsed ADDRESS of RFC 822."
 812   (cond ((eq (car address) 'group)
 813          (mapconcat (function
 814                      (lambda (token)
 815                        (cdr token)
 816                        ))
 817                     (nth 1 address) "")
 818          )
 819         ((eq (car address) 'mailbox)
 820          (let ((addr (nth 1 address))
 821                (comment (nth 2 address))
 822                phrase)
 823            (if (eq (car addr) 'phrase-route-addr)
 824                (setq phrase
 825                      (mapconcat
 826                       (function
 827                        (lambda (token)
 828                          (let ((type (car token)))
 829                            (cond ((eq type 'quoted-string)
 830                                   (std11-strip-quoted-pair (cdr token))
 831                                   )
 832                                  ((eq type 'comment)
 833                                   (concat "("
 834                                           (std11-comment-value-to-string
 835                                            (cdr token))
 836                                           ")")
 837                                   )
 838                                  (t
 839                                   (cdr token)
 840                                   )))))
 841                       (nth 1 addr) ""))
 842              )
 843            (cond ((> (length phrase) 0) phrase)
 844                  (comment (std11-comment-value-to-string comment))
 845                  )
 846            ))))
 847
 848 ;;;###autoload
 849 (defun std11-msg-id-string (msg-id)
 850   "Return string from parsed MSG-ID of RFC 822."
 851   (concat "<" (std11-addr-to-string (cdr msg-id)) ">")
 852   )
 853
 854 ;;;###autoload
 855 (defun std11-fill-msg-id-list-string (string &optional column)
 856   "Fill list of msg-id in STRING, and return the result."
 857   (or column
 858       (setq column 12))
 859   (let ((lal (std11-lexical-analyze string))
 860         dest)
 861     (let ((ret (std11-parse-msg-id lal)))
 862       (if ret
 863           (let* ((str (std11-msg-id-string (car ret)))
 864                  (len (length str)))
 865             (setq lal (cdr ret))
 866             (if (> (+ len column) 76)
 867                 (setq dest (concat dest "\n " str)
 868                       column (1+ len))
 869               (setq dest str
 870                     column (+ column len))
 871               ))
 872         (setq dest (concat dest (cdr (car lal)))
 873               lal (cdr lal))
 874         ))
 875     (while lal
 876       (let ((ret (std11-parse-msg-id lal)))
 877         (if ret
 878             (let* ((str (std11-msg-id-string (car ret)))
 879                    (len (1+ (length str))))
 880               (setq lal (cdr ret))
 881               (if (> (+ len column) 76)
 882                   (setq dest (concat dest "\n " str)
 883                         column len)
 884                 (setq dest (concat dest " " str)
 885                       column (+ column len))
 886                 ))
 887           (setq dest (concat dest (cdr (car lal)))
 888                 lal (cdr lal))
 889           )))
 890     dest))
 891
 892
 893 ;;; @ parser with lexical analyzer
 894 ;;;
 895
 896 ;;;###autoload
 897 (defun std11-parse-address-string (string)
 898   "Parse STRING as mail address."
 899   (std11-parse-address (std11-lexical-analyze string))
 900   )
 901
 902 ;;;###autoload
 903 (defun std11-parse-addresses-string (string)
 904   "Parse STRING as mail address list."
 905   (std11-parse-addresses (std11-lexical-analyze string))
 906   )
 907
 908 ;;;###autoload
 909 (defun std11-parse-msg-id-string (string)
 910   "Parse STRING as msg-id."
 911   (std11-parse-msg-id (std11-lexical-analyze string))
 912   )
 913
 914 ;;;###autoload
 915 (defun std11-parse-msg-ids-string (string)
 916   "Parse STRING as `*(phrase / msg-id)'."
 917   (std11-parse-msg-ids (std11-lexical-analyze string))
 918   )
 919
 920 ;;;###autoload
 921 (defun std11-extract-address-components (string)
 922   "Extract full name and canonical address from STRING.
 923 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 924 If no name can be extracted, FULL-NAME will be nil."
 925   (let* ((structure (car (std11-parse-address-string
 926                           (std11-unfold-string string))))
 927          (phrase  (std11-full-name-string structure))
 928          (address (std11-address-string structure))
 929          )
 930     (list phrase address)
 931     ))
 932
 933
 934 ;;; @ end
 935 ;;;
 936
 937 (provide 'std11)
 938
 939 ;;; std11.el ends here