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