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           (when dest
 337             (setq dest (decode-mime-charset-string dest charset))
 338             (if must-unfold
 339                 (mapconcat (function
 340                             (lambda (chr)
 341                               (cond ((eq chr ?\n) "")
 342                                     ((eq chr ?\t) " ")
 343                                     (t (char-to-string chr)))
 344                               ))
 345                            (std11-unfold-string dest)
 346                            "")
 347               dest))))))
 348
 349
 350 ;;; @ lexical analyze
 351 ;;;
 352
 353 (defvar eword-lexical-analyze-cache nil)
 354 (defvar eword-lexical-analyze-cache-max 299
 355   "*Max position of eword-lexical-analyze-cache.
 356 It is max size of eword-lexical-analyze-cache - 1.")
 357
 358 (defcustom eword-lexical-analyzers
 359   '(eword-analyze-quoted-string
 360     eword-analyze-domain-literal
 361     eword-analyze-comment
 362     eword-analyze-spaces
 363     eword-analyze-special
 364     eword-analyze-encoded-word
 365     eword-analyze-atom)
 366   "*List of functions to return result of lexical analyze.
 367 Each function must have two arguments: STRING and MUST-UNFOLD.
 368 STRING is the target string to be analyzed.
 369 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 370 bare-CR and bare-LF from the result even if they are included in
 371 content of the encoded-word.
 372 Each function must return nil if it can not analyze STRING as its
 373 format.
 374
 375 Previous function is preferred to next function.  If a function
 376 returns nil, next function is used.  Otherwise the return value will
 377 be the result."
 378   :group 'eword-decode
 379   :type '(repeat function))
 380
 381 (defun eword-analyze-quoted-string (string &optional must-unfold)
 382   (let ((p (std11-check-enclosure string ?\" ?\")))
 383     (if p
 384         (cons (cons 'quoted-string
 385                     (decode-mime-charset-string
 386                      (std11-strip-quoted-pair (substring string 1 (1- p)))
 387                      default-mime-charset))
 388               (substring string p))
 389       )))
 390
 391 (defun eword-analyze-domain-literal (string &optional must-unfold)
 392   (std11-analyze-domain-literal string))
 393
 394 (defun eword-analyze-comment (string &optional must-unfold)
 395   (let ((p (std11-check-enclosure string ?\( ?\) t)))
 396     (if p
 397         (cons (cons 'comment
 398                     (eword-decode-string
 399                      (decode-mime-charset-string
 400                       (std11-strip-quoted-pair (substring string 1 (1- p)))
 401                       default-mime-charset)
 402                      must-unfold))
 403               (substring string p))
 404       )))
 405
 406 (defun eword-analyze-spaces (string &optional must-unfold)
 407   (std11-analyze-spaces string))
 408
 409 (defun eword-analyze-special (string &optional must-unfold)
 410   (std11-analyze-special string))
 411
 412 (defun eword-analyze-encoded-word (string &optional must-unfold)
 413   (if (eq (string-match eword-encoded-word-regexp string) 0)
 414       (let ((end (match-end 0))
 415             (dest (eword-decode-encoded-word (match-string 0 string)
 416                                              must-unfold))
 417             )
 418         (setq string (substring string end))
 419         (while (eq (string-match `,(concat "[ \t\n]*\\("
 420                                            eword-encoded-word-regexp
 421                                            "\\)")
 422                                  string)
 423                    0)
 424           (setq end (match-end 0))
 425           (setq dest
 426                 (concat dest
 427                         (eword-decode-encoded-word (match-string 1 string)
 428                                                    must-unfold))
 429                 string (substring string end))
 430           )
 431         (cons (cons 'atom dest) string)
 432         )))
 433
 434 (defun eword-analyze-atom (string &optional must-unfold)
 435   (if (string-match std11-atom-regexp string)
 436       (let ((end (match-end 0)))
 437         (cons (cons 'atom (decode-mime-charset-string
 438                            (substring string 0 end)
 439                            default-mime-charset))
 440               (substring string end)
 441               ))))
 442
 443 (defun eword-lexical-analyze-internal (string must-unfold)
 444   (let (dest ret)
 445     (while (not (string-equal string ""))
 446       (setq ret
 447             (let ((rest eword-lexical-analyzers)
 448                   func r)
 449               (while (and (setq func (car rest))
 450                           (null (setq r (funcall func string must-unfold)))
 451                           )
 452                 (setq rest (cdr rest)))
 453               (or r `((error . ,string) . ""))
 454               ))
 455       (setq dest (cons (car ret) dest))
 456       (setq string (cdr ret))
 457       )
 458     (nreverse dest)
 459     ))
 460
 461 (defun eword-lexical-analyze (string &optional must-unfold)
 462   "Return lexical analyzed list corresponding STRING.
 463 It is like std11-lexical-analyze, but it decodes non us-ascii
 464 characters encoded as encoded-words or invalid \"raw\" format.
 465 \"Raw\" non us-ascii characters are regarded as variable
 466 `default-mime-charset'."
 467   (let ((key (copy-sequence string))
 468         ret)
 469     (set-text-properties 0 (length key) nil key)
 470     (if (setq ret (assoc key eword-lexical-analyze-cache))
 471         (cdr ret)
 472       (setq ret (eword-lexical-analyze-internal key must-unfold))
 473       (setq eword-lexical-analyze-cache
 474             (cons (cons key ret)
 475                   (last eword-lexical-analyze-cache
 476                         eword-lexical-analyze-cache-max)))
 477       ret)))
 478
 479 (defun eword-decode-token (token)
 480   (let ((type (car token))
 481         (value (cdr token)))
 482     (cond ((eq type 'quoted-string)
 483            (std11-wrap-as-quoted-string value))
 484           ((eq type 'comment)
 485            (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")"))
 486           (t value))))
 487
 488 (defun eword-decode-and-fold-structured-field
 489   (string start-column &optional max-column must-unfold)
 490   "Decode and fold (fill) STRING as structured field body.
 491 It decodes non us-ascii characters in FULL-NAME encoded as
 492 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 493 characters are regarded as variable `default-mime-charset'.
 494
 495 If an encoded-word is broken or your emacs implementation can not
 496 decode the charset included in it, it is not decoded.
 497
 498 If MAX-COLUMN is omitted, `fill-column' is used.
 499
 500 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 501 if there are in decoded encoded-words (generated by bad manner MUA
 502 such as a version of Net$cape)."
 503   (or max-column
 504       (setq max-column fill-column))
 505   (let ((c start-column)
 506         (tokens (eword-lexical-analyze string must-unfold))
 507         (result "")
 508         token)
 509     (while (and (setq token (car tokens))
 510                 (setq tokens (cdr tokens)))
 511       (let* ((type (car token)))
 512         (if (eq type 'spaces)
 513             (let* ((next-token (car tokens))
 514                    (next-str (eword-decode-token next-token))
 515                    (next-len (string-width next-str))
 516                    (next-c (+ c next-len 1)))
 517               (if (< next-c max-column)
 518                   (setq result (concat result " " next-str)
 519                         c next-c)
 520                 (setq result (concat result "\n " next-str)
 521                       c (1+ next-len)))
 522               (setq tokens (cdr tokens))
 523               )
 524           (let* ((str (eword-decode-token token)))
 525             (setq result (concat result str)
 526                   c (+ c (string-width str)))
 527             ))))
 528     (if token
 529         (concat result (eword-decode-token token))
 530       result)))
 531
 532 (defun eword-decode-and-unfold-structured-field (string)
 533   "Decode and unfold STRING as structured field body.
 534 It decodes non us-ascii characters in FULL-NAME encoded as
 535 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 536 characters are regarded as variable `default-mime-charset'.
 537
 538 If an encoded-word is broken or your emacs implementation can not
 539 decode the charset included in it, it is not decoded."
 540   (let ((tokens (eword-lexical-analyze string 'must-unfold))
 541         (result ""))
 542     (while tokens
 543       (let* ((token (car tokens))
 544              (type (car token)))
 545         (setq tokens (cdr tokens))
 546         (setq result
 547               (if (eq type 'spaces)
 548                   (concat result " ")
 549                 (concat result (eword-decode-token token))
 550                 ))))
 551     result))
 552
 553 (defun eword-decode-structured-field-body (string &optional must-unfold
 554                                                   start-column max-column)
 555   "Decode non us-ascii characters in STRING as structured field body.
 556 STRING is unfolded before decoding.
 557
 558 It decodes non us-ascii characters in FULL-NAME encoded as
 559 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 560 characters are regarded as variable `default-mime-charset'.
 561
 562 If an encoded-word is broken or your emacs implementation can not
 563 decode the charset included in it, it is not decoded.
 564
 565 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 566 if there are in decoded encoded-words (generated by bad manner MUA
 567 such as a version of Net$cape)."
 568   (if start-column
 569       ;; fold with max-column
 570       (eword-decode-and-fold-structured-field
 571        string start-column max-column must-unfold)
 572     ;; Don't fold
 573     (mapconcat (function eword-decode-token)
 574                (eword-lexical-analyze string must-unfold)
 575                "")
 576     ))
 577
 578 (defun eword-decode-unstructured-field-body (string &optional must-unfold)
 579   "Decode non us-ascii characters in STRING as unstructured field body.
 580 STRING is unfolded before decoding.
 581
 582 It decodes non us-ascii characters in FULL-NAME encoded as
 583 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 584 characters are regarded as variable `default-mime-charset'.
 585
 586 If an encoded-word is broken or your emacs implementation can not
 587 decode the charset included in it, it is not decoded.
 588
 589 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 590 if there are in decoded encoded-words (generated by bad manner MUA
 591 such as a version of Net$cape)."
 592   (eword-decode-string
 593    (decode-mime-charset-string string default-mime-charset)
 594    must-unfold))
 595
 596 (defun eword-extract-address-components (string)
 597   "Extract full name and canonical address from STRING.
 598 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 599 If no name can be extracted, FULL-NAME will be nil.
 600 It decodes non us-ascii characters in FULL-NAME encoded as
 601 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 602 characters are regarded as variable `default-mime-charset'."
 603   (let* ((structure (car (std11-parse-address
 604                           (eword-lexical-analyze
 605                            (std11-unfold-string string) 'must-unfold))))
 606          (phrase  (std11-full-name-string structure))
 607          (address (std11-address-string structure))
 608          )
 609     (list phrase address)
 610     ))
 611
 612
 613 ;;; @ end
 614 ;;;
 615
 616 (provide 'eword-decode)
 617
 618 ;;; eword-decode.el ends here