eword-decode.el

   1 ;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 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 ;; Version: $Revision: 1.3 $
  14 ;; Keywords: encoded-word, MIME, multilingual, header, mail, news
  15
  16 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  17
  18 ;; This program is free software; you can redistribute it and/or
  19 ;; modify it under the terms of the GNU General Public License as
  20 ;; published by the Free Software Foundation; either version 2, or (at
  21 ;; your option) any later version.
  22
  23 ;; This program is distributed in the hope that it will be useful, but
  24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  26 ;; General Public License for more details.
  27
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  31 ;; Boston, MA 02111-1307, USA.
  32
  33 ;;; Code:
  34
  35 (require 'std11-parse)
  36 (require 'mel)
  37 (require 'mime-def)
  38
  39 (defgroup eword-decode nil
  40   "Encoded-word decoding"
  41   :group 'mime)
  42
  43
  44 ;;; @ version
  45 ;;;
  46
  47 (defconst eword-decode-RCS-ID
  48   "$Id: eword-decode.el,v 1.3 1998-02-16 20:40:19 morioka Exp $")
  49 (defconst eword-decode-version (get-version-string eword-decode-RCS-ID))
  50
  51
  52 ;;; @ MIME encoded-word definition
  53 ;;;
  54
  55 (defconst eword-encoded-text-regexp "[!->@-~]+")
  56 (defconst eword-encoded-word-regexp
  57   (concat (regexp-quote "=?")
  58           "\\("
  59           mime-charset-regexp
  60           "\\)"
  61           (regexp-quote "?")
  62           "\\(B\\|Q\\)"
  63           (regexp-quote "?")
  64           "\\("
  65           eword-encoded-text-regexp
  66           "\\)"
  67           (regexp-quote "?=")))
  68
  69
  70 ;;; @@ Base64
  71 ;;;
  72
  73 (defconst base64-token-regexp "[A-Za-z0-9+/]")
  74 (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
  75
  76 (defconst eword-B-encoded-text-regexp
  77   (concat "\\(\\("
  78           base64-token-regexp
  79           base64-token-regexp
  80           base64-token-regexp
  81           base64-token-regexp
  82           "\\)*"
  83           base64-token-regexp
  84           base64-token-regexp
  85           base64-token-padding-regexp
  86           base64-token-padding-regexp
  87           "\\)"))
  88
  89 ;; (defconst eword-B-encoding-and-encoded-text-regexp
  90 ;;   (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
  91
  92
  93 ;;; @@ Quoted-Printable
  94 ;;;
  95
  96 (defconst quoted-printable-hex-chars "0123456789ABCDEF")
  97 (defconst quoted-printable-octet-regexp
  98   (concat "=[" quoted-printable-hex-chars
  99           "][" quoted-printable-hex-chars "]"))
 100
 101 (defconst eword-Q-encoded-text-regexp
 102   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
 103 ;; (defconst eword-Q-encoding-and-encoded-text-regexp
 104 ;;   (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
 105
 106
 107 ;;; @ for string
 108 ;;;
 109
 110 (defun eword-decode-string (string &optional must-unfold)
 111   "Decode MIME encoded-words in STRING.
 112
 113 STRING is unfolded before decoding.
 114
 115 If an encoded-word is broken or your emacs implementation can not
 116 decode the charset included in it, it is not decoded.
 117
 118 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 119 if there are in decoded encoded-words (generated by bad manner MUA
 120 such as a version of Net$cape)."
 121   (setq string (std11-unfold-string string))
 122   (let ((dest "")(ew nil)
 123         beg end)
 124     (while (and (string-match eword-encoded-word-regexp string)
 125                 (setq beg (match-beginning 0)
 126                       end (match-end 0))
 127                 )
 128       (if (> beg 0)
 129           (if (not
 130                (and (eq ew t)
 131                     (string-match "^[ \t]+$" (substring string 0 beg))
 132                     ))
 133               (setq dest (concat dest (substring string 0 beg)))
 134             )
 135         )
 136       (setq dest
 137             (concat dest
 138                     (eword-decode-encoded-word
 139                      (substring string beg end) must-unfold)
 140                     ))
 141       (setq string (substring string end))
 142       (setq ew t)
 143       )
 144     (concat dest string)
 145     ))
 146
 147
 148 ;;; @ for region
 149 ;;;
 150
 151 (defun eword-decode-region (start end &optional unfolding must-unfold)
 152   "Decode MIME encoded-words in region between START and END.
 153
 154 If UNFOLDING is not nil, it unfolds before decoding.
 155
 156 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 157 if there are in decoded encoded-words (generated by bad manner MUA
 158 such as a version of Net$cape)."
 159   (interactive "*r")
 160   (save-excursion
 161     (save-restriction
 162       (narrow-to-region start end)
 163       (if unfolding
 164           (eword-decode-unfold)
 165         )
 166       (goto-char (point-min))
 167       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
 168                                         "\\(\n?[ \t]\\)+"
 169                                         "\\(" eword-encoded-word-regexp "\\)")
 170                                 nil t)
 171         (replace-match "\\1\\6")
 172         (goto-char (point-min))
 173         )
 174       (while (re-search-forward eword-encoded-word-regexp nil t)
 175         (insert (eword-decode-encoded-word
 176                  (prog1
 177                      (buffer-substring (match-beginning 0) (match-end 0))
 178                    (delete-region (match-beginning 0) (match-end 0))
 179                    ) must-unfold))
 180         )
 181       )))
 182
 183
 184 ;;; @ for message header
 185 ;;;
 186
 187 (defcustom eword-decode-ignored-field-list
 188   '(newsgroups message-id path)
 189   "*List of field-names to be ignored when decoding.
 190 Each field name must be symbol."
 191   :group 'eword-decode
 192   :type '(repeat symbol))
 193
 194 (defcustom eword-decode-structured-field-list
 195   '(reply-to resent-reply-to from resent-from sender resent-sender
 196              to resent-to cc resent-cc bcc resent-bcc dcc
 197              mime-version content-type content-transfer-encoding
 198              content-disposition)
 199   "*List of field-names to decode as structured field.
 200 Each field name must be symbol."
 201   :group 'eword-decode
 202   :type '(repeat symbol))
 203
 204 (defun eword-decode-header (&optional code-conversion separator)
 205   "Decode MIME encoded-words in header fields.
 206 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 207 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 208 Otherwise it decodes non-ASCII bit patterns as the
 209 default-mime-charset.
 210 If SEPARATOR is not nil, it is used as header separator."
 211   (interactive "*")
 212   (save-excursion
 213     (save-restriction
 214       (std11-narrow-to-header separator)
 215       (let ((default-charset
 216               (if code-conversion
 217                   (if (mime-charset-to-coding-system code-conversion)
 218                       code-conversion
 219                     default-mime-charset))))
 220         (if default-charset
 221             (let (beg end field-name)
 222               (goto-char (point-min))
 223               (while (re-search-forward std11-field-head-regexp nil t)
 224                 (setq beg (match-beginning 0)
 225                       p (match-end 0)
 226                       field-name (intern
 227                                   (downcase (buffer-substring beg (1- p))))
 228                       end (std11-field-end))
 229                 (cond ((memq field-name eword-decode-ignored-field-list)
 230                        ;; Don't decode
 231                        )
 232                       ((memq field-name eword-decode-structured-field-list)
 233                        ;; Decode as structured field
 234                        (let ((body (buffer-substring p end))
 235                              (default-mime-charset default-charset))
 236                          (delete-region p end)
 237                          (insert (eword-decode-structured-field-body body))
 238                          ))
 239                       (t
 240                        ;; Decode as unstructured field
 241                        (save-restriction
 242                          (narrow-to-region p end)
 243                          (decode-mime-charset-region p end default-charset)
 244                          (eword-decode-region p (point-max))
 245                          )))))
 246           (eword-decode-region (point-min) (point-max) t)
 247           )))))
 248
 249 (defun eword-decode-unfold ()
 250   (goto-char (point-min))
 251   (let (field beg end)
 252     (while (re-search-forward std11-field-head-regexp nil t)
 253       (setq beg (match-beginning 0)
 254             end (std11-field-end))
 255       (setq field (buffer-substring beg end))
 256       (if (string-match eword-encoded-word-regexp field)
 257           (save-restriction
 258             (narrow-to-region (goto-char beg) end)
 259             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 260               (replace-match (match-string 1))
 261               )
 262             (goto-char (point-max))
 263             ))
 264       )))
 265
 266
 267 ;;; @ encoded-word decoder
 268 ;;;
 269
 270 (defvar eword-warning-face nil "Face used for invalid encoded-word.")
 271
 272 (defun eword-decode-encoded-word (word &optional must-unfold)
 273   "Decode WORD if it is an encoded-word.
 274
 275 If your emacs implementation can not decode the charset of WORD, it
 276 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 277
 278 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 279 if there are in decoded encoded-word (generated by bad manner MUA such
 280 as a version of Net$cape)."
 281   (or (if (string-match eword-encoded-word-regexp word)
 282           (let ((charset
 283                  (substring word (match-beginning 1) (match-end 1))
 284                  )
 285                 (encoding
 286                  (upcase
 287                   (substring word (match-beginning 2) (match-end 2))
 288                   ))
 289                 (text
 290                  (substring word (match-beginning 3) (match-end 3))
 291                  ))
 292             (condition-case err
 293                 (eword-decode-encoded-text charset encoding text must-unfold)
 294               (error
 295                (and
 296                 (add-text-properties 0 (length word)
 297                                      (and eword-warning-face
 298                                           (list 'face eword-warning-face))
 299                                      word)
 300                 word)))
 301             ))
 302       word))
 303
 304
 305 ;;; @ encoded-text decoder
 306 ;;;
 307
 308 (defun eword-decode-encoded-text (charset encoding string
 309                                           &optional must-unfold)
 310   "Decode STRING as an encoded-text.
 311
 312 If your emacs implementation can not decode CHARSET, it returns nil.
 313
 314 If ENCODING is not \"B\" or \"Q\", it occurs error.
 315 So you should write error-handling code if you don't want break by errors.
 316
 317 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 318 if there are in decoded encoded-text (generated by bad manner MUA such
 319 as a version of Net$cape)."
 320   (let ((cs (mime-charset-to-coding-system charset)))
 321     (if cs
 322         (let ((dest
 323                (cond
 324                 ((string-equal "B" encoding)
 325                  (if (and (string-match eword-B-encoded-text-regexp string)
 326                           (string-equal string (match-string 0 string)))
 327                      (base64-decode-string string)
 328                    (error "Invalid encoded-text %s" string)))
 329                 ((string-equal "Q" encoding)
 330                  (if (and (string-match eword-Q-encoded-text-regexp string)
 331                           (string-equal string (match-string 0 string)))
 332                      (q-encoding-decode-string string)
 333                    (error "Invalid encoded-text %s" string)))
 334                 (t
 335                  (error "Invalid encoding %s" encoding)
 336                  )))
 337               )
 338           (if dest
 339               (progn
 340                 (setq dest (decode-coding-string dest cs))
 341                 (if must-unfold
 342                     (mapconcat (function
 343                                 (lambda (chr)
 344                                   (cond
 345                                    ((eq chr ?\n) "")
 346                                    ((eq chr ?\t) " ")
 347                                    (t (char-to-string chr)))
 348                                   ))
 349                                (std11-unfold-string dest)
 350                                "")
 351                   dest)
 352                 ))))))
 353
 354
 355 ;;; @ lexical analyze
 356 ;;;
 357
 358 (defvar eword-lexical-analyze-cache nil)
 359 (defvar eword-lexical-analyze-cache-max 299
 360   "*Max position of eword-lexical-analyze-cache.
 361 It is max size of eword-lexical-analyze-cache - 1.")
 362
 363 (defun eword-analyze-quoted-string (string)
 364   (let ((p (std11-check-enclosure string ?\" ?\")))
 365     (if p
 366         (cons (cons 'quoted-string
 367                     (decode-mime-charset-string
 368                      (std11-strip-quoted-pair (substring string 1 (1- p)))
 369                      default-mime-charset))
 370               (substring string p))
 371       )))
 372
 373 (defun eword-analyze-comment (string &optional must-unfold)
 374   (let ((p (std11-check-enclosure string ?\( ?\) t)))
 375     (if p
 376         (cons (cons 'comment
 377                     (eword-decode-string
 378                      (decode-mime-charset-string
 379                       (std11-strip-quoted-pair (substring string 1 (1- p)))
 380                       default-mime-charset)
 381                      must-unfold))
 382               (substring string p))
 383       )))
 384
 385 (defun eword-analyze-encoded-word (string &optional must-unfold)
 386   (if (eq (string-match eword-encoded-word-regexp string) 0)
 387       (let ((end (match-end 0))
 388             (dest (eword-decode-encoded-word (match-string 0 string)
 389                                              must-unfold))
 390             )
 391         (setq string (substring string end))
 392         (while (eq (string-match `,(concat "[ \t\n]*\\("
 393                                            eword-encoded-word-regexp
 394                                            "\\)")
 395                                  string)
 396                    0)
 397           (setq end (match-end 0))
 398           (setq dest
 399                 (concat dest
 400                         (eword-decode-encoded-word (match-string 1 string)
 401                                                    must-unfold))
 402                 string (substring string end))
 403           )
 404         (cons (cons 'atom dest) string)
 405         )))
 406
 407 (defun eword-analyze-atom (string)
 408   (if (string-match std11-atom-regexp string)
 409       (let ((end (match-end 0)))
 410         (cons (cons 'atom (decode-mime-charset-string
 411                            (substring string 0 end)
 412                            default-mime-charset))
 413               (substring string end)
 414               ))))
 415
 416 (defun eword-lexical-analyze-internal (string must-unfold)
 417   (let (dest ret)
 418     (while (not (string-equal string ""))
 419       (setq ret
 420             (or (eword-analyze-quoted-string string)
 421                 (std11-analyze-domain-literal string)
 422                 (eword-analyze-comment string must-unfold)
 423                 (std11-analyze-spaces string)
 424                 (std11-analyze-special string)
 425                 (eword-analyze-encoded-word string must-unfold)
 426                 (eword-analyze-atom string)
 427                 '((error) . "")
 428                 ))
 429       (setq dest (cons (car ret) dest))
 430       (setq string (cdr ret))
 431       )
 432     (nreverse dest)
 433     ))
 434
 435 (defun eword-lexical-analyze (string &optional must-unfold)
 436   "Return lexical analyzed list corresponding STRING.
 437 It is like std11-lexical-analyze, but it decodes non us-ascii
 438 characters encoded as encoded-words or invalid \"raw\" format.
 439 \"Raw\" non us-ascii characters are regarded as variable
 440 `default-mime-charset'."
 441   (let ((key (copy-sequence string))
 442         ret)
 443     (set-text-properties 0 (length key) nil key)
 444     (if (setq ret (assoc key eword-lexical-analyze-cache))
 445         (cdr ret)
 446       (setq ret (eword-lexical-analyze-internal key must-unfold))
 447       (setq eword-lexical-analyze-cache
 448             (cons (cons key ret)
 449                   (last eword-lexical-analyze-cache
 450                         eword-lexical-analyze-cache-max)))
 451       ret)))
 452
 453 (defun eword-decode-structured-field-body (string &optional must-unfold)
 454   "Decode non us-ascii characters in STRING as structured field body.
 455 STRING is unfolded before decoding.
 456
 457 It decodes non us-ascii characters in FULL-NAME encoded as
 458 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 459 characters are regarded as variable `default-mime-charset'.
 460
 461 If an encoded-word is broken or your emacs implementation can not
 462 decode the charset included in it, it is not decoded.
 463
 464 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 465 if there are in decoded encoded-words (generated by bad manner MUA
 466 such as a version of Net$cape)."
 467   (mapconcat (function
 468               (lambda (token)
 469                 (let ((type (car token))
 470                       (value (cdr token)))
 471                   (cond ((eq type 'quoted-string)
 472                          (std11-wrap-as-quoted-string value)
 473                          )
 474                         ((eq type 'comment)
 475                          (concat "("
 476                                  (std11-wrap-as-quoted-pairs value '(?( ?)))
 477                                  ")")
 478                          )
 479                         (t
 480                          value)))))
 481              (eword-lexical-analyze string must-unfold)
 482              ""))
 483
 484 (defun eword-decode-unstructured-field-body (string &optional must-unfold)
 485   "Decode non us-ascii characters in STRING as unstructured field body.
 486 STRING is unfolded before decoding.
 487
 488 It decodes non us-ascii characters in FULL-NAME encoded as
 489 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 490 characters are regarded as variable `default-mime-charset'.
 491
 492 If an encoded-word is broken or your emacs implementation can not
 493 decode the charset included in it, it is not decoded.
 494
 495 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 496 if there are in decoded encoded-words (generated by bad manner MUA
 497 such as a version of Net$cape)."
 498   (eword-decode-string
 499    (decode-mime-charset-string string default-mime-charset)
 500    must-unfold))
 501
 502 (defun eword-extract-address-components (string)
 503   "Extract full name and canonical address from STRING.
 504 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 505 If no name can be extracted, FULL-NAME will be nil.
 506 It decodes non us-ascii characters in FULL-NAME encoded as
 507 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 508 characters are regarded as variable `default-mime-charset'."
 509   (let* ((structure (car (std11-parse-address
 510                           (eword-lexical-analyze
 511                            (std11-unfold-string string) 'must-unfold))))
 512          (phrase  (std11-full-name-string structure))
 513          (address (std11-address-string structure))
 514          )
 515     (list phrase address)
 516     ))
 517
 518
 519 ;;; @ end
 520 ;;;
 521
 522 (provide 'eword-decode)
 523
 524 ;;; eword-decode.el ends here