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