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