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