mime/eword-decode.el

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