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