eword-decode.el

   1 ;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
   6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;         TANAKA Akira <akr@jaist.ac.jp>
   8 ;; Created: 1995/10/03
   9 ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
  10 ;;      Renamed: 1993/06/03 to tiny-mime.el by MORIOKA Tomohiko
  11 ;;      Renamed: 1995/10/03 to tm-ew-d.el (split off encoder)
  12 ;;               by MORIOKA Tomohiko
  13 ;;      Renamed: 1997/02/22 from tm-ew-d.el by MORIOKA Tomohiko
  14 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
  15
  16 ;; This file is part of FLIM (Faithful Library about Internet Message).
  17
  18 ;; This program is free software; you can redistribute it and/or
  19 ;; modify it under the terms of the GNU General Public License as
  20 ;; published by the Free Software Foundation; either version 2, or (at
  21 ;; your option) any later version.
  22
  23 ;; This program is distributed in the hope that it will be useful, but
  24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  26 ;; General Public License for more details.
  27
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  31 ;; Boston, MA 02111-1307, USA.
  32
  33 ;;; Code:
  34
  35 (require 'std11)
  36 (require 'mel)
  37 (require 'mime-def)
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (defgroup eword-decode nil
  42   "Encoded-word decoding"
  43   :group 'mime)
  44
  45 (defcustom eword-max-size-to-decode 1000
  46   "*Max size to decode header field."
  47   :group 'eword-decode
  48   :type '(choice (integer :tag "Limit (bytes)")
  49                  (const :tag "Don't limit" nil)))
  50
  51
  52 ;;; @ MIME encoded-word definition
  53 ;;;
  54
  55 (eval-and-compile
  56   (defconst eword-encoded-text-regexp "[!->@-~]+")
  57
  58   (defconst eword-encoded-word-regexp
  59     (eval-when-compile
  60       (concat (regexp-quote "=?")
  61               "\\("
  62               mime-charset-regexp
  63               "\\)"
  64               (regexp-quote "?")
  65               "\\([BbQq]\\)"
  66               (regexp-quote "?")
  67               "\\("
  68               eword-encoded-text-regexp
  69               "\\)"
  70               (regexp-quote "?="))))
  71   )
  72
  73
  74 ;;; @ for string
  75 ;;;
  76
  77 (defun eword-decode-string (string &optional must-unfold)
  78   "Decode MIME encoded-words in STRING.
  79
  80 STRING is unfolded before decoding.
  81
  82 If an encoded-word is broken or your emacs implementation can not
  83 decode the charset included in it, it is not decoded.
  84
  85 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  86 if there are in decoded encoded-words (generated by bad manner MUA
  87 such as a version of Net$cape)."
  88   (setq string (std11-unfold-string string))
  89   (let ((dest "")(ew nil)
  90         beg end)
  91     (while (and (string-match eword-encoded-word-regexp string)
  92                 (setq beg (match-beginning 0)
  93                       end (match-end 0))
  94                 )
  95       (if (> beg 0)
  96           (if (not
  97                (and (eq ew t)
  98                     (string-match "^[ \t]+$" (substring string 0 beg))
  99                     ))
 100               (setq dest (concat dest (substring string 0 beg)))
 101             )
 102         )
 103       (setq dest
 104             (concat dest
 105                     (eword-decode-encoded-word
 106                      (substring string beg end) must-unfold)
 107                     ))
 108       (setq string (substring string end))
 109       (setq ew t)
 110       )
 111     (concat dest string)
 112     ))
 113
 114 (defun eword-decode-structured-field-body (string
 115                                            &optional start-column max-column
 116                                            start)
 117   (let ((tokens (eword-lexical-analyze string start 'must-unfold))
 118         (result "")
 119         token)
 120     (while tokens
 121       (setq token (car tokens))
 122       (setq result (concat result (eword-decode-token token)))
 123       (setq tokens (cdr tokens)))
 124     result))
 125
 126 (defun eword-decode-and-unfold-structured-field-body (string
 127                                                       &optional
 128                                                       start-column
 129                                                       max-column
 130                                                       start)
 131   "Decode and unfold STRING as structured field body.
 132 It decodes non us-ascii characters in FULL-NAME encoded as
 133 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 134 characters are regarded as variable `default-mime-charset'.
 135
 136 If an encoded-word is broken or your emacs implementation can not
 137 decode the charset included in it, it is not decoded."
 138   (let ((tokens (eword-lexical-analyze string start 'must-unfold))
 139         (result ""))
 140     (while tokens
 141       (let* ((token (car tokens))
 142              (type (car token)))
 143         (setq tokens (cdr tokens))
 144         (setq result
 145               (if (eq type 'spaces)
 146                   (concat result " ")
 147                 (concat result (eword-decode-token token))
 148                 ))))
 149     result))
 150
 151 (defun eword-decode-and-fold-structured-field-body (string
 152                                                     start-column
 153                                                     &optional max-column
 154                                                     start)
 155   (if (and eword-max-size-to-decode
 156            (> (length string) eword-max-size-to-decode))
 157       string
 158     (or max-column
 159         (setq max-column fill-column))
 160     (let ((c start-column)
 161           (tokens (eword-lexical-analyze string start 'must-unfold))
 162           (result "")
 163           token)
 164       (while (and (setq token (car tokens))
 165                   (setq tokens (cdr tokens)))
 166         (let* ((type (car token)))
 167           (if (eq type 'spaces)
 168               (let* ((next-token (car tokens))
 169                      (next-str (eword-decode-token next-token))
 170                      (next-len (string-width next-str))
 171                      (next-c (+ c next-len 1)))
 172                 (if (< next-c max-column)
 173                     (setq result (concat result " " next-str)
 174                           c next-c)
 175                   (setq result (concat result "\n " next-str)
 176                         c (1+ next-len)))
 177                 (setq tokens (cdr tokens))
 178                 )
 179             (let* ((str (eword-decode-token token)))
 180               (setq result (concat result str)
 181                     c (+ c (string-width str)))
 182               ))))
 183       (if token
 184           (concat result (eword-decode-token token))
 185         result))))
 186
 187 (defun eword-decode-unstructured-field-body (string &optional start-column
 188                                                     max-column)
 189   (eword-decode-string
 190    (decode-mime-charset-string string default-mime-charset)))
 191
 192 (defun eword-decode-and-unfold-unstructured-field-body (string
 193                                                         &optional start-column
 194                                                         max-column)
 195   (eword-decode-string
 196    (decode-mime-charset-string (std11-unfold-string string)
 197                                default-mime-charset)
 198    'must-unfold))
 199
 200 (defun eword-decode-unfolded-unstructured-field-body (string
 201                                                       &optional start-column
 202                                                       max-column)
 203   (eword-decode-string
 204    (decode-mime-charset-string string default-mime-charset)
 205    'must-unfold))
 206
 207
 208 ;;; @ for region
 209 ;;;
 210
 211 (defun eword-decode-region (start end &optional unfolding must-unfold)
 212   "Decode MIME encoded-words in region between START and END.
 213
 214 If UNFOLDING is not nil, it unfolds before decoding.
 215
 216 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 217 if there are in decoded encoded-words (generated by bad manner MUA
 218 such as a version of Net$cape)."
 219   (interactive "*r")
 220   (save-excursion
 221     (save-restriction
 222       (narrow-to-region start end)
 223       (if unfolding
 224           (eword-decode-unfold)
 225         )
 226       (goto-char (point-min))
 227       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
 228                                         "\\(\n?[ \t]\\)+"
 229                                         "\\(" eword-encoded-word-regexp "\\)")
 230                                 nil t)
 231         (replace-match "\\1\\6")
 232         (goto-char (point-min))
 233         )
 234       (while (re-search-forward eword-encoded-word-regexp nil t)
 235         (insert (eword-decode-encoded-word
 236                  (prog1
 237                      (buffer-substring (match-beginning 0) (match-end 0))
 238                    (delete-region (match-beginning 0) (match-end 0))
 239                    ) must-unfold))
 240         )
 241       )))
 242
 243 (defun eword-decode-unfold ()
 244   (goto-char (point-min))
 245   (let (field beg end)
 246     (while (re-search-forward std11-field-head-regexp nil t)
 247       (setq beg (match-beginning 0)
 248             end (std11-field-end))
 249       (setq field (buffer-substring beg end))
 250       (if (string-match eword-encoded-word-regexp field)
 251           (save-restriction
 252             (narrow-to-region (goto-char beg) end)
 253             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 254               (replace-match (match-string 1))
 255               )
 256             (goto-char (point-max))
 257             ))
 258       )))
 259
 260
 261 ;;; @ for message header
 262 ;;;
 263
 264 (defvar mime-field-decoder-alist nil)
 265
 266 (defvar mime-field-decoder-cache nil)
 267
 268 (defvar mime-update-field-decoder-cache 'mime-update-field-decoder-cache
 269   "*Field decoder cache update function.")
 270
 271 ;;;###autoload
 272 (defun mime-set-field-decoder (field &rest specs)
 273   "Set decoder of FILED.
 274 SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
 275 Each mode must be `nil', `plain', `wide', `summary' or `nov'.
 276 If mode is `nil', corresponding decoder is set up for every modes."
 277   (when specs
 278     (let ((mode (pop specs))
 279           (function (pop specs)))
 280       (if mode
 281           (progn
 282             (let ((cell (assq mode mime-field-decoder-alist)))
 283               (if cell
 284                   (setcdr cell (put-alist field function (cdr cell)))
 285                 (setq mime-field-decoder-alist
 286                       (cons (cons mode (list (cons field function)))
 287                             mime-field-decoder-alist))
 288                 ))
 289             (apply (function mime-set-field-decoder) field specs)
 290             )
 291         (mime-set-field-decoder field
 292                                 'plain function
 293                                 'wide function
 294                                 'summary function
 295                                 'nov function)
 296         ))))
 297
 298 ;;;###autoload
 299 (defmacro mime-find-field-presentation-method (name)
 300   "Return field-presentation-method from NAME.
 301 NAME must be `plain', `wide', `summary' or `nov'."
 302   (cond ((eq name nil)
 303          `(or (assq 'summary mime-field-decoder-cache)
 304               '(summary))
 305          )
 306         ((and (consp name)
 307               (car name)
 308               (consp (cdr name))
 309               (symbolp (car (cdr name)))
 310               (null (cdr (cdr name))))
 311          `(or (assq ,name mime-field-decoder-cache)
 312               (cons ,name nil))
 313          )
 314         (t
 315          `(or (assq (or ,name 'summary) mime-field-decoder-cache)
 316               (cons (or ,name 'summary) nil))
 317          )))
 318
 319 (defun mime-find-field-decoder-internal (field &optional mode)
 320   "Return function to decode field-body of FIELD in MODE.
 321 Optional argument MODE must be object of field-presentation-method."
 322   (cdr (or (assq field (cdr mode))
 323            (prog1
 324                (funcall mime-update-field-decoder-cache
 325                         field (car mode))
 326              (setcdr mode
 327                      (cdr (assq (car mode) mime-field-decoder-cache)))
 328              ))))
 329
 330 ;;;###autoload
 331 (defun mime-find-field-decoder (field &optional mode)
 332   "Return function to decode field-body of FIELD in MODE.
 333 Optional argument MODE must be object or name of
 334 field-presentation-method.  Name of field-presentation-method must be
 335 `plain', `wide', `summary' or `nov'.
 336 Default value of MODE is `summary'."
 337   (if (symbolp mode)
 338       (let ((p (cdr (mime-find-field-presentation-method mode))))
 339         (if (and p (setq p (assq field p)))
 340             (cdr p)
 341           (cdr (funcall mime-update-field-decoder-cache
 342                         field (or mode 'summary)))))
 343     (inline (mime-find-field-decoder-internal field mode))
 344     ))
 345
 346 ;;;###autoload
 347 (defun mime-update-field-decoder-cache (field mode &optional function)
 348   "Update field decoder cache `mime-field-decoder-cache'."
 349   (cond ((eq function 'identity)
 350          (setq function nil)
 351          )
 352         ((null function)
 353          (let ((decoder-alist
 354                 (cdr (assq (or mode 'summary) mime-field-decoder-alist))))
 355            (setq function (cdr (or (assq field decoder-alist)
 356                                    (assq t decoder-alist)))))
 357          ))
 358   (let ((cell (assq mode mime-field-decoder-cache))
 359         ret)
 360     (if cell
 361         (if (setq ret (assq field (cdr cell)))
 362             (setcdr ret function)
 363           (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
 364       (setq mime-field-decoder-cache
 365             (cons (cons mode (list (setq ret (cons field function))))
 366                   mime-field-decoder-cache)))
 367     ret))
 368
 369 ;; ignored fields
 370 (mime-set-field-decoder 'Archive                nil nil)
 371 (mime-set-field-decoder 'Content-Md5            nil nil)
 372 (mime-set-field-decoder 'Control                nil nil)
 373 (mime-set-field-decoder 'Date                   nil nil)
 374 (mime-set-field-decoder 'Distribution           nil nil)
 375 (mime-set-field-decoder 'Followup-Host          nil nil)
 376 (mime-set-field-decoder 'Followup-To            nil nil)
 377 (mime-set-field-decoder 'Lines                  nil nil)
 378 (mime-set-field-decoder 'Message-Id             nil nil)
 379 (mime-set-field-decoder 'Newsgroups             nil nil)
 380 (mime-set-field-decoder 'Nntp-Posting-Host      nil nil)
 381 (mime-set-field-decoder 'Path                   nil nil)
 382 (mime-set-field-decoder 'Posted-And-Mailed      nil nil)
 383 (mime-set-field-decoder 'Received               nil nil)
 384 (mime-set-field-decoder 'Status                 nil nil)
 385 (mime-set-field-decoder 'X-Face                 nil nil)
 386 (mime-set-field-decoder 'X-Face-Version         nil nil)
 387 (mime-set-field-decoder 'X-Info                 nil nil)
 388 (mime-set-field-decoder 'X-Pgp-Key-Info         nil nil)
 389 (mime-set-field-decoder 'X-Pgp-Sig              nil nil)
 390 (mime-set-field-decoder 'X-Pgp-Sig-Version      nil nil)
 391 (mime-set-field-decoder 'Xref                   nil nil)
 392
 393 ;; structured fields
 394 (let ((fields
 395        '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
 396          To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
 397          Mail-Followup-To
 398          Mime-Version Content-Type Content-Transfer-Encoding
 399          Content-Disposition User-Agent))
 400       field)
 401   (while fields
 402     (setq field (pop fields))
 403     (mime-set-field-decoder
 404      field
 405      'plain     #'eword-decode-structured-field-body
 406      'wide      #'eword-decode-and-fold-structured-field-body
 407      'summary   #'eword-decode-and-unfold-structured-field-body
 408      'nov       #'eword-decode-and-unfold-structured-field-body)
 409     ))
 410
 411 ;; unstructured fields (default)
 412 (mime-set-field-decoder
 413  t
 414  'plain #'eword-decode-unstructured-field-body
 415  'wide  #'eword-decode-unstructured-field-body
 416  'summary #'eword-decode-and-unfold-unstructured-field-body
 417  'nov   #'eword-decode-unfolded-unstructured-field-body)
 418
 419 ;;;###autoload
 420 (defun mime-decode-field-body (field-body field-name
 421                                           &optional mode max-column)
 422   "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
 423 Optional argument MODE must be `plain', `wide', `summary' or `nov'.
 424 Default mode is `summary'.
 425
 426 If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
 427 MAX-COLUMN.
 428
 429 Non MIME encoded-word part in FILED-BODY is decoded with
 430 `default-mime-charset'."
 431   (let (field-name-symbol len decoder)
 432     (if (symbolp field-name)
 433         (setq field-name-symbol field-name
 434               len (1+ (string-width (symbol-name field-name))))
 435       (setq field-name-symbol (intern (capitalize field-name))
 436             len (1+ (string-width field-name))))
 437     (setq decoder (mime-find-field-decoder field-name-symbol mode))
 438     (if decoder
 439         (funcall decoder field-body len max-column)
 440       ;; Don't decode
 441       (if (eq mode 'summary)
 442           (std11-unfold-string field-body)
 443         field-body)
 444       )))
 445
 446 ;;;###autoload
 447 (defun mime-decode-header-in-region (start end
 448                                            &optional code-conversion)
 449   "Decode MIME encoded-words in region between START and END.
 450 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 451 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 452 Otherwise it decodes non-ASCII bit patterns as the
 453 default-mime-charset."
 454   (interactive "*r")
 455   (save-excursion
 456     (save-restriction
 457       (narrow-to-region start end)
 458       (let ((default-charset
 459               (if code-conversion
 460                   (if (mime-charset-to-coding-system code-conversion)
 461                       code-conversion
 462                     default-mime-charset))))
 463         (if default-charset
 464             (let ((mode-obj (mime-find-field-presentation-method 'wide))
 465                   beg p end field-name len field-decoder)
 466               (goto-char (point-min))
 467               (while (re-search-forward std11-field-head-regexp nil t)
 468                 (setq beg (match-beginning 0)
 469                       p (match-end 0)
 470                       field-name (buffer-substring beg (1- p))
 471                       len (string-width field-name)
 472                       field-name (intern (capitalize field-name))
 473                       field-decoder (inline
 474                                       (mime-find-field-decoder-internal
 475                                        field-name mode-obj)))
 476                 (when field-decoder
 477                   (setq end (std11-field-end))
 478                   (let ((body (buffer-substring p end))
 479                         (default-mime-charset default-charset))
 480                     (delete-region p end)
 481                     (insert (funcall field-decoder body (1+ len)))
 482                     ))
 483                 ))
 484           (eword-decode-region (point-min) (point-max) t)
 485           )))))
 486
 487 ;;;###autoload
 488 (defun mime-decode-header-in-buffer (&optional code-conversion separator)
 489   "Decode MIME encoded-words in header fields.
 490 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 491 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 492 Otherwise it decodes non-ASCII bit patterns as the
 493 default-mime-charset.
 494 If SEPARATOR is not nil, it is used as header separator."
 495   (interactive "*")
 496   (mime-decode-header-in-region
 497    (point-min)
 498    (save-excursion
 499      (goto-char (point-min))
 500      (if (re-search-forward
 501           (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
 502           nil t)
 503          (match-beginning 0)
 504        (point-max)
 505        ))
 506    code-conversion))
 507
 508 (define-obsolete-function-alias 'eword-decode-header
 509   'mime-decode-header-in-buffer)
 510
 511
 512 ;;; @ encoded-word decoder
 513 ;;;
 514
 515 (defvar eword-decode-encoded-word-error-handler
 516   'eword-decode-encoded-word-default-error-handler)
 517
 518 (defvar eword-warning-face nil
 519   "Face used for invalid encoded-word.")
 520
 521 (defun eword-decode-encoded-word-default-error-handler (word signal)
 522   (and (add-text-properties 0 (length word)
 523                             (and eword-warning-face
 524                                  (list 'face eword-warning-face))
 525                             word)
 526        word))
 527
 528 (defun eword-decode-encoded-word (word &optional must-unfold)
 529   "Decode WORD if it is an encoded-word.
 530
 531 If your emacs implementation can not decode the charset of WORD, it
 532 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 533
 534 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 535 if there are in decoded encoded-word (generated by bad manner MUA such
 536 as a version of Net$cape)."
 537   (or (if (string-match eword-encoded-word-regexp word)
 538           (let ((charset
 539                  (substring word (match-beginning 1) (match-end 1))
 540                  )
 541                 (encoding
 542                  (upcase
 543                   (substring word (match-beginning 2) (match-end 2))
 544                   ))
 545                 (text
 546                  (substring word (match-beginning 3) (match-end 3))
 547                  ))
 548             (condition-case err
 549                 (eword-decode-encoded-text charset encoding text must-unfold)
 550               (error
 551                (funcall eword-decode-encoded-word-error-handler word err)
 552                ))
 553             ))
 554       word))
 555
 556
 557 ;;; @ encoded-text decoder
 558 ;;;
 559
 560 (defun eword-decode-encoded-text (charset encoding string
 561                                           &optional must-unfold)
 562   "Decode STRING as an encoded-text.
 563
 564 If your emacs implementation can not decode CHARSET, it returns nil.
 565
 566 If ENCODING is not \"B\" or \"Q\", it occurs error.
 567 So you should write error-handling code if you don't want break by errors.
 568
 569 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 570 if there are in decoded encoded-text (generated by bad manner MUA such
 571 as a version of Net$cape)."
 572   (let ((cs (mime-charset-to-coding-system charset)))
 573     (if cs
 574         (let ((dest (encoded-text-decode-string string encoding)))
 575           (when dest
 576             (setq dest (decode-mime-charset-string dest charset))
 577             (if must-unfold
 578                 (mapconcat (function
 579                             (lambda (chr)
 580                               (cond ((eq chr ?\n) "")
 581                                     ((eq chr ?\t) " ")
 582                                     (t (char-to-string chr)))
 583                               ))
 584                            (std11-unfold-string dest)
 585                            "")
 586               dest))))))
 587
 588
 589 ;;; @ lexical analyze
 590 ;;;
 591
 592 (defvar eword-lexical-analyze-cache nil)
 593 (defvar eword-lexical-analyze-cache-max 299
 594   "*Max position of eword-lexical-analyze-cache.
 595 It is max size of eword-lexical-analyze-cache - 1.")
 596
 597 (defcustom eword-lexical-analyzer
 598   '(eword-analyze-quoted-string
 599     eword-analyze-domain-literal
 600     eword-analyze-comment
 601     eword-analyze-spaces
 602     eword-analyze-special
 603     eword-analyze-encoded-word
 604     eword-analyze-atom)
 605   "*List of functions to return result of lexical analyze.
 606 Each function must have three arguments: STRING, START and MUST-UNFOLD.
 607 STRING is the target string to be analyzed.
 608 START is start position of STRING to analyze.
 609 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 610 bare-CR and bare-LF from the result even if they are included in
 611 content of the encoded-word.
 612 Each function must return nil if it can not analyze STRING as its
 613 format.
 614
 615 Previous function is preferred to next function.  If a function
 616 returns nil, next function is used.  Otherwise the return value will
 617 be the result."
 618   :group 'eword-decode
 619   :type '(repeat function))
 620
 621 (defun eword-analyze-quoted-string (string start &optional must-unfold)
 622   (let ((p (std11-check-enclosure string ?\" ?\" nil start)))
 623     (if p
 624         (cons (cons 'quoted-string
 625                     (decode-mime-charset-string
 626                      (std11-strip-quoted-pair
 627                       (substring string (1+ start) (1- p)))
 628                      default-mime-charset))
 629               ;;(substring string p))
 630               p)
 631       )))
 632
 633 (defun eword-analyze-domain-literal (string start &optional must-unfold)
 634   (std11-analyze-domain-literal string start))
 635
 636 (defun eword-analyze-comment (string from &optional must-unfold)
 637   (let ((len (length string))
 638         (i (or from 0))
 639         dest last-str
 640         chr ret)
 641     (when (and (> len i)
 642                (eq (aref string i) ?\())
 643       (setq i (1+ i)
 644             from i)
 645       (catch 'tag
 646         (while (< i len)
 647           (setq chr (aref string i))
 648           (cond ((eq chr ?\\)
 649                  (setq i (1+ i))
 650                  (if (>= i len)
 651                      (throw 'tag nil)
 652                    )
 653                  (setq last-str (concat last-str
 654                                         (substring string from (1- i))
 655                                         (char-to-string (aref string i)))
 656                        i (1+ i)
 657                        from i)
 658                  )
 659                 ((eq chr ?\))
 660                  (setq ret (concat last-str
 661                                    (substring string from i)))
 662                  (throw 'tag (cons
 663                               (cons 'comment
 664                                     (nreverse
 665                                      (if (string= ret "")
 666                                          dest
 667                                        (cons
 668                                         (eword-decode-string
 669                                          (decode-mime-charset-string
 670                                           ret default-mime-charset)
 671                                          must-unfold)
 672                                         dest)
 673                                        )))
 674                               (1+ i)))
 675                  )
 676                 ((eq chr ?\()
 677                  (if (setq ret (eword-analyze-comment string i must-unfold))
 678                      (setq last-str
 679                            (concat last-str
 680                                    (substring string from i))
 681                            dest
 682                            (if (string= last-str "")
 683                                (cons (car ret) dest)
 684                              (list* (car ret)
 685                                     (eword-decode-string
 686                                      (decode-mime-charset-string
 687                                       last-str default-mime-charset)
 688                                      must-unfold)
 689                                     dest)
 690                              )
 691                            i (cdr ret)
 692                            from i
 693                            last-str "")
 694                    (throw 'tag nil)
 695                    ))
 696                 (t
 697                  (setq i (1+ i))
 698                  ))
 699           )))))
 700
 701 (defun eword-analyze-spaces (string start &optional must-unfold)
 702   (std11-analyze-spaces string start))
 703
 704 (defun eword-analyze-special (string start &optional must-unfold)
 705   (std11-analyze-special string start))
 706
 707 (defun eword-analyze-encoded-word (string start &optional must-unfold)
 708   (if (and (string-match eword-encoded-word-regexp string start)
 709            (= (match-beginning 0) start))
 710       (let ((end (match-end 0))
 711             (dest (eword-decode-encoded-word (match-string 0 string)
 712                                              must-unfold))
 713             )
 714         ;;(setq string (substring string end))
 715         (setq start end)
 716         (while (and (string-match (eval-when-compile
 717                                     (concat "[ \t\n]*\\("
 718                                             eword-encoded-word-regexp
 719                                             "\\)"))
 720                                   string start)
 721                     (= (match-beginning 0) start))
 722           (setq end (match-end 0))
 723           (setq dest
 724                 (concat dest
 725                         (eword-decode-encoded-word (match-string 1 string)
 726                                                    must-unfold))
 727                 ;;string (substring string end))
 728                 start end)
 729           )
 730         (cons (cons 'atom dest) ;;string)
 731               end)
 732         )))
 733
 734 (defun eword-analyze-atom (string start &optional must-unfold)
 735   (if (and (string-match std11-atom-regexp string start)
 736            (= (match-beginning 0) start))
 737       (let ((end (match-end 0)))
 738         (cons (cons 'atom (decode-mime-charset-string
 739                            (substring string start end)
 740                            default-mime-charset))
 741               ;;(substring string end)
 742               end)
 743         )))
 744
 745 (defun eword-lexical-analyze-internal (string start must-unfold)
 746   (let ((len (length string))
 747         dest ret)
 748     (while (< start len)
 749       (setq ret
 750             (let ((rest eword-lexical-analyzer)
 751                   func r)
 752               (while (and (setq func (car rest))
 753                           (null
 754                            (setq r (funcall func string start must-unfold)))
 755                           )
 756                 (setq rest (cdr rest)))
 757               (or r
 758                   (list (cons 'error (substring string start)) (1+ len)))
 759               ))
 760       (setq dest (cons (car ret) dest)
 761             start (cdr ret))
 762       )
 763     (nreverse dest)
 764     ))
 765
 766 (defun eword-lexical-analyze (string &optional start must-unfold)
 767   "Return lexical analyzed list corresponding STRING.
 768 It is like std11-lexical-analyze, but it decodes non us-ascii
 769 characters encoded as encoded-words or invalid \"raw\" format.
 770 \"Raw\" non us-ascii characters are regarded as variable
 771 `default-mime-charset'."
 772   (let ((key (substring string (or start 0)))
 773         ret cell)
 774     (set-text-properties 0 (length key) nil key)
 775     (if (setq ret (assoc key eword-lexical-analyze-cache))
 776         (cdr ret)
 777       (setq ret (eword-lexical-analyze-internal key 0 must-unfold))
 778       (setq eword-lexical-analyze-cache
 779             (cons (cons key ret)
 780                   eword-lexical-analyze-cache))
 781       (if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max
 782                                   eword-lexical-analyze-cache)))
 783           (setcdr cell nil))
 784       ret)))
 785
 786 (defun eword-decode-token (token)
 787   (let ((type (car token))
 788         (value (cdr token)))
 789     (cond ((eq type 'quoted-string)
 790            (std11-wrap-as-quoted-string value))
 791           ((eq type 'comment)
 792            (let ((dest ""))
 793              (while value
 794                (setq dest (concat dest
 795                                   (if (stringp (car value))
 796                                       (std11-wrap-as-quoted-pairs
 797                                        (car value) '(?( ?)))
 798                                     (eword-decode-token (car value))
 799                                     ))
 800                      value (cdr value))
 801                )
 802              (concat "(" dest ")")
 803              ))
 804           (t value))))
 805
 806 (defun eword-extract-address-components (string &optional start)
 807   "Extract full name and canonical address from STRING.
 808 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 809 If no name can be extracted, FULL-NAME will be nil.
 810 It decodes non us-ascii characters in FULL-NAME encoded as
 811 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 812 characters are regarded as variable `default-mime-charset'."
 813   (let* ((structure (car (std11-parse-address
 814                           (eword-lexical-analyze
 815                            (std11-unfold-string string) start
 816                            'must-unfold))))
 817          (phrase  (std11-full-name-string structure))
 818          (address (std11-address-string structure))
 819          )
 820     (list phrase address)
 821     ))
 822
 823
 824 ;;; @ end
 825 ;;;
 826
 827 (provide 'eword-decode)
 828
 829 ;;; eword-decode.el ends here