eword-decode.el

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