eword-decode.el

   1 ;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
   6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;         Tanaka Akira <akr@jaist.ac.jp>
   8 ;; Maintainer: Tanaka Akira <akr@jaist.ac.jp>
   9 ;; Created: 1995/10/03
  10 ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
  11 ;;      Renamed: 1993/06/03 to tiny-mime.el
  12 ;;      Renamed: 1995/10/03 from tiny-mime.el (split off encoder)
  13 ;;      Renamed: 1997/02/22 from tm-ew-d.el
  14 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
  15
  16 ;; This file is part of FLAM (Faithful Library About MIME).
  17
  18 ;; This program is free software; you can redistribute it and/or
  19 ;; modify it under the terms of the GNU General Public License as
  20 ;; published by the Free Software Foundation; either version 2, or (at
  21 ;; your option) any later version.
  22
  23 ;; This program is distributed in the hope that it will be useful, but
  24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  26 ;; General Public License for more details.
  27
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  31 ;; Boston, MA 02111-1307, USA.
  32
  33 ;;; Code:
  34
  35 (require 'std11)
  36 (require 'mel)
  37 (require 'mime-def)
  38
  39 (require 'ew-dec)
  40 (require 'ew-line)
  41
  42 (eval-when-compile (require 'cl))
  43
  44 (defgroup eword-decode nil
  45   "Encoded-word decoding"
  46   :group 'mime)
  47
  48 ;;; TEST
  49
  50 (defvar rotate-memo nil)
  51 (defmacro rotate-memo (var val)
  52   `(when rotate-memo
  53      (unless (boundp ',var) (setq ,var ()))
  54      (setq ,var (cons ,val ,var))
  55      (let ((tmp (last ,var (- (length ,var) 100))))
  56        (when tmp (setcdr tmp nil)))
  57      ,var))
  58
  59 ;;; @ variables
  60 ;;;
  61
  62 (defcustom eword-decode-sticked-encoded-word nil
  63   "*If non-nil, decode encoded-words sticked on atoms,
  64 other encoded-words, etc.
  65 however this behaviour violates RFC2047."
  66   :group 'eword-decode
  67   :type 'boolean)
  68
  69 (defcustom eword-decode-quoted-encoded-word nil
  70   "*If non-nil, decode encoded-words in quoted-string
  71 however this behaviour violates RFC2047."
  72   :group 'eword-decode
  73   :type 'boolean)
  74
  75 (defcustom eword-max-size-to-decode 1000
  76   "*Max size to decode header field."
  77   :group 'eword-decode
  78   :type '(choice (integer :tag "Limit (bytes)")
  79                  (const :tag "Don't limit" nil)))
  80
  81
  82 ;;; @ MIME encoded-word definition
  83 ;;;
  84
  85 (defconst eword-encoded-word-prefix-regexp
  86   (concat (regexp-quote "=?")
  87           "\\(" mime-charset-regexp "\\)"
  88           (regexp-quote "?")
  89           "\\(B\\|Q\\)"
  90           (regexp-quote "?")))
  91 (defconst eword-encoded-word-suffix-regexp
  92   (regexp-quote "?="))
  93
  94 (defconst eword-encoded-text-in-unstructured-regexp "[!->@-~]+")
  95 (defconst eword-encoded-word-in-unstructured-regexp
  96   (concat eword-encoded-word-prefix-regexp
  97           "\\(" eword-encoded-text-in-unstructured-regexp "\\)"
  98           eword-encoded-word-suffix-regexp))
  99 (defconst eword-after-encoded-word-in-unstructured-regexp "\\([ \t]\\|$\\)")
 100
 101 (defconst eword-encoded-text-in-phrase-regexp "[-A-Za-z0-9!*+/=_]+")
 102 (defconst eword-encoded-word-in-phrase-regexp
 103   (concat eword-encoded-word-prefix-regexp
 104           "\\(" eword-encoded-text-in-phrase-regexp "\\)"
 105           eword-encoded-word-suffix-regexp))
 106 (defconst eword-after-encoded-word-in-phrase-regexp "\\([ \t]\\|$\\)")
 107
 108 (defconst eword-encoded-text-in-comment-regexp "[]!-'*->@-[^-~]+")
 109 (defconst eword-encoded-word-in-comment-regexp
 110   (concat eword-encoded-word-prefix-regexp
 111           "\\(" eword-encoded-text-in-comment-regexp "\\)"
 112           eword-encoded-word-suffix-regexp))
 113 (defconst eword-after-encoded-word-in-comment-regexp "\\([ \t()\\\\]\\|$\\)")
 114
 115 (defconst eword-encoded-text-in-quoted-string-regexp "[]!#->@-[^-~]+")
 116 (defconst eword-encoded-word-in-quoted-string-regexp
 117   (concat eword-encoded-word-prefix-regexp
 118           "\\(" eword-encoded-text-in-quoted-string-regexp "\\)"
 119           eword-encoded-word-suffix-regexp))
 120 (defconst eword-after-encoded-word-in-quoted-string-regexp "\\([ \t\"\\\\]\\|$\\)")
 121
 122 ; obsolete
 123 (defconst eword-encoded-text-regexp eword-encoded-text-in-unstructured-regexp)
 124 (defconst eword-encoded-word-regexp eword-encoded-word-in-unstructured-regexp)
 125
 126
 127 ;;; @ internal utilities
 128 ;;;
 129
 130 (defun eword-decode-first-encoded-words (string
 131                                          eword-regexp
 132                                          after-regexp
 133                                          &optional must-unfold)
 134   "Decode MIME encoded-words in beginning of STRING.
 135
 136 EWORD-REGEXP is the regexp that matches a encoded-word.
 137 Usual value is
 138 eword-encoded-word-in-unstructured-regexp,
 139 eword-encoded-text-in-phrase-regexp,
 140 eword-encoded-word-in-comment-regexp or
 141 eword-encoded-word-in-quoted-string-regexp.
 142
 143 AFTER-REGEXP is the regexp that matches a after encoded-word.
 144 Usual value is
 145 eword-after-encoded-word-in-unstructured-regexp,
 146 eword-after-encoded-text-in-phrase-regexp,
 147 eword-after-encoded-word-in-comment-regexp or
 148 eword-after-encoded-word-in-quoted-string-regexp.
 149
 150 If beginning of STRING matches EWORD-REGEXP with AFTER-REGEXP,
 151 returns a cons cell of decoded string(sequence of characters) and
 152 the rest(sequence of octets).
 153
 154 If beginning of STRING does not matches EWORD-REGEXP and AFTER-REGEXP,
 155 returns nil.
 156
 157 If an encoded-word is broken or your emacs implementation can not
 158 decode the charset included in it, it is returned in decoded part
 159 as encoded-word form.
 160
 161 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 162 if there are in decoded encoded-words (generated by bad manner MUA
 163 such as a version of Net$cape)."
 164   (if eword-decode-sticked-encoded-word (setq after-regexp ""))
 165   (let* ((between-ewords-regexp
 166            (if eword-decode-sticked-encoded-word
 167              "\\(\n?[ \t]\\)*"
 168              "\\(\n?[ \t]\\)+"))
 169          (between-ewords-eword-after-regexp
 170            (concat "\\`\\(" between-ewords-regexp "\\)"
 171                       "\\(" eword-regexp "\\)"
 172                       after-regexp))
 173          (eword-after-regexp
 174            (concat "\\`\\(" eword-regexp "\\)" after-regexp))
 175          (src string)   ; sequence of octets.
 176          (dst ""))      ; sequence of characters.
 177     (if (string-match eword-after-regexp src)
 178       (let* (p
 179              (q (match-end 1))
 180              (ew (substring src 0 q))
 181              (dw (eword-decode-encoded-word ew must-unfold)))
 182         (setq dst (concat dst dw)
 183               src (substring src q))
 184         (if (not (string= ew dw))
 185           (progn
 186             (while
 187               (and
 188                 (string-match between-ewords-eword-after-regexp src)
 189                 (progn
 190                   (setq p (match-end 1)
 191                         q (match-end 3)
 192                         ew (substring src p q)
 193                         dw (eword-decode-encoded-word ew must-unfold))
 194                   (if (string= ew dw)
 195                     (progn
 196                       (setq dst (concat dst (substring src 0 q))
 197                             src (substring src q))
 198                       nil)
 199                     t)))
 200               (setq dst (concat dst dw)
 201                     src (substring src q)))))
 202         (cons dst src))
 203       nil)))
 204
 205 (defun eword-decode-entire-string (string
 206                                    eword-regexp
 207                                    after-regexp
 208                                    safe-regexp
 209                                    escape ; ?\\ or nil.
 210                                    delimiters ; list of chars.
 211                                    chars-must-be-quote
 212                                    must-unfold
 213                                    code-conversion)
 214   (if (and code-conversion
 215            (not (mime-charset-to-coding-system code-conversion)))
 216       (setq code-conversion default-mime-charset))
 217   (let ((equal-safe-regexp (concat "\\`=?" safe-regexp))
 218         (dst "")
 219         (buf "")
 220         (src string)
 221         (ew-enable t))
 222     (while (< 0 (length src))
 223       (let ((ch (aref src 0))
 224             (decoded (and
 225                         ew-enable
 226                         (eword-decode-first-encoded-words src
 227                           eword-regexp after-regexp must-unfold))))
 228         (if (and (not (string= buf ""))
 229                  (or decoded (memq ch delimiters)))
 230           (setq dst (concat dst
 231                       (std11-wrap-as-quoted-pairs
 232                         (decode-mime-charset-string buf code-conversion)
 233                         chars-must-be-quote))
 234                 buf ""))
 235         (cond
 236           (decoded
 237             (setq dst (concat dst
 238                         (std11-wrap-as-quoted-pairs
 239                           (car decoded)
 240                           chars-must-be-quote))
 241                   src (cdr decoded)))
 242           ((memq ch delimiters)
 243             (setq dst (concat dst (list ch))
 244                   src (substring src 1)
 245                   ew-enable t))
 246           ((eq ch escape)
 247             (setq buf (concat buf (list (aref src 1)))
 248                   src (substring src 2)
 249                   ew-enable t))
 250           ((string-match "\\`[ \t\n]+" src)
 251             (setq buf (concat buf (substring src 0 (match-end 0)))
 252                   src (substring src (match-end 0))
 253                   ew-enable t))
 254           ((and (string-match equal-safe-regexp src)
 255                 (< 0 (match-end 0)))
 256             (setq buf (concat buf (substring src 0 (match-end 0)))
 257                   src (substring src (match-end 0))
 258                   ew-enable eword-decode-sticked-encoded-word))
 259           (t (error "something wrong")))))
 260     (if (not (string= buf ""))
 261       (setq dst (concat dst
 262                   (std11-wrap-as-quoted-pairs
 263                     (decode-mime-charset-string buf code-conversion)
 264                     chars-must-be-quote))))
 265     dst))
 266
 267
 268 ;;; @ for string
 269 ;;;
 270
 271 (defun eword-decode-unstructured (string code-conversion &optional must-unfold)
 272   (eword-decode-entire-string
 273     string
 274     eword-encoded-word-in-unstructured-regexp
 275     eword-after-encoded-word-in-unstructured-regexp
 276     "[^ \t\n=]*"
 277     nil
 278     nil
 279     nil
 280     must-unfold
 281     code-conversion))
 282
 283 (defun eword-decode-comment (string code-conversion &optional must-unfold)
 284   (eword-decode-entire-string
 285     string
 286     eword-encoded-word-in-comment-regexp
 287     eword-after-encoded-word-in-comment-regexp
 288     "[^ \t\n()\\\\=]*"
 289     ?\\
 290     '(?\( ?\))
 291     '(?\( ?\) ?\\ ?\r ?\n)
 292     must-unfold
 293     code-conversion))
 294
 295 (defun eword-decode-quoted-string (string code-conversion &optional must-unfold)
 296   (eword-decode-entire-string
 297     string
 298     eword-encoded-word-in-quoted-string-regexp
 299     eword-after-encoded-word-in-quoted-string-regexp
 300     "[^ \t\n\"\\\\=]*"
 301     ?\\
 302     '(?\")
 303     '(?\" ?\\ ?\r ?\n)
 304     must-unfold
 305     code-conversion))
 306
 307 (defun eword-decode-string (string &optional must-unfold code-conversion)
 308   "Decode MIME encoded-words in STRING.
 309
 310 STRING is unfolded before decoding.
 311
 312 If an encoded-word is broken or your emacs implementation can not
 313 decode the charset included in it, it is not decoded.
 314
 315 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 316 if there are in decoded encoded-words (generated by bad manner MUA
 317 such as a version of Net$cape).
 318
 319 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 320 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 321 Otherwise it decodes non-ASCII bit patterns as the
 322 default-mime-charset."
 323   (eword-decode-unstructured
 324     (std11-unfold-string string)
 325     code-conversion
 326     must-unfold))
 327
 328 (defun eword-decode-structured-field-body (string
 329                                            &optional
 330                                            start-column max-column)
 331   (let* ((ew-decode-field-default-syntax '(ew-scan-unibyte-std11))
 332          (decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
 333     (ew-crlf-to-lf decoded)))
 334
 335 (defun eword-decode-and-unfold-structured-field-body (string
 336                                                       &optional
 337                                                       start-column
 338                                                       max-column)
 339   "Decode and unfold STRING as structured field body.
 340 It decodes non us-ascii characters in FULL-NAME encoded as
 341 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 342 characters are regarded as variable `default-mime-charset'.
 343
 344 If an encoded-word is broken or your emacs implementation can not
 345 decode the charset included in it, it is not decoded."
 346   (let* ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
 347     (ew-crlf-to-lf (ew-crlf-unfold decoded))))
 348
 349 (defun eword-decode-and-fold-structured-field-body (string
 350                                                     start-column
 351                                                     &optional max-column)
 352   (or max-column
 353       (setq max-column fill-column))
 354   (let* ((field-name (make-string (1- start-column) ?X))
 355          (field-body (ew-lf-crlf-to-crlf string))
 356          (ew-decode-field-default-syntax '(ew-scan-unibyte-std11))
 357          (decoded (ew-decode-field field-name field-body)))
 358     (unless (equal field-body decoded)
 359       (setq decoded (ew-crlf-refold decoded start-column max-column)))
 360     (ew-crlf-to-lf decoded)))
 361
 362 (defun eword-decode-unstructured-field-body (string &optional start-column
 363                                                     max-column)
 364   (let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
 365     (ew-crlf-to-lf decoded)))
 366
 367 (defun eword-decode-and-unfold-unstructured-field-body (string
 368                                                         &optional start-column
 369                                                         max-column)
 370   (let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
 371     (ew-crlf-to-lf (ew-crlf-unfold decoded))))
 372
 373 (defun eword-decode-unfolded-unstructured-field-body (string
 374                                                       &optional start-column
 375                                                       max-column)
 376   (let ((decoded (ew-decode-field "" (ew-lf-crlf-to-crlf string))))
 377     (ew-crlf-to-lf decoded)))
 378
 379
 380 ;;; @ for region
 381 ;;;
 382
 383 (defun eword-decode-region (start end &optional unfolding must-unfold
 384                                                 code-conversion)
 385   "Decode MIME encoded-words in region between START and END.
 386
 387 If UNFOLDING is not nil, it unfolds before decoding.
 388
 389 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 390 if there are in decoded encoded-words (generated by bad manner MUA
 391 such as a version of Net$cape).
 392
 393 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 394 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 395 Otherwise it decodes non-ASCII bit patterns as the
 396 default-mime-charset."
 397   (interactive "*r")
 398   (rotate-memo args-eword-decode-region
 399                (list start end (buffer-substring start end) unfolding must-unfold code-conversion))
 400   (save-excursion
 401     (save-restriction
 402       (narrow-to-region start end)
 403       (if unfolding
 404           (eword-decode-unfold)
 405         )
 406       (let ((str (eword-decode-unstructured
 407                    (buffer-substring (point-min) (point-max))
 408                    code-conversion
 409                    must-unfold)))
 410         (delete-region (point-min) (point-max))
 411         (insert str)))))
 412
 413 (defun eword-decode-unfold ()
 414   (goto-char (point-min))
 415   (let (field beg end)
 416     (while (re-search-forward std11-field-head-regexp nil t)
 417       (setq beg (match-beginning 0)
 418             end (std11-field-end))
 419       (setq field (buffer-substring beg end))
 420       (if (string-match eword-encoded-word-regexp field)
 421           (save-restriction
 422             (narrow-to-region (goto-char beg) end)
 423             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 424               (replace-match (match-string 1))
 425               )
 426             (goto-char (point-max))
 427             ))
 428       )))
 429
 430 ;;; @ for message header
 431 ;;;
 432
 433 (defvar mime-field-decoder-alist nil)
 434
 435 (defvar mime-field-decoder-cache nil)
 436
 437 (defvar mime-update-field-decoder-cache 'ew-mime-update-field-decoder-cache
 438   "*Field decoder cache update function.")
 439
 440 ;;;###autoload
 441 (defun mime-set-field-decoder (field &rest specs)
 442   "Set decoder of FILED.
 443 SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
 444 Each mode must be `nil', `plain', `wide', `summary' or `nov'.
 445 If mode is `nil', corresponding decoder is set up for every modes."
 446   (when specs
 447     (let ((mode (pop specs))
 448           (function (pop specs)))
 449       (if mode
 450           (progn
 451             (let ((cell (assq mode mime-field-decoder-alist)))
 452               (if cell
 453                   (setcdr cell (put-alist field function (cdr cell)))
 454                 (setq mime-field-decoder-alist
 455                       (cons (cons mode (list (cons field function)))
 456                             mime-field-decoder-alist))
 457                 ))
 458             (apply (function mime-set-field-decoder) field specs)
 459             )
 460         (mime-set-field-decoder field
 461                                 'plain function
 462                                 'wide function
 463                                 'summary function
 464                                 'nov function)
 465         ))))
 466
 467 ;;;###autoload
 468 (defmacro mime-find-field-presentation-method (name)
 469   "Return field-presentation-method from NAME.
 470 NAME must be `plain', `wide', `summary' or `nov'."
 471   (cond ((eq name nil)
 472          `(or (assq 'summary mime-field-decoder-cache)
 473               '(summary))
 474          )
 475         ((and (consp name)
 476               (car name)
 477               (consp (cdr name))
 478               (symbolp (car (cdr name)))
 479               (null (cdr (cdr name))))
 480          `(or (assq ,name mime-field-decoder-cache)
 481               (cons ,name nil))
 482          )
 483         (t
 484          `(or (assq (or ,name 'summary) mime-field-decoder-cache)
 485               (cons (or ,name 'summary) nil))
 486          )))
 487
 488 (defun mime-find-field-decoder-internal (field &optional mode)
 489   "Return function to decode field-body of FIELD in MODE.
 490 Optional argument MODE must be object of field-presentation-method."
 491   (cdr (or (assq field (cdr mode))
 492            (prog1
 493                (funcall mime-update-field-decoder-cache
 494                         field (car mode))
 495              (setcdr mode
 496                      (cdr (assq (car mode) mime-field-decoder-cache)))
 497              ))))
 498
 499 ;;;###autoload
 500 (defun mime-find-field-decoder (field &optional mode)
 501   "Return function to decode field-body of FIELD in MODE.
 502 Optional argument MODE must be object or name of
 503 field-presentation-method.  Name of field-presentation-method must be
 504 `plain', `wide', `summary' or `nov'.
 505 Default value of MODE is `summary'."
 506   (if (symbolp mode)
 507       (let ((p (cdr (mime-find-field-presentation-method mode))))
 508         (if (and p (setq p (assq field p)))
 509             (cdr p)
 510           (cdr (funcall mime-update-field-decoder-cache
 511                         field (or mode 'summary)))))
 512     (inline (mime-find-field-decoder-internal field mode))
 513     ))
 514
 515 ;;;###autoload
 516 (defun mime-update-field-decoder-cache (field mode &optional function)
 517   "Update field decoder cache `mime-field-decoder-cache'."
 518   (cond ((eq function 'identity)
 519          (setq function nil)
 520          )
 521         ((null function)
 522          (let ((decoder-alist
 523                 (cdr (assq (or mode 'summary) mime-field-decoder-alist))))
 524            (setq function (cdr (or (assq field decoder-alist)
 525                                    (assq t decoder-alist)))))
 526          ))
 527   (let ((cell (assq mode mime-field-decoder-cache))
 528         ret)
 529     (if cell
 530         (if (setq ret (assq field (cdr cell)))
 531             (setcdr ret function)
 532           (setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
 533       (setq mime-field-decoder-cache
 534             (cons (cons mode (list (setq ret (cons field function))))
 535                   mime-field-decoder-cache)))
 536     ret))
 537
 538 ;; ignored fields
 539 (mime-set-field-decoder 'Archive                nil nil)
 540 (mime-set-field-decoder 'Content-Md5            nil nil)
 541 (mime-set-field-decoder 'Control                nil nil)
 542 (mime-set-field-decoder 'Date                   nil nil)
 543 (mime-set-field-decoder 'Distribution           nil nil)
 544 (mime-set-field-decoder 'Followup-Host          nil nil)
 545 (mime-set-field-decoder 'Followup-To            nil nil)
 546 (mime-set-field-decoder 'Lines                  nil nil)
 547 (mime-set-field-decoder 'Message-Id             nil nil)
 548 (mime-set-field-decoder 'Newsgroups             nil nil)
 549 (mime-set-field-decoder 'Nntp-Posting-Host      nil nil)
 550 (mime-set-field-decoder 'Path                   nil nil)
 551 (mime-set-field-decoder 'Posted-And-Mailed      nil nil)
 552 (mime-set-field-decoder 'Received               nil nil)
 553 (mime-set-field-decoder 'Status                 nil nil)
 554 (mime-set-field-decoder 'X-Face                 nil nil)
 555 (mime-set-field-decoder 'X-Face-Version         nil nil)
 556 (mime-set-field-decoder 'X-Info                 nil nil)
 557 (mime-set-field-decoder 'X-Pgp-Key-Info         nil nil)
 558 (mime-set-field-decoder 'X-Pgp-Sig              nil nil)
 559 (mime-set-field-decoder 'X-Pgp-Sig-Version      nil nil)
 560 (mime-set-field-decoder 'Xref                   nil nil)
 561
 562 ;; structured fields
 563 (let ((fields
 564        '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
 565          To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
 566          Mail-Followup-To
 567          Mime-Version Content-Type Content-Transfer-Encoding
 568          Content-Disposition User-Agent))
 569       field)
 570   (while fields
 571     (setq field (pop fields))
 572     (mime-set-field-decoder
 573      field
 574      'plain     #'eword-decode-structured-field-body
 575      'wide      #'eword-decode-and-fold-structured-field-body
 576      'summary   #'eword-decode-and-unfold-structured-field-body
 577      'nov       #'eword-decode-and-unfold-structured-field-body)
 578     ))
 579
 580 ;; unstructured fields (default)
 581 (mime-set-field-decoder
 582  t
 583  'plain #'eword-decode-unstructured-field-body
 584  'wide  #'eword-decode-unstructured-field-body
 585  'summary #'eword-decode-and-unfold-unstructured-field-body
 586  'nov   #'eword-decode-unfolded-unstructured-field-body)
 587
 588 ;;;###autoload
 589 (defun ew-mime-update-field-decoder-cache (field mode)
 590   (let ((fun (cond
 591               ((eq mode 'plain)
 592                (lexical-let ((field-name (symbol-name field)))
 593                  (lambda (field-body &optional start-column max-column must-unfold)
 594                    (setq field-body (ew-lf-to-crlf field-body))
 595                    (let ((res (ew-crlf-to-lf
 596                                (ew-decode-field field-name field-body))))
 597                      (add-text-properties
 598                       0 (length res)
 599                       (list 'original-field-name field-name
 600                             'original-field-body field-body)
 601                       res)
 602                      res))))
 603               ((eq mode 'wide)
 604                (lexical-let ((field-name (symbol-name field)))
 605                  (lambda (field-body &optional start-column max-column must-unfold)
 606                    (setq field-body (ew-lf-to-crlf field-body))
 607                    (let ((res (ew-crlf-to-lf
 608                                (ew-crlf-refold
 609                                 (ew-decode-field field-name field-body)
 610                                 (length field-name)
 611                                 (or max-column fill-column)))))
 612                      (add-text-properties
 613                       0 (length res)
 614                       (list 'original-field-name field-name
 615                             'original-field-body field-body)
 616                       res)
 617                      res))))
 618               ((eq mode 'summary)
 619                (lexical-let ((field-name (symbol-name field)))
 620                  (lambda (field-body &optional start-column max-column must-unfold)
 621                    (setq field-body (ew-lf-to-crlf field-body))
 622                    (let ((res (ew-crlf-to-lf
 623                                (ew-crlf-unfold
 624                                 (ew-decode-field field-name field-body)))))
 625                      (add-text-properties
 626                       0 (length res)
 627                       (list 'original-field-name field-name
 628                             'original-field-body field-body)
 629                       res)
 630                      res))))
 631               ((eq mode 'nov)
 632                (lexical-let ((field-name (symbol-name field)))
 633                  (lambda (field-body &optional start-column max-column must-unfold)
 634                    (setq field-body (ew-lf-to-crlf field-body))
 635                    (require 'ew-var)
 636                    (let ((ew-ignore-76bytes-limit t))
 637                      (let ((res (ew-crlf-to-lf
 638                                  (ew-crlf-unfold
 639                                   (ew-decode-field field-name field-body)))))
 640                        (add-text-properties
 641                         0 (length res)
 642                         (list 'original-field-name field-name
 643                               'original-field-body field-body)
 644                         res)
 645                        res)))))
 646               (t
 647                nil))))
 648     (mime-update-field-decoder-cache field mode fun)))
 649
 650 ;;;###autoload
 651 (defun mime-decode-field-body (field-body field-name
 652                                           &optional mode max-column)
 653   "Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
 654 Optional argument MODE must be `plain', `wide', `summary' or `nov'.
 655 Default mode is `summary'.
 656
 657 If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
 658 MAX-COLUMN.
 659
 660 Non MIME encoded-word part in FILED-BODY is decoded with
 661 `default-mime-charset'."
 662   (unless mode (setq mode 'summary))
 663   (if (symbolp field-name) (setq field-name (symbol-name field-name)))
 664   (let ((decoded
 665           (if (eq mode 'nov)
 666             (let ((ew-ignore-76bytes-limit t))
 667               (ew-decode-field
 668                field-name (ew-lf-crlf-to-crlf field-body)))
 669             (ew-decode-field
 670              field-name (ew-lf-crlf-to-crlf field-body)))))
 671     (if (and (eq mode 'wide) max-column)
 672         (setq decoded (ew-crlf-refold
 673                        decoded
 674                        (1+ (string-width field-name))
 675                        max-column))
 676       (if (not (eq mode 'plain))
 677           (setq decoded (ew-crlf-unfold decoded))))
 678     (setq decoded (ew-crlf-to-lf decoded))
 679     (add-text-properties 0 (length decoded)
 680                          (list 'original-field-name field-name
 681                                'original-field-body field-body)
 682                          decoded)
 683     decoded))
 684
 685 ;;;###autoload
 686 (defun mime-decode-header-in-region (start end
 687                                            &optional code-conversion)
 688   "Decode MIME encoded-words in region between START and END.
 689 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 690 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 691 Otherwise it decodes non-ASCII bit patterns as the
 692 default-mime-charset."
 693   (interactive "*r")
 694   (save-excursion
 695     (save-restriction
 696       (narrow-to-region start end)
 697       (let ((default-charset
 698               (if code-conversion
 699                   (if (mime-charset-to-coding-system code-conversion)
 700                       code-conversion
 701                     default-mime-charset))))
 702         (if default-charset
 703             (let ((mode-obj (mime-find-field-presentation-method 'wide))
 704                   beg p end len field-decoder
 705                   field-name field-body)
 706               (goto-char (point-min))
 707               (while (re-search-forward std11-field-head-regexp nil t)
 708                 (setq beg (match-beginning 0)
 709                       p (match-end 0)
 710                       field-name (buffer-substring beg (1- p))
 711                       len (string-width field-name)
 712                       field-decoder (inline
 713                                       (mime-find-field-decoder-internal
 714                                        (intern (capitalize field-name))
 715                                        mode-obj)))
 716                 (when field-decoder
 717                   (setq end (std11-field-end)
 718                         field-body (buffer-substring p end))
 719                   (let ((default-mime-charset default-charset))
 720                     (delete-region p end)
 721                     (insert (funcall field-decoder field-body (1+ len)))
 722                     ))
 723                 (add-text-properties beg (min (1+ (point)) (point-max))
 724                                      (list 'original-field-name field-name
 725                                            'original-field-body field-body))
 726                 ))
 727           (eword-decode-region (point-min) (point-max) t)
 728           )))))
 729
 730 ;;;###autoload
 731 (defun mime-decode-header-in-buffer (&optional code-conversion separator)
 732   "Decode MIME encoded-words in header fields.
 733 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 734 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 735 Otherwise it decodes non-ASCII bit patterns as the
 736 default-mime-charset.
 737 If SEPARATOR is not nil, it is used as header separator."
 738   (interactive "*")
 739   (mime-decode-header-in-region
 740    (point-min)
 741    (save-excursion
 742      (goto-char (point-min))
 743      (if (re-search-forward
 744           (concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
 745           nil t)
 746          (match-beginning 0)
 747        (point-max)
 748        ))
 749    code-conversion))
 750
 751 (define-obsolete-function-alias 'eword-decode-header
 752   'mime-decode-header-in-buffer)
 753
 754
 755 ;;; @ encoded-word decoder
 756 ;;;
 757
 758 (defvar eword-decode-encoded-word-error-handler
 759   'eword-decode-encoded-word-default-error-handler)
 760
 761 (defvar eword-warning-face nil
 762   "Face used for invalid encoded-word.")
 763
 764 (defun eword-decode-encoded-word-default-error-handler (word signal)
 765   (and (add-text-properties 0 (length word)
 766                             (and eword-warning-face
 767                                  (list 'face eword-warning-face))
 768                             word)
 769        word))
 770
 771 (defun eword-decode-encoded-word (word &optional must-unfold)
 772   "Decode WORD if it is an encoded-word.
 773
 774 If your emacs implementation can not decode the charset of WORD, it
 775 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 776
 777 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 778 if there are in decoded encoded-word (generated by bad manner MUA such
 779 as a version of Net$cape)."
 780   (or (if (string-match eword-encoded-word-regexp word)
 781           (let ((charset
 782                  (substring word (match-beginning 1) (match-end 1))
 783                  )
 784                 (encoding
 785                  (upcase
 786                   (substring word (match-beginning 2) (match-end 2))
 787                   ))
 788                 (text
 789                  (substring word (match-beginning 3) (match-end 3))
 790                  ))
 791             (condition-case err
 792                 (eword-decode-encoded-text charset encoding text must-unfold)
 793               (error
 794                (funcall eword-decode-encoded-word-error-handler word err)
 795                ))
 796             ))
 797       word))
 798
 799
 800 ;;; @ encoded-text decoder
 801 ;;;
 802
 803 (defun eword-decode-encoded-text (charset encoding string
 804                                           &optional must-unfold)
 805   "Decode STRING as an encoded-text.
 806
 807 If your emacs implementation can not decode CHARSET, it returns nil.
 808
 809 If ENCODING is not \"B\" or \"Q\", it occurs error.
 810 So you should write error-handling code if you don't want break by errors.
 811
 812 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 813 if there are in decoded encoded-text (generated by bad manner MUA such
 814 as a version of Net$cape)."
 815   (let ((cs (mime-charset-to-coding-system charset)))
 816     (if cs
 817         (let ((dest (encoded-text-decode-string string encoding)))
 818           (when dest
 819             (setq dest (decode-mime-charset-string dest charset))
 820             (if must-unfold
 821                 (mapconcat (function
 822                             (lambda (chr)
 823                               (cond ((eq chr ?\n) "")
 824                                     ((eq chr ?\t) " ")
 825                                     (t (char-to-string chr)))
 826                               ))
 827                            (std11-unfold-string dest)
 828                            "")
 829               dest))))))
 830
 831
 832 ;;; @ lexical analyze
 833 ;;;
 834
 835 (defvar eword-lexical-analyze-cache nil)
 836 (defvar eword-lexical-analyze-cache-max 299
 837   "*Max position of eword-lexical-analyze-cache.
 838 It is max size of eword-lexical-analyze-cache - 1.")
 839
 840 (defcustom eword-lexical-analyzers
 841   '(eword-analyze-quoted-string
 842     eword-analyze-domain-literal
 843     eword-analyze-comment
 844     eword-analyze-spaces
 845     eword-analyze-special
 846     eword-analyze-encoded-word
 847     eword-analyze-atom)
 848   "*List of functions to return result of lexical analyze.
 849 Each function must have two arguments: STRING and MUST-UNFOLD.
 850 STRING is the target string to be analyzed.
 851 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 852 bare-CR and bare-LF from the result even if they are included in
 853 content of the encoded-word.
 854 Each function must return nil if it can not analyze STRING as its
 855 format.
 856
 857 Previous function is preferred to next function.  If a function
 858 returns nil, next function is used.  Otherwise the return value will
 859 be the result."
 860   :group 'eword-decode
 861   :type '(repeat function))
 862
 863 (defun eword-analyze-quoted-string (string &optional must-unfold)
 864   (let ((p (std11-check-enclosure string ?\" ?\")))
 865     (if p
 866         (cons (cons 'quoted-string
 867                     (if eword-decode-quoted-encoded-word
 868                         (eword-decode-quoted-string
 869                           (substring string 0 p)
 870                           default-mime-charset)
 871                       (std11-wrap-as-quoted-string
 872                        (decode-mime-charset-string
 873                         (std11-strip-quoted-pair (substring string 1 (1- p)))
 874                         default-mime-charset))))
 875               (substring string p)))
 876     ))
 877
 878 (defun eword-analyze-domain-literal (string &optional must-unfold)
 879   (std11-analyze-domain-literal string))
 880
 881 (defun eword-analyze-comment (string &optional must-unfold)
 882   (let ((len (length string)))
 883     (if (and (< 0 len) (eq (aref string 0) ?\())
 884         (let ((p 0))
 885           (while (and p (< p len) (eq (aref string p) ?\())
 886             (setq p (std11-check-enclosure string ?\( ?\) t p)))
 887           (setq p (or p len))
 888           (cons (cons 'comment
 889                       (eword-decode-comment
 890                         (std11-unfold-string (substring string 0 p))
 891                         default-mime-charset))
 892                 (substring string p)))
 893       nil)))
 894
 895
 896 (defun eword-analyze-spaces (string &optional must-unfold)
 897   (std11-analyze-spaces string))
 898
 899 (defun eword-analyze-special (string &optional must-unfold)
 900   (std11-analyze-special string))
 901
 902 (defun eword-analyze-encoded-word (string &optional must-unfold)
 903   (let ((decoded (eword-decode-first-encoded-words
 904                   string
 905                   eword-encoded-word-in-phrase-regexp
 906                   eword-after-encoded-word-in-phrase-regexp
 907                   must-unfold)))
 908     (if decoded
 909         (let ((s (car decoded)))
 910           (while (or (string-match std11-atom-regexp s)
 911                      (string-match std11-spaces-regexp s))
 912             (setq s (substring s (match-end 0))))
 913           (if (= (length s) 0)
 914               (cons (cons 'atom (car decoded)) (cdr decoded))
 915             (cons (cons 'quoted-string
 916                         (std11-wrap-as-quoted-string (car decoded)))
 917                   (cdr decoded)))))))
 918
 919 (defun eword-analyze-atom (string &optional must-unfold)
 920   (if (string-match std11-atom-regexp (string-as-unibyte string))
 921       (let ((end (match-end 0)))
 922         (if (and eword-decode-sticked-encoded-word
 923                  (string-match eword-encoded-word-in-phrase-regexp
 924                                (substring string 0 end))
 925                  (< 0 (match-beginning 0)))
 926             (setq end (match-beginning 0)))
 927         (cons (cons 'atom (decode-mime-charset-string
 928                            (substring string 0 end)
 929                            default-mime-charset))
 930               (substring string end)
 931               ))))
 932
 933 (defun eword-lexical-analyze-internal (string must-unfold)
 934   (let ((last 'eword-analyze-spaces)
 935         dest ret)
 936     (while (not (string-equal string ""))
 937       (setq ret
 938             (let ((rest eword-lexical-analyzers)
 939                   func r)
 940               (while (and (setq func (car rest))
 941                           (or
 942                            (and
 943                             (not eword-decode-sticked-encoded-word)
 944                             (not (eq last 'eword-analyze-spaces))
 945                             (eq func 'eword-analyze-encoded-word))
 946                            (null (setq r (funcall func string must-unfold))))
 947                           )
 948                 (setq rest (cdr rest)))
 949               (setq last func)
 950               (or r `((error . ,string) . ""))
 951               ))
 952       (setq dest (cons (car ret) dest))
 953       (setq string (cdr ret))
 954       )
 955     (nreverse dest)
 956     ))
 957
 958 (defun eword-lexical-analyze (string &optional must-unfold)
 959   "Return lexical analyzed list corresponding STRING.
 960 It is like std11-lexical-analyze, but it decodes non us-ascii
 961 characters encoded as encoded-words or invalid \"raw\" format.
 962 \"Raw\" non us-ascii characters are regarded as variable
 963 `default-mime-charset'."
 964   (let* ((str (copy-sequence string))
 965          (key (cons str (cons default-mime-charset must-unfold)))
 966          ret)
 967     (set-text-properties 0 (length str) nil str)
 968     (if (setq ret (assoc key eword-lexical-analyze-cache))
 969         (cdr ret)
 970       (setq ret (eword-lexical-analyze-internal str must-unfold))
 971       (setq eword-lexical-analyze-cache
 972             (cons (cons key ret)
 973                   (last eword-lexical-analyze-cache
 974                         eword-lexical-analyze-cache-max)))
 975       ret)))
 976
 977 (defun eword-decode-token (token)
 978   (cdr token))
 979
 980 (defun eword-extract-address-components (string)
 981   "Extract full name and canonical address from STRING.
 982 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 983 If no name can be extracted, FULL-NAME will be nil.
 984 It decodes non us-ascii characters in FULL-NAME encoded as
 985 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 986 characters are regarded as variable `default-mime-charset'."
 987   (rotate-memo args-eword-extract-address-components (list string))
 988   (let* ((structure (car (std11-parse-address
 989                           (eword-lexical-analyze
 990                            (std11-unfold-string string) 'must-unfold))))
 991          (phrase  (std11-full-name-string structure))
 992          (address (std11-address-string structure))
 993          )
 994     (list phrase address)
 995     ))
 996
 997
 998 ;;; @ end
 999 ;;;
1000
1001 (provide 'eword-decode)
1002
1003 ;;; eword-decode.el ends here