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