std11.el

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