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