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-header (&optional code-conversion separator)
 293   "Decode MIME encoded-words in header fields.
 294 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 295 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 296 Otherwise it decodes non-ASCII bit patterns as the
 297 default-mime-charset.
 298 If SEPARATOR is not nil, it is used as header separator."
 299   (interactive "*")
 300   (save-excursion
 301     (save-restriction
 302       (std11-narrow-to-header separator)
 303       (let ((default-charset
 304               (if code-conversion
 305                   (if (mime-charset-to-coding-system code-conversion)
 306                       code-conversion
 307                     default-mime-charset))))
 308         (if default-charset
 309             (let (beg p end field-name len)
 310               (goto-char (point-min))
 311               (while (re-search-forward std11-field-head-regexp nil t)
 312                 (setq beg (match-beginning 0)
 313                       p (match-end 0)
 314                       field-name (buffer-substring beg (1- p))
 315                       len (string-width field-name)
 316                       field-name (intern (capitalize field-name))
 317                       end (std11-field-end))
 318                 (cond ((memq field-name eword-decode-ignored-field-list)
 319                        ;; Don't decode
 320                        )
 321                       ((memq field-name eword-decode-structured-field-list)
 322                        ;; Decode as structured field
 323                        (let ((body (buffer-substring p end))
 324                              (default-mime-charset default-charset))
 325                          (delete-region p end)
 326                          (insert (eword-decode-and-fold-structured-field
 327                                   body (1+ len)))
 328                          ))
 329                       (t
 330                        ;; Decode as unstructured field
 331                        (save-restriction
 332                          (narrow-to-region beg (1+ end))
 333                          (decode-mime-charset-region p end default-charset)
 334                          (goto-char p)
 335                          (if (re-search-forward eword-encoded-word-regexp
 336                                                 nil t)
 337                              (eword-decode-region beg (point-max) 'unfold))
 338                          )))))
 339           (eword-decode-region (point-min) (point-max) t)
 340           )))))
 341
 342 (defun eword-decode-unfold ()
 343   (goto-char (point-min))
 344   (let (field beg end)
 345     (while (re-search-forward std11-field-head-regexp nil t)
 346       (setq beg (match-beginning 0)
 347             end (std11-field-end))
 348       (setq field (buffer-substring beg end))
 349       (if (string-match eword-encoded-word-regexp field)
 350           (save-restriction
 351             (narrow-to-region (goto-char beg) end)
 352             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 353               (replace-match (match-string 1))
 354               )
 355             (goto-char (point-max))
 356             ))
 357       )))
 358
 359
 360 ;;; @ encoded-word decoder
 361 ;;;
 362
 363 (defvar eword-decode-encoded-word-error-handler
 364   'eword-decode-encoded-word-default-error-handler)
 365
 366 (defvar eword-warning-face nil
 367   "Face used for invalid encoded-word.")
 368
 369 (defun eword-decode-encoded-word-default-error-handler (word signal)
 370   (and (add-text-properties 0 (length word)
 371                             (and eword-warning-face
 372                                  (list 'face eword-warning-face))
 373                             word)
 374        word))
 375
 376 (defun eword-decode-encoded-word (word &optional must-unfold)
 377   "Decode WORD if it is an encoded-word.
 378
 379 If your emacs implementation can not decode the charset of WORD, it
 380 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 381
 382 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 383 if there are in decoded encoded-word (generated by bad manner MUA such
 384 as a version of Net$cape)."
 385   (or (if (string-match eword-encoded-word-regexp word)
 386           (let ((charset
 387                  (substring word (match-beginning 1) (match-end 1))
 388                  )
 389                 (encoding
 390                  (upcase
 391                   (substring word (match-beginning 2) (match-end 2))
 392                   ))
 393                 (text
 394                  (substring word (match-beginning 3) (match-end 3))
 395                  ))
 396             (condition-case err
 397                 (eword-decode-encoded-text charset encoding text must-unfold)
 398               (error
 399                (funcall eword-decode-encoded-word-error-handler word err)
 400                ))
 401             ))
 402       word))
 403
 404
 405 ;;; @ encoded-text decoder
 406 ;;;
 407
 408 (defun eword-decode-encoded-text (charset encoding string
 409                                           &optional must-unfold)
 410   "Decode STRING as an encoded-text.
 411
 412 If your emacs implementation can not decode CHARSET, it returns nil.
 413
 414 If ENCODING is not \"B\" or \"Q\", it occurs error.
 415 So you should write error-handling code if you don't want break by errors.
 416
 417 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 418 if there are in decoded encoded-text (generated by bad manner MUA such
 419 as a version of Net$cape)."
 420   (let ((cs (mime-charset-to-coding-system charset)))
 421     (if cs
 422         (let ((dest (encoded-text-decode-string string encoding)))
 423           (when dest
 424             (setq dest (decode-mime-charset-string dest charset))
 425             (if must-unfold
 426                 (mapconcat (function
 427                             (lambda (chr)
 428                               (cond ((eq chr ?\n) "")
 429                                     ((eq chr ?\t) " ")
 430                                     (t (char-to-string chr)))
 431                               ))
 432                            (std11-unfold-string dest)
 433                            "")
 434               dest))))))
 435
 436
 437 ;;; @ lexical analyze
 438 ;;;
 439
 440 (defvar eword-lexical-analyze-cache nil)
 441 (defvar eword-lexical-analyze-cache-max 299
 442   "*Max position of eword-lexical-analyze-cache.
 443 It is max size of eword-lexical-analyze-cache - 1.")
 444
 445 (defcustom eword-lexical-analyzers
 446   '(eword-analyze-quoted-string
 447     eword-analyze-domain-literal
 448     eword-analyze-comment
 449     eword-analyze-spaces
 450     eword-analyze-special
 451     eword-analyze-encoded-word
 452     eword-analyze-atom)
 453   "*List of functions to return result of lexical analyze.
 454 Each function must have two arguments: STRING and MUST-UNFOLD.
 455 STRING is the target string to be analyzed.
 456 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 457 bare-CR and bare-LF from the result even if they are included in
 458 content of the encoded-word.
 459 Each function must return nil if it can not analyze STRING as its
 460 format.
 461
 462 Previous function is preferred to next function.  If a function
 463 returns nil, next function is used.  Otherwise the return value will
 464 be the result."
 465   :group 'eword-decode
 466   :type '(repeat function))
 467
 468 (defun eword-analyze-quoted-string (string &optional must-unfold)
 469   (let ((p (std11-check-enclosure string ?\" ?\")))
 470     (if p
 471         (cons (cons 'quoted-string
 472                     (decode-mime-charset-string
 473                      (std11-strip-quoted-pair (substring string 1 (1- p)))
 474                      default-mime-charset))
 475               (substring string p))
 476       )))
 477
 478 (defun eword-analyze-domain-literal (string &optional must-unfold)
 479   (std11-analyze-domain-literal string))
 480
 481 (defun eword-analyze-comment (string &optional must-unfold)
 482   (let ((p (std11-check-enclosure string ?\( ?\) t)))
 483     (if p
 484         (cons (cons 'comment
 485                     (eword-decode-string
 486                      (decode-mime-charset-string
 487                       (std11-strip-quoted-pair (substring string 1 (1- p)))
 488                       default-mime-charset)
 489                      must-unfold))
 490               (substring string p))
 491       )))
 492
 493 (defun eword-analyze-spaces (string &optional must-unfold)
 494   (std11-analyze-spaces string))
 495
 496 (defun eword-analyze-special (string &optional must-unfold)
 497   (std11-analyze-special string))
 498
 499 (defun eword-analyze-encoded-word (string &optional must-unfold)
 500   (if (eq (string-match eword-encoded-word-regexp string) 0)
 501       (let ((end (match-end 0))
 502             (dest (eword-decode-encoded-word (match-string 0 string)
 503                                              must-unfold))
 504             )
 505         (setq string (substring string end))
 506         (while (eq (string-match `,(concat "[ \t\n]*\\("
 507                                            eword-encoded-word-regexp
 508                                            "\\)")
 509                                  string)
 510                    0)
 511           (setq end (match-end 0))
 512           (setq dest
 513                 (concat dest
 514                         (eword-decode-encoded-word (match-string 1 string)
 515                                                    must-unfold))
 516                 string (substring string end))
 517           )
 518         (cons (cons 'atom dest) string)
 519         )))
 520
 521 (defun eword-analyze-atom (string &optional must-unfold)
 522   (if (string-match std11-atom-regexp string)
 523       (let ((end (match-end 0)))
 524         (cons (cons 'atom (decode-mime-charset-string
 525                            (substring string 0 end)
 526                            default-mime-charset))
 527               (substring string end)
 528               ))))
 529
 530 (defun eword-lexical-analyze-internal (string must-unfold)
 531   (let (dest ret)
 532     (while (not (string-equal string ""))
 533       (setq ret
 534             (let ((rest eword-lexical-analyzers)
 535                   func r)
 536               (while (and (setq func (car rest))
 537                           (null (setq r (funcall func string must-unfold)))
 538                           )
 539                 (setq rest (cdr rest)))
 540               (or r `((error . ,string) . ""))
 541               ))
 542       (setq dest (cons (car ret) dest))
 543       (setq string (cdr ret))
 544       )
 545     (nreverse dest)
 546     ))
 547
 548 (defun eword-lexical-analyze (string &optional must-unfold)
 549   "Return lexical analyzed list corresponding STRING.
 550 It is like std11-lexical-analyze, but it decodes non us-ascii
 551 characters encoded as encoded-words or invalid \"raw\" format.
 552 \"Raw\" non us-ascii characters are regarded as variable
 553 `default-mime-charset'."
 554   (let ((key (copy-sequence string))
 555         ret)
 556     (set-text-properties 0 (length key) nil key)
 557     (if (setq ret (assoc key eword-lexical-analyze-cache))
 558         (cdr ret)
 559       (setq ret (eword-lexical-analyze-internal key must-unfold))
 560       (setq eword-lexical-analyze-cache
 561             (cons (cons key ret)
 562                   (last eword-lexical-analyze-cache
 563                         eword-lexical-analyze-cache-max)))
 564       ret)))
 565
 566 (defun eword-decode-token (token)
 567   (let ((type (car token))
 568         (value (cdr token)))
 569     (cond ((eq type 'quoted-string)
 570            (std11-wrap-as-quoted-string value))
 571           ((eq type 'comment)
 572            (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")"))
 573           (t value))))
 574
 575 (defun eword-extract-address-components (string)
 576   "Extract full name and canonical address from STRING.
 577 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 578 If no name can be extracted, FULL-NAME will be nil.
 579 It decodes non us-ascii characters in FULL-NAME encoded as
 580 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 581 characters are regarded as variable `default-mime-charset'."
 582   (let* ((structure (car (std11-parse-address
 583                           (eword-lexical-analyze
 584                            (std11-unfold-string string) 'must-unfold))))
 585          (phrase  (std11-full-name-string structure))
 586          (address (std11-address-string structure))
 587          )
 588     (list phrase address)
 589     ))
 590
 591
 592 ;;; @ end
 593 ;;;
 594
 595 (provide 'eword-decode)
 596
 597 ;;; eword-decode.el ends here