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