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-parse)
  35 (require 'mel)
  36 (require 'mime-def)
  37
  38 (defgroup eword-decode nil
  39   "Encoded-word decoding"
  40   :group 'mime)
  41
  42 (defconst eword-decode-version "1.2.2")
  43
  44
  45 ;;; @ MIME encoded-word definition
  46 ;;;
  47
  48 (defconst eword-encoded-text-regexp "[!->@-~]+")
  49 (defconst eword-encoded-word-regexp
  50   (concat (regexp-quote "=?")
  51           "\\("
  52           mime-charset-regexp
  53           "\\)"
  54           (regexp-quote "?")
  55           "\\(B\\|Q\\)"
  56           (regexp-quote "?")
  57           "\\("
  58           eword-encoded-text-regexp
  59           "\\)"
  60           (regexp-quote "?=")))
  61
  62
  63 ;;; @@ Base64
  64 ;;;
  65
  66 (defconst base64-token-regexp "[A-Za-z0-9+/]")
  67 (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
  68
  69 (defconst eword-B-encoded-text-regexp
  70   (concat "\\(\\("
  71           base64-token-regexp
  72           base64-token-regexp
  73           base64-token-regexp
  74           base64-token-regexp
  75           "\\)*"
  76           base64-token-regexp
  77           base64-token-regexp
  78           base64-token-padding-regexp
  79           base64-token-padding-regexp
  80           "\\)"))
  81
  82 ;; (defconst eword-B-encoding-and-encoded-text-regexp
  83 ;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
  84
  85
  86 ;;; @@ Quoted-Printable
  87 ;;;
  88
  89 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
  90 (defconst quoted-printable-octet-regexp
  91   (concat "=[" quoted-printable-hex-chars
  92           "][" quoted-printable-hex-chars "]"))
  93
  94 (defconst eword-Q-encoded-text-regexp
  95   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
  96 ;; (defconst eword-Q-encoding-and-encoded-text-regexp
  97 ;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
  98
  99
 100 ;;; @ for string
 101 ;;;
 102
 103 (defun eword-decode-string (string &optional must-unfold)
 104   "Decode MIME encoded-words in STRING.
 105
 106 STRING is unfolded before decoding.
 107
 108 If an encoded-word is broken or your emacs implementation can not
 109 decode the charset included in it, it is not decoded.
 110
 111 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 112 if there are in decoded encoded-words (generated by bad manner MUA
 113 such as a version of Net$cape)."
 114   (setq string (std11-unfold-string string))
 115   (let ((dest "")(ew nil)
 116         beg end)
 117     (while (and (string-match eword-encoded-word-regexp string)
 118                 (setq beg (match-beginning 0)
 119                       end (match-end 0))
 120                 )
 121       (if (> beg 0)
 122           (if (not
 123                (and (eq ew t)
 124                     (string-match "^[ \t]+$" (substring string 0 beg))
 125                     ))
 126               (setq dest (concat dest (substring string 0 beg)))
 127             )
 128         )
 129       (setq dest
 130             (concat dest
 131                     (eword-decode-encoded-word
 132                      (substring string beg end) must-unfold)
 133                     ))
 134       (setq string (substring string end))
 135       (setq ew t)
 136       )
 137     (concat dest string)
 138     ))
 139
 140
 141 ;;; @ for region
 142 ;;;
 143
 144 (defun eword-decode-region (start end &optional unfolding must-unfold)
 145   "Decode MIME encoded-words in region between START and END.
 146
 147 If UNFOLDING is not nil, it unfolds before decoding.
 148
 149 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 150 if there are in decoded encoded-words (generated by bad manner MUA
 151 such as a version of Net$cape)."
 152   (interactive "*r")
 153   (save-excursion
 154     (save-restriction
 155       (narrow-to-region start end)
 156       (if unfolding
 157           (eword-decode-unfold)
 158         )
 159       (goto-char (point-min))
 160       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
 161                                         "\\(\n?[ \t]\\)+"
 162                                         "\\(" eword-encoded-word-regexp "\\)")
 163                                 nil t)
 164         (replace-match "\\1\\6")
 165         (goto-char (point-min))
 166         )
 167       (while (re-search-forward eword-encoded-word-regexp nil t)
 168         (insert (eword-decode-encoded-word
 169                  (prog1
 170                      (buffer-substring (match-beginning 0) (match-end 0))
 171                    (delete-region (match-beginning 0) (match-end 0))
 172                    ) must-unfold))
 173         )
 174       )))
 175
 176
 177 ;;; @ for message header
 178 ;;;
 179
 180 (defcustom eword-decode-ignored-field-list
 181   '(newsgroups path lines nntp-posting-host message-id date)
 182   "*List of field-names to be ignored when decoding.
 183 Each field name must be symbol."
 184   :group 'eword-decode
 185   :type '(repeat symbol))
 186
 187 (defcustom eword-decode-structured-field-list
 188   '(reply-to resent-reply-to from resent-from sender resent-sender
 189              to resent-to cc resent-cc bcc resent-bcc dcc
 190              mime-version content-type content-transfer-encoding
 191              content-disposition)
 192   "*List of field-names to decode as structured field.
 193 Each field name must be symbol."
 194   :group 'eword-decode
 195   :type '(repeat symbol))
 196
 197 (defun eword-decode-header (&optional code-conversion separator)
 198   "Decode MIME encoded-words in header fields.
 199 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 200 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 201 Otherwise it decodes non-ASCII bit patterns as the
 202 default-mime-charset.
 203 If SEPARATOR is not nil, it is used as header separator."
 204   (interactive "*")
 205   (save-excursion
 206     (save-restriction
 207       (std11-narrow-to-header separator)
 208       (let ((default-charset
 209               (if code-conversion
 210                   (if (mime-charset-to-coding-system code-conversion)
 211                       code-conversion
 212                     default-mime-charset))))
 213         (if default-charset
 214             (let (beg p end field-name len)
 215               (goto-char (point-min))
 216               (while (re-search-forward std11-field-head-regexp nil t)
 217                 (setq beg (match-beginning 0)
 218                       p (match-end 0)
 219                       field-name (buffer-substring beg (1- p))
 220                       len (string-width field-name)
 221                       field-name (intern (downcase field-name))
 222                       end (std11-field-end))
 223                 (cond ((memq field-name eword-decode-ignored-field-list)
 224                        ;; Don't decode
 225                        )
 226                       ((memq field-name eword-decode-structured-field-list)
 227                        ;; Decode as structured field
 228                        (let ((body (buffer-substring p end))
 229                              (default-mime-charset default-charset))
 230                          (delete-region p end)
 231                          (insert (eword-decode-and-fold-structured-field
 232                                   body (1+ len)))
 233                          ))
 234                       (t
 235                        ;; Decode as unstructured field
 236                        (save-restriction
 237                          (narrow-to-region beg (1+ end))
 238                          (decode-mime-charset-region p end default-charset)
 239                          (goto-char p)
 240                          (if (re-search-forward eword-encoded-word-regexp
 241                                                 nil t)
 242                              (eword-decode-region beg (point-max) 'unfold))
 243                          )))))
 244           (eword-decode-region (point-min) (point-max) t)
 245           )))))
 246
 247 (defun eword-decode-unfold ()
 248   (goto-char (point-min))
 249   (let (field beg end)
 250     (while (re-search-forward std11-field-head-regexp nil t)
 251       (setq beg (match-beginning 0)
 252             end (std11-field-end))
 253       (setq field (buffer-substring beg end))
 254       (if (string-match eword-encoded-word-regexp field)
 255           (save-restriction
 256             (narrow-to-region (goto-char beg) end)
 257             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 258               (replace-match (match-string 1))
 259               )
 260             (goto-char (point-max))
 261             ))
 262       )))
 263
 264
 265 ;;; @ encoded-word decoder
 266 ;;;
 267
 268 (defvar eword-warning-face nil "Face used for invalid encoded-word.")
 269
 270 (defun eword-decode-encoded-word (word &optional must-unfold)
 271   "Decode WORD if it is an encoded-word.
 272
 273 If your emacs implementation can not decode the charset of WORD, it
 274 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 275
 276 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 277 if there are in decoded encoded-word (generated by bad manner MUA such
 278 as a version of Net$cape)."
 279   (or (if (string-match eword-encoded-word-regexp word)
 280           (let ((charset
 281                  (substring word (match-beginning 1) (match-end 1))
 282                  )
 283                 (encoding
 284                  (upcase
 285                   (substring word (match-beginning 2) (match-end 2))
 286                   ))
 287                 (text
 288                  (substring word (match-beginning 3) (match-end 3))
 289                  ))
 290             (condition-case err
 291                 (eword-decode-encoded-text charset encoding text must-unfold)
 292               (error
 293                (and
 294                 (add-text-properties 0 (length word)
 295                                      (and eword-warning-face
 296                                           (list 'face eword-warning-face))
 297                                      word)
 298                 word)))
 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