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