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