eword-decode.el

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