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