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