std11.el

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