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 ;; Maintainer: MORIOKA Tomohiko <morioka@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
  11 ;;      Renamed: 1995/10/03 from tiny-mime.el (split off encoder)
  12 ;;      Renamed: 1997/02/22 from tm-ew-d.el
  13 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
  14
  15 ;; This file is part of SEMI (Spadework for Emacs MIME Interfaces).
  16
  17 ;; This program is free software; you can redistribute it and/or
  18 ;; modify it under the terms of the GNU General Public License as
  19 ;; published by the Free Software Foundation; either version 2, or (at
  20 ;; your option) any later version.
  21
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25 ;; General Public License for more details.
  26
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  29 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  30 ;; Boston, MA 02111-1307, USA.
  31
  32 ;;; Code:
  33
  34 (require 'std11)
  35 (require 'mel)
  36 (require 'mime-def)
  37
  38 (defgroup eword-decode nil
  39   "Encoded-word decoding"
  40   :group 'mime)
  41
  42 (defcustom eword-max-size-to-decode 1000
  43   "*Max size to decode header field."
  44   :group 'eword-decode
  45   :type '(choice (integer :tag "Limit (bytes)")
  46                  (const :tag "Don't limit" nil)))
  47
  48
  49 ;;; @ MIME encoded-word definition
  50 ;;;
  51
  52 (eval-and-compile
  53   (defconst eword-encoded-text-regexp "[!->@-~]+")
  54   )
  55 (defconst eword-encoded-word-regexp
  56   (eval-when-compile
  57     (concat (regexp-quote "=?")
  58             "\\("
  59             mime-charset-regexp
  60             "\\)"
  61             (regexp-quote "?")
  62             "\\(B\\|Q\\)"
  63             (regexp-quote "?")
  64             "\\("
  65             eword-encoded-text-regexp
  66             "\\)"
  67             (regexp-quote "?="))))
  68
  69
  70 ;;; @ for string
  71 ;;;
  72
  73 (defun eword-decode-string (string &optional must-unfold)
  74   "Decode MIME encoded-words in STRING.
  75
  76 STRING is unfolded before decoding.
  77
  78 If an encoded-word is broken or your emacs implementation can not
  79 decode the charset included in it, it is not decoded.
  80
  81 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  82 if there are in decoded encoded-words (generated by bad manner MUA
  83 such as a version of Net$cape)."
  84   (setq string (std11-unfold-string string))
  85   (let ((dest "")(ew nil)
  86         beg end)
  87     (while (and (string-match eword-encoded-word-regexp string)
  88                 (setq beg (match-beginning 0)
  89                       end (match-end 0))
  90                 )
  91       (if (> beg 0)
  92           (if (not
  93                (and (eq ew t)
  94                     (string-match "^[ \t]+$" (substring string 0 beg))
  95                     ))
  96               (setq dest (concat dest (substring string 0 beg)))
  97             )
  98         )
  99       (setq dest
 100             (concat dest
 101                     (eword-decode-encoded-word
 102                      (substring string beg end) must-unfold)
 103                     ))
 104       (setq string (substring string end))
 105       (setq ew t)
 106       )
 107     (concat dest string)
 108     ))
 109
 110 (defun eword-decode-and-fold-structured-field
 111   (string start-column &optional max-column must-unfold)
 112   "Decode and fold (fill) STRING as structured field body.
 113 It decodes non us-ascii characters in FULL-NAME encoded as
 114 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 115 characters are regarded as variable `default-mime-charset'.
 116
 117 If an encoded-word is broken or your emacs implementation can not
 118 decode the charset included in it, it is not decoded.
 119
 120 If MAX-COLUMN is omitted, `fill-column' is used.
 121
 122 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 123 if there are in decoded encoded-words (generated by bad manner MUA
 124 such as a version of Net$cape)."
 125   (if (and eword-max-size-to-decode
 126            (> (length string) eword-max-size-to-decode))
 127       string
 128     (or max-column
 129         (setq max-column fill-column))
 130     (let ((c start-column)
 131           (tokens (eword-lexical-analyze string must-unfold))
 132           (result "")
 133           token)
 134       (while (and (setq token (car tokens))
 135                   (setq tokens (cdr tokens)))
 136         (let* ((type (car token)))
 137           (if (eq type 'spaces)
 138               (let* ((next-token (car tokens))
 139                      (next-str (eword-decode-token next-token))
 140                      (next-len (string-width next-str))
 141                      (next-c (+ c next-len 1)))
 142                 (if (< next-c max-column)
 143                     (setq result (concat result " " next-str)
 144                           c next-c)
 145                   (setq result (concat result "\n " next-str)
 146                         c (1+ next-len)))
 147                 (setq tokens (cdr tokens))
 148                 )
 149             (let* ((str (eword-decode-token token)))
 150               (setq result (concat result str)
 151                     c (+ c (string-width str)))
 152               ))))
 153       (if token
 154           (concat result (eword-decode-token token))
 155         result))))
 156
 157 (defun eword-decode-and-unfold-structured-field (string)
 158   "Decode and unfold STRING as structured field body.
 159 It decodes non us-ascii characters in FULL-NAME encoded as
 160 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 161 characters are regarded as variable `default-mime-charset'.
 162
 163 If an encoded-word is broken or your emacs implementation can not
 164 decode the charset included in it, it is not decoded."
 165   (let ((tokens (eword-lexical-analyze string 'must-unfold))
 166         (result ""))
 167     (while tokens
 168       (let* ((token (car tokens))
 169              (type (car token)))
 170         (setq tokens (cdr tokens))
 171         (setq result
 172               (if (eq type 'spaces)
 173                   (concat result " ")
 174                 (concat result (eword-decode-token token))
 175                 ))))
 176     result))
 177
 178 (defun eword-decode-structured-field-body (string &optional must-unfold
 179                                                   start-column max-column)
 180   "Decode non us-ascii characters in STRING as structured field body.
 181 STRING is unfolded before decoding.
 182
 183 It decodes non us-ascii characters in FULL-NAME encoded as
 184 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 185 characters are regarded as variable `default-mime-charset'.
 186
 187 If an encoded-word is broken or your emacs implementation can not
 188 decode the charset included in it, it is not decoded.
 189
 190 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 191 if there are in decoded encoded-words (generated by bad manner MUA
 192 such as a version of Net$cape)."
 193   (if start-column
 194       ;; fold with max-column
 195       (eword-decode-and-fold-structured-field
 196        string start-column max-column must-unfold)
 197     ;; Don't fold
 198     (mapconcat (function eword-decode-token)
 199                (eword-lexical-analyze string must-unfold)
 200                "")
 201     ))
 202
 203 (defun eword-decode-unstructured-field-body (string &optional must-unfold)
 204   "Decode non us-ascii characters in STRING as unstructured field body.
 205 STRING is unfolded before decoding.
 206
 207 It decodes non us-ascii characters in FULL-NAME encoded as
 208 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 209 characters are regarded as variable `default-mime-charset'.
 210
 211 If an encoded-word is broken or your emacs implementation can not
 212 decode the charset included in it, it is not decoded.
 213
 214 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 215 if there are in decoded encoded-words (generated by bad manner MUA
 216 such as a version of Net$cape)."
 217   (eword-decode-string
 218    (decode-mime-charset-string string default-mime-charset)
 219    must-unfold))
 220
 221 (defun eword-decode-and-unfold-unstructured-field (string)
 222   "Decode and unfold STRING as unstructured field body.
 223 It decodes non us-ascii characters in FULL-NAME encoded as
 224 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 225 characters are regarded as variable `default-mime-charset'.
 226
 227 If an encoded-word is broken or your emacs implementation can not
 228 decode the charset included in it, it is not decoded."
 229   (eword-decode-string
 230    (decode-mime-charset-string (std11-unfold-string string)
 231                                default-mime-charset)
 232    'must-unfold))
 233
 234
 235 ;;; @ for region
 236 ;;;
 237
 238 (defun eword-decode-region (start end &optional unfolding must-unfold)
 239   "Decode MIME encoded-words in region between START and END.
 240
 241 If UNFOLDING is not nil, it unfolds before decoding.
 242
 243 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 244 if there are in decoded encoded-words (generated by bad manner MUA
 245 such as a version of Net$cape)."
 246   (interactive "*r")
 247   (save-excursion
 248     (save-restriction
 249       (narrow-to-region start end)
 250       (if unfolding
 251           (eword-decode-unfold)
 252         )
 253       (goto-char (point-min))
 254       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
 255                                         "\\(\n?[ \t]\\)+"
 256                                         "\\(" eword-encoded-word-regexp "\\)")
 257                                 nil t)
 258         (replace-match "\\1\\6")
 259         (goto-char (point-min))
 260         )
 261       (while (re-search-forward eword-encoded-word-regexp nil t)
 262         (insert (eword-decode-encoded-word
 263                  (prog1
 264                      (buffer-substring (match-beginning 0) (match-end 0))
 265                    (delete-region (match-beginning 0) (match-end 0))
 266                    ) must-unfold))
 267         )
 268       )))
 269
 270
 271 ;;; @ for message header
 272 ;;;
 273
 274 (defcustom eword-decode-ignored-field-list
 275   '(Newsgroups Path Lines Nntp-Posting-Host Received Message-Id Date)
 276   "*List of field-names to be ignored when decoding.
 277 Each field name must be symbol."
 278   :group 'eword-decode
 279   :type '(repeat symbol))
 280
 281 (defcustom eword-decode-structured-field-list
 282   '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
 283              To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
 284              Mail-Followup-To
 285              Mime-Version Content-Type Content-Transfer-Encoding
 286              Content-Disposition User-Agent)
 287   "*List of field-names to decode as structured field.
 288 Each field name must be symbol."
 289   :group 'eword-decode
 290   :type '(repeat symbol))
 291
 292 (defun eword-decode-field (field-name field-body &optional unfolded max-column)
 293   "If FIELD-NAME is in `eword-decode-ignored-field-list',
 294 return FIELD-BODY itself.
 295
 296 If FIELD-NAME is in `eword-decode-structured-field-list',
 297 FIELD-BODY is interpreted as structured field,
 298 decode MIME encoded-words and return it.
 299
 300 Otherwise, FIELD-BODY is interpreted as unstructured field,
 301 decode MIME encoded-words and return it.
 302
 303 Anyway, non-encoded-word part is decoded with `default-mime-charset'.
 304
 305 If FIELD-BODY is already unfolded, UNFOLDED should be non-nil.
 306
 307 If MAX-COLUMN is nil, FIELD-BODY is unfolded.
 308 Otherwise, FIELD-BODY is folded with with MAX-COLUMN
 309 (or `fill-column' if MAX-COLUMN is not integer.)"
 310   (cond
 311     ((memq field-name eword-decode-ignored-field-list)
 312      field-body)
 313     ((memq field-name eword-decode-structured-field-list)
 314      (if (null max-column)
 315          (eword-decode-and-fold-structured-field
 316            field-body
 317            (1+ (string-width (symbol-name field-name)))
 318            (if (integerp max-column) max-column fill-column))
 319        (eword-decode-and-unfold-structured-field field-body)))
 320     (t
 321      (eword-decode-unstructured-field-body
 322        field-body
 323        (1+ (string-width (symbol-name field-name)))))))
 324
 325 (defun eword-decode-header (&optional code-conversion separator)
 326   "Decode MIME encoded-words in header fields.
 327 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 328 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 329 Otherwise it decodes non-ASCII bit patterns as the
 330 default-mime-charset.
 331 If SEPARATOR is not nil, it is used as header separator."
 332   (interactive "*")
 333   (save-excursion
 334     (save-restriction
 335       (std11-narrow-to-header separator)
 336       (let ((default-charset
 337               (if code-conversion
 338                   (if (mime-charset-to-coding-system code-conversion)
 339                       code-conversion
 340                     default-mime-charset))))
 341         (if default-charset
 342             (let (beg p end field-name len)
 343               (goto-char (point-min))
 344               (while (re-search-forward std11-field-head-regexp nil t)
 345                 (setq beg (match-beginning 0)
 346                       p (match-end 0)
 347                       field-name (buffer-substring beg (1- p))
 348                       len (string-width field-name)
 349                       field-name (intern (capitalize field-name))
 350                       end (std11-field-end))
 351                 (let ((body (buffer-substring p end))
 352                       (default-mime-charset default-charset))
 353                   (delete-region p end)
 354                   (insert (eword-decode-field field-name body nil t)))))
 355           (eword-decode-region (point-min) (point-max) t)
 356           )))))
 357
 358 (defun eword-decode-unfold ()
 359   (goto-char (point-min))
 360   (let (field beg end)
 361     (while (re-search-forward std11-field-head-regexp nil t)
 362       (setq beg (match-beginning 0)
 363             end (std11-field-end))
 364       (setq field (buffer-substring beg end))
 365       (if (string-match eword-encoded-word-regexp field)
 366           (save-restriction
 367             (narrow-to-region (goto-char beg) end)
 368             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 369               (replace-match (match-string 1))
 370               )
 371             (goto-char (point-max))
 372             ))
 373       )))
 374
 375
 376 ;;; @ encoded-word decoder
 377 ;;;
 378
 379 (defvar eword-decode-encoded-word-error-handler
 380   'eword-decode-encoded-word-default-error-handler)
 381
 382 (defvar eword-warning-face nil
 383   "Face used for invalid encoded-word.")
 384
 385 (defun eword-decode-encoded-word-default-error-handler (word signal)
 386   (and (add-text-properties 0 (length word)
 387                             (and eword-warning-face
 388                                  (list 'face eword-warning-face))
 389                             word)
 390        word))
 391
 392 (defun eword-decode-encoded-word (word &optional must-unfold)
 393   "Decode WORD if it is an encoded-word.
 394
 395 If your emacs implementation can not decode the charset of WORD, it
 396 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 397
 398 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 399 if there are in decoded encoded-word (generated by bad manner MUA such
 400 as a version of Net$cape)."
 401   (or (if (string-match eword-encoded-word-regexp word)
 402           (let ((charset
 403                  (substring word (match-beginning 1) (match-end 1))
 404                  )
 405                 (encoding
 406                  (upcase
 407                   (substring word (match-beginning 2) (match-end 2))
 408                   ))
 409                 (text
 410                  (substring word (match-beginning 3) (match-end 3))
 411                  ))
 412             (condition-case err
 413                 (eword-decode-encoded-text charset encoding text must-unfold)
 414               (error
 415                (funcall eword-decode-encoded-word-error-handler word err)
 416                ))
 417             ))
 418       word))
 419
 420
 421 ;;; @ encoded-text decoder
 422 ;;;
 423
 424 (defun eword-decode-encoded-text (charset encoding string
 425                                           &optional must-unfold)
 426   "Decode STRING as an encoded-text.
 427
 428 If your emacs implementation can not decode CHARSET, it returns nil.
 429
 430 If ENCODING is not \"B\" or \"Q\", it occurs error.
 431 So you should write error-handling code if you don't want break by errors.
 432
 433 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 434 if there are in decoded encoded-text (generated by bad manner MUA such
 435 as a version of Net$cape)."
 436   (let ((cs (mime-charset-to-coding-system charset)))
 437     (if cs
 438         (let ((dest (encoded-text-decode-string string encoding)))
 439           (when dest
 440             (setq dest (decode-mime-charset-string dest charset))
 441             (if must-unfold
 442                 (mapconcat (function
 443                             (lambda (chr)
 444                               (cond ((eq chr ?\n) "")
 445                                     ((eq chr ?\t) " ")
 446                                     (t (char-to-string chr)))
 447                               ))
 448                            (std11-unfold-string dest)
 449                            "")
 450               dest))))))
 451
 452
 453 ;;; @ lexical analyze
 454 ;;;
 455
 456 (defvar eword-lexical-analyze-cache nil)
 457 (defvar eword-lexical-analyze-cache-max 299
 458   "*Max position of eword-lexical-analyze-cache.
 459 It is max size of eword-lexical-analyze-cache - 1.")
 460
 461 (defcustom eword-lexical-analyzers
 462   '(eword-analyze-quoted-string
 463     eword-analyze-domain-literal
 464     eword-analyze-comment
 465     eword-analyze-spaces
 466     eword-analyze-special
 467     eword-analyze-encoded-word
 468     eword-analyze-atom)
 469   "*List of functions to return result of lexical analyze.
 470 Each function must have two arguments: STRING and MUST-UNFOLD.
 471 STRING is the target string to be analyzed.
 472 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 473 bare-CR and bare-LF from the result even if they are included in
 474 content of the encoded-word.
 475 Each function must return nil if it can not analyze STRING as its
 476 format.
 477
 478 Previous function is preferred to next function.  If a function
 479 returns nil, next function is used.  Otherwise the return value will
 480 be the result."
 481   :group 'eword-decode
 482   :type '(repeat function))
 483
 484 (defun eword-analyze-quoted-string (string &optional must-unfold)
 485   (let ((p (std11-check-enclosure string ?\" ?\")))
 486     (if p
 487         (cons (cons 'quoted-string
 488                     (decode-mime-charset-string
 489                      (std11-strip-quoted-pair (substring string 1 (1- p)))
 490                      default-mime-charset))
 491               (substring string p))
 492       )))
 493
 494 (defun eword-analyze-domain-literal (string &optional must-unfold)
 495   (std11-analyze-domain-literal string))
 496
 497 (defun eword-analyze-comment (string &optional must-unfold)
 498   (let ((p (std11-check-enclosure string ?\( ?\) t)))
 499     (if p
 500         (cons (cons 'comment
 501                     (eword-decode-string
 502                      (decode-mime-charset-string
 503                       (std11-strip-quoted-pair (substring string 1 (1- p)))
 504                       default-mime-charset)
 505                      must-unfold))
 506               (substring string p))
 507       )))
 508
 509 (defun eword-analyze-spaces (string &optional must-unfold)
 510   (std11-analyze-spaces string))
 511
 512 (defun eword-analyze-special (string &optional must-unfold)
 513   (std11-analyze-special string))
 514
 515 (defun eword-analyze-encoded-word (string &optional must-unfold)
 516   (if (eq (string-match eword-encoded-word-regexp string) 0)
 517       (let ((end (match-end 0))
 518             (dest (eword-decode-encoded-word (match-string 0 string)
 519                                              must-unfold))
 520             )
 521         (setq string (substring string end))
 522         (while (eq (string-match `,(concat "[ \t\n]*\\("
 523                                            eword-encoded-word-regexp
 524                                            "\\)")
 525                                  string)
 526                    0)
 527           (setq end (match-end 0))
 528           (setq dest
 529                 (concat dest
 530                         (eword-decode-encoded-word (match-string 1 string)
 531                                                    must-unfold))
 532                 string (substring string end))
 533           )
 534         (cons (cons 'atom dest) string)
 535         )))
 536
 537 (defun eword-analyze-atom (string &optional must-unfold)
 538   (if (string-match std11-atom-regexp string)
 539       (let ((end (match-end 0)))
 540         (cons (cons 'atom (decode-mime-charset-string
 541                            (substring string 0 end)
 542                            default-mime-charset))
 543               (substring string end)
 544               ))))
 545
 546 (defun eword-lexical-analyze-internal (string must-unfold)
 547   (let (dest ret)
 548     (while (not (string-equal string ""))
 549       (setq ret
 550             (let ((rest eword-lexical-analyzers)
 551                   func r)
 552               (while (and (setq func (car rest))
 553                           (null (setq r (funcall func string must-unfold)))
 554                           )
 555                 (setq rest (cdr rest)))
 556               (or r `((error . ,string) . ""))
 557               ))
 558       (setq dest (cons (car ret) dest))
 559       (setq string (cdr ret))
 560       )
 561     (nreverse dest)
 562     ))
 563
 564 (defun eword-lexical-analyze (string &optional must-unfold)
 565   "Return lexical analyzed list corresponding STRING.
 566 It is like std11-lexical-analyze, but it decodes non us-ascii
 567 characters encoded as encoded-words or invalid \"raw\" format.
 568 \"Raw\" non us-ascii characters are regarded as variable
 569 `default-mime-charset'."
 570   (let ((key (copy-sequence string))
 571         ret)
 572     (set-text-properties 0 (length key) nil key)
 573     (if (setq ret (assoc key eword-lexical-analyze-cache))
 574         (cdr ret)
 575       (setq ret (eword-lexical-analyze-internal key must-unfold))
 576       (setq eword-lexical-analyze-cache
 577             (cons (cons key ret)
 578                   (last eword-lexical-analyze-cache
 579                         eword-lexical-analyze-cache-max)))
 580       ret)))
 581
 582 (defun eword-decode-token (token)
 583   (let ((type (car token))
 584         (value (cdr token)))
 585     (cond ((eq type 'quoted-string)
 586            (std11-wrap-as-quoted-string value))
 587           ((eq type 'comment)
 588            (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")"))
 589           (t value))))
 590
 591 (defun eword-extract-address-components (string)
 592   "Extract full name and canonical address from STRING.
 593 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 594 If no name can be extracted, FULL-NAME will be nil.
 595 It decodes non us-ascii characters in FULL-NAME encoded as
 596 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 597 characters are regarded as variable `default-mime-charset'."
 598   (let* ((structure (car (std11-parse-address
 599                           (eword-lexical-analyze
 600                            (std11-unfold-string string) 'must-unfold))))
 601          (phrase  (std11-full-name-string structure))
 602          (address (std11-address-string structure))
 603          )
 604     (list phrase address)
 605     ))
 606
 607
 608 ;;; @ end
 609 ;;;
 610
 611 (provide 'eword-decode)
 612
 613 ;;; eword-decode.el ends here