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 (defcustom eword-max-size-to-decode 1000
  43   "*Max size to decode header field."
  44   :group 'eword-decode
  45   :type '(choice (integer :tag "Limit (bytes)")
  46                  (const :tag "Don't limit" nil)))
  47
  48
  49 ;;; @ MIME encoded-word definition
  50 ;;;
  51
  52 (defconst eword-encoded-text-regexp "[!->@-~]+")
  53 (defconst eword-encoded-word-regexp
  54   (concat (regexp-quote "=?")
  55           "\\("
  56           mime-charset-regexp
  57           "\\)"
  58           (regexp-quote "?")
  59           "\\(B\\|Q\\)"
  60           (regexp-quote "?")
  61           "\\("
  62           eword-encoded-text-regexp
  63           "\\)"
  64           (regexp-quote "?=")))
  65
  66
  67 ;;; @ for string
  68 ;;;
  69
  70 (defun eword-decode-string (string &optional must-unfold)
  71   "Decode MIME encoded-words in STRING.
  72
  73 STRING is unfolded before decoding.
  74
  75 If an encoded-word is broken or your emacs implementation can not
  76 decode the charset included in it, it is not decoded.
  77
  78 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
  79 if there are in decoded encoded-words (generated by bad manner MUA
  80 such as a version of Net$cape)."
  81   (setq string (std11-unfold-string string))
  82   (let ((dest "")(ew nil)
  83         beg end)
  84     (while (and (string-match eword-encoded-word-regexp string)
  85                 (setq beg (match-beginning 0)
  86                       end (match-end 0))
  87                 )
  88       (if (> beg 0)
  89           (if (not
  90                (and (eq ew t)
  91                     (string-match "^[ \t]+$" (substring string 0 beg))
  92                     ))
  93               (setq dest (concat dest (substring string 0 beg)))
  94             )
  95         )
  96       (setq dest
  97             (concat dest
  98                     (eword-decode-encoded-word
  99                      (substring string beg end) must-unfold)
 100                     ))
 101       (setq string (substring string end))
 102       (setq ew t)
 103       )
 104     (concat dest string)
 105     ))
 106
 107
 108 ;;; @ for region
 109 ;;;
 110
 111 (defun eword-decode-region (start end &optional unfolding must-unfold)
 112   "Decode MIME encoded-words in region between START and END.
 113
 114 If UNFOLDING is not nil, it unfolds before decoding.
 115
 116 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 117 if there are in decoded encoded-words (generated by bad manner MUA
 118 such as a version of Net$cape)."
 119   (interactive "*r")
 120   (save-excursion
 121     (save-restriction
 122       (narrow-to-region start end)
 123       (if unfolding
 124           (eword-decode-unfold)
 125         )
 126       (goto-char (point-min))
 127       (while (re-search-forward (concat "\\(" eword-encoded-word-regexp "\\)"
 128                                         "\\(\n?[ \t]\\)+"
 129                                         "\\(" eword-encoded-word-regexp "\\)")
 130                                 nil t)
 131         (replace-match "\\1\\6")
 132         (goto-char (point-min))
 133         )
 134       (while (re-search-forward eword-encoded-word-regexp nil t)
 135         (insert (eword-decode-encoded-word
 136                  (prog1
 137                      (buffer-substring (match-beginning 0) (match-end 0))
 138                    (delete-region (match-beginning 0) (match-end 0))
 139                    ) must-unfold))
 140         )
 141       )))
 142
 143
 144 ;;; @ for message header
 145 ;;;
 146
 147 (defcustom eword-decode-ignored-field-list
 148   '(Newsgroups Path Lines Nntp-Posting-Host Received Message-Id Date)
 149   "*List of field-names to be ignored when decoding.
 150 Each field name must be symbol."
 151   :group 'eword-decode
 152   :type '(repeat symbol))
 153
 154 (defcustom eword-decode-structured-field-list
 155   '(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
 156              To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
 157              Mail-Followup-To
 158              Mime-Version Content-Type Content-Transfer-Encoding
 159              Content-Disposition User-Agent)
 160   "*List of field-names to decode as structured field.
 161 Each field name must be symbol."
 162   :group 'eword-decode
 163   :type '(repeat symbol))
 164
 165 (defun eword-decode-header (&optional code-conversion separator)
 166   "Decode MIME encoded-words in header fields.
 167 If CODE-CONVERSION is nil, it decodes only encoded-words.  If it is
 168 mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
 169 Otherwise it decodes non-ASCII bit patterns as the
 170 default-mime-charset.
 171 If SEPARATOR is not nil, it is used as header separator."
 172   (interactive "*")
 173   (save-excursion
 174     (save-restriction
 175       (std11-narrow-to-header separator)
 176       (let ((default-charset
 177               (if code-conversion
 178                   (if (mime-charset-to-coding-system code-conversion)
 179                       code-conversion
 180                     default-mime-charset))))
 181         (if default-charset
 182             (let (beg p end field-name len)
 183               (goto-char (point-min))
 184               (while (re-search-forward std11-field-head-regexp nil t)
 185                 (setq beg (match-beginning 0)
 186                       p (match-end 0)
 187                       field-name (buffer-substring beg (1- p))
 188                       len (string-width field-name)
 189                       field-name (intern (capitalize field-name))
 190                       end (std11-field-end))
 191                 (cond ((memq field-name eword-decode-ignored-field-list)
 192                        ;; Don't decode
 193                        )
 194                       ((memq field-name eword-decode-structured-field-list)
 195                        ;; Decode as structured field
 196                        (let ((body (buffer-substring p end))
 197                              (default-mime-charset default-charset))
 198                          (delete-region p end)
 199                          (insert (eword-decode-and-fold-structured-field
 200                                   body (1+ len)))
 201                          ))
 202                       (t
 203                        ;; Decode as unstructured field
 204                        (save-restriction
 205                          (narrow-to-region beg (1+ end))
 206                          (decode-mime-charset-region p end default-charset)
 207                          (goto-char p)
 208                          (if (re-search-forward eword-encoded-word-regexp
 209                                                 nil t)
 210                              (eword-decode-region beg (point-max) 'unfold))
 211                          )))))
 212           (eword-decode-region (point-min) (point-max) t)
 213           )))))
 214
 215 (defun eword-decode-unfold ()
 216   (goto-char (point-min))
 217   (let (field beg end)
 218     (while (re-search-forward std11-field-head-regexp nil t)
 219       (setq beg (match-beginning 0)
 220             end (std11-field-end))
 221       (setq field (buffer-substring beg end))
 222       (if (string-match eword-encoded-word-regexp field)
 223           (save-restriction
 224             (narrow-to-region (goto-char beg) end)
 225             (while (re-search-forward "\n\\([ \t]\\)" nil t)
 226               (replace-match (match-string 1))
 227               )
 228             (goto-char (point-max))
 229             ))
 230       )))
 231
 232
 233 ;;; @ encoded-word decoder
 234 ;;;
 235
 236 (defvar eword-decode-encoded-word-error-handler
 237   'eword-decode-encoded-word-default-error-handler)
 238
 239 (defvar eword-warning-face nil
 240   "Face used for invalid encoded-word.")
 241
 242 (defun eword-decode-encoded-word-default-error-handler (word signal)
 243   (and (add-text-properties 0 (length word)
 244                             (and eword-warning-face
 245                                  (list 'face eword-warning-face))
 246                             word)
 247        word))
 248
 249 (defun eword-decode-encoded-word (word &optional must-unfold)
 250   "Decode WORD if it is an encoded-word.
 251
 252 If your emacs implementation can not decode the charset of WORD, it
 253 returns WORD.  Similarly the encoded-word is broken, it returns WORD.
 254
 255 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 256 if there are in decoded encoded-word (generated by bad manner MUA such
 257 as a version of Net$cape)."
 258   (or (if (string-match eword-encoded-word-regexp word)
 259           (let ((charset
 260                  (substring word (match-beginning 1) (match-end 1))
 261                  )
 262                 (encoding
 263                  (upcase
 264                   (substring word (match-beginning 2) (match-end 2))
 265                   ))
 266                 (text
 267                  (substring word (match-beginning 3) (match-end 3))
 268                  ))
 269             (condition-case err
 270                 (eword-decode-encoded-text charset encoding text must-unfold)
 271               (error
 272                (funcall eword-decode-encoded-word-error-handler word err)
 273                ))
 274             ))
 275       word))
 276
 277
 278 ;;; @ encoded-text decoder
 279 ;;;
 280
 281 (defun eword-decode-encoded-text (charset encoding string
 282                                           &optional must-unfold)
 283   "Decode STRING as an encoded-text.
 284
 285 If your emacs implementation can not decode CHARSET, it returns nil.
 286
 287 If ENCODING is not \"B\" or \"Q\", it occurs error.
 288 So you should write error-handling code if you don't want break by errors.
 289
 290 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 291 if there are in decoded encoded-text (generated by bad manner MUA such
 292 as a version of Net$cape)."
 293   (let ((cs (mime-charset-to-coding-system charset)))
 294     (if cs
 295         (let ((dest (encoded-text-decode-string string encoding)))
 296           (when dest
 297             (setq dest (decode-mime-charset-string dest charset))
 298             (if must-unfold
 299                 (mapconcat (function
 300                             (lambda (chr)
 301                               (cond ((eq chr ?\n) "")
 302                                     ((eq chr ?\t) " ")
 303                                     (t (char-to-string chr)))
 304                               ))
 305                            (std11-unfold-string dest)
 306                            "")
 307               dest))))))
 308
 309
 310 ;;; @ lexical analyze
 311 ;;;
 312
 313 (defvar eword-lexical-analyze-cache nil)
 314 (defvar eword-lexical-analyze-cache-max 299
 315   "*Max position of eword-lexical-analyze-cache.
 316 It is max size of eword-lexical-analyze-cache - 1.")
 317
 318 (defcustom eword-lexical-analyzers
 319   '(eword-analyze-quoted-string
 320     eword-analyze-domain-literal
 321     eword-analyze-comment
 322     eword-analyze-spaces
 323     eword-analyze-special
 324     eword-analyze-encoded-word
 325     eword-analyze-atom)
 326   "*List of functions to return result of lexical analyze.
 327 Each function must have two arguments: STRING and MUST-UNFOLD.
 328 STRING is the target string to be analyzed.
 329 If MUST-UNFOLD is not nil, each function must unfold and eliminate
 330 bare-CR and bare-LF from the result even if they are included in
 331 content of the encoded-word.
 332 Each function must return nil if it can not analyze STRING as its
 333 format.
 334
 335 Previous function is preferred to next function.  If a function
 336 returns nil, next function is used.  Otherwise the return value will
 337 be the result."
 338   :group 'eword-decode
 339   :type '(repeat function))
 340
 341 (defun eword-analyze-quoted-string (string &optional must-unfold)
 342   (let ((p (std11-check-enclosure string ?\" ?\")))
 343     (if p
 344         (cons (cons 'quoted-string
 345                     (decode-mime-charset-string
 346                      (std11-strip-quoted-pair (substring string 1 (1- p)))
 347                      default-mime-charset))
 348               (substring string p))
 349       )))
 350
 351 (defun eword-analyze-domain-literal (string &optional must-unfold)
 352   (std11-analyze-domain-literal string))
 353
 354 (defun eword-analyze-comment (string &optional must-unfold)
 355   (let ((p (std11-check-enclosure string ?\( ?\) t)))
 356     (if p
 357         (cons (cons 'comment
 358                     (eword-decode-string
 359                      (decode-mime-charset-string
 360                       (std11-strip-quoted-pair (substring string 1 (1- p)))
 361                       default-mime-charset)
 362                      must-unfold))
 363               (substring string p))
 364       )))
 365
 366 (defun eword-analyze-spaces (string &optional must-unfold)
 367   (std11-analyze-spaces string))
 368
 369 (defun eword-analyze-special (string &optional must-unfold)
 370   (std11-analyze-special string))
 371
 372 (defun eword-analyze-encoded-word (string &optional must-unfold)
 373   (if (eq (string-match eword-encoded-word-regexp string) 0)
 374       (let ((end (match-end 0))
 375             (dest (eword-decode-encoded-word (match-string 0 string)
 376                                              must-unfold))
 377             )
 378         (setq string (substring string end))
 379         (while (eq (string-match `,(concat "[ \t\n]*\\("
 380                                            eword-encoded-word-regexp
 381                                            "\\)")
 382                                  string)
 383                    0)
 384           (setq end (match-end 0))
 385           (setq dest
 386                 (concat dest
 387                         (eword-decode-encoded-word (match-string 1 string)
 388                                                    must-unfold))
 389                 string (substring string end))
 390           )
 391         (cons (cons 'atom dest) string)
 392         )))
 393
 394 (defun eword-analyze-atom (string &optional must-unfold)
 395   (if (string-match std11-atom-regexp string)
 396       (let ((end (match-end 0)))
 397         (cons (cons 'atom (decode-mime-charset-string
 398                            (substring string 0 end)
 399                            default-mime-charset))
 400               (substring string end)
 401               ))))
 402
 403 (defun eword-lexical-analyze-internal (string must-unfold)
 404   (let (dest ret)
 405     (while (not (string-equal string ""))
 406       (setq ret
 407             (let ((rest eword-lexical-analyzers)
 408                   func r)
 409               (while (and (setq func (car rest))
 410                           (null (setq r (funcall func string must-unfold)))
 411                           )
 412                 (setq rest (cdr rest)))
 413               (or r `((error . ,string) . ""))
 414               ))
 415       (setq dest (cons (car ret) dest))
 416       (setq string (cdr ret))
 417       )
 418     (nreverse dest)
 419     ))
 420
 421 (defun eword-lexical-analyze (string &optional must-unfold)
 422   "Return lexical analyzed list corresponding STRING.
 423 It is like std11-lexical-analyze, but it decodes non us-ascii
 424 characters encoded as encoded-words or invalid \"raw\" format.
 425 \"Raw\" non us-ascii characters are regarded as variable
 426 `default-mime-charset'."
 427   (let ((key (copy-sequence string))
 428         ret)
 429     (set-text-properties 0 (length key) nil key)
 430     (if (setq ret (assoc key eword-lexical-analyze-cache))
 431         (cdr ret)
 432       (setq ret (eword-lexical-analyze-internal key must-unfold))
 433       (setq eword-lexical-analyze-cache
 434             (cons (cons key ret)
 435                   (last eword-lexical-analyze-cache
 436                         eword-lexical-analyze-cache-max)))
 437       ret)))
 438
 439 (defun eword-decode-token (token)
 440   (let ((type (car token))
 441         (value (cdr token)))
 442     (cond ((eq type 'quoted-string)
 443            (std11-wrap-as-quoted-string value))
 444           ((eq type 'comment)
 445            (concat "(" (std11-wrap-as-quoted-pairs value '(?( ?))) ")"))
 446           (t value))))
 447
 448 (defun eword-decode-and-fold-structured-field
 449   (string start-column &optional max-column must-unfold)
 450   "Decode and fold (fill) STRING as structured field body.
 451 It decodes non us-ascii characters in FULL-NAME encoded as
 452 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 453 characters are regarded as variable `default-mime-charset'.
 454
 455 If an encoded-word is broken or your emacs implementation can not
 456 decode the charset included in it, it is not decoded.
 457
 458 If MAX-COLUMN is omitted, `fill-column' is used.
 459
 460 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 461 if there are in decoded encoded-words (generated by bad manner MUA
 462 such as a version of Net$cape)."
 463   (if (and eword-max-size-to-decode
 464            (> (length string) eword-max-size-to-decode))
 465       string
 466     (or max-column
 467         (setq max-column fill-column))
 468     (let ((c start-column)
 469           (tokens (eword-lexical-analyze string must-unfold))
 470           (result "")
 471           token)
 472       (while (and (setq token (car tokens))
 473                   (setq tokens (cdr tokens)))
 474         (let* ((type (car token)))
 475           (if (eq type 'spaces)
 476               (let* ((next-token (car tokens))
 477                      (next-str (eword-decode-token next-token))
 478                      (next-len (string-width next-str))
 479                      (next-c (+ c next-len 1)))
 480                 (if (< next-c max-column)
 481                     (setq result (concat result " " next-str)
 482                           c next-c)
 483                   (setq result (concat result "\n " next-str)
 484                         c (1+ next-len)))
 485                 (setq tokens (cdr tokens))
 486                 )
 487             (let* ((str (eword-decode-token token)))
 488               (setq result (concat result str)
 489                     c (+ c (string-width str)))
 490               ))))
 491       (if token
 492           (concat result (eword-decode-token token))
 493         result))))
 494
 495 (defun eword-decode-and-unfold-structured-field (string)
 496   "Decode and unfold STRING as structured field body.
 497 It decodes non us-ascii characters in FULL-NAME encoded as
 498 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 499 characters are regarded as variable `default-mime-charset'.
 500
 501 If an encoded-word is broken or your emacs implementation can not
 502 decode the charset included in it, it is not decoded."
 503   (let ((tokens (eword-lexical-analyze string 'must-unfold))
 504         (result ""))
 505     (while tokens
 506       (let* ((token (car tokens))
 507              (type (car token)))
 508         (setq tokens (cdr tokens))
 509         (setq result
 510               (if (eq type 'spaces)
 511                   (concat result " ")
 512                 (concat result (eword-decode-token token))
 513                 ))))
 514     result))
 515
 516 (defun eword-decode-structured-field-body (string &optional must-unfold
 517                                                   start-column max-column)
 518   "Decode non us-ascii characters in STRING as structured field body.
 519 STRING is unfolded before decoding.
 520
 521 It decodes non us-ascii characters in FULL-NAME encoded as
 522 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 523 characters are regarded as variable `default-mime-charset'.
 524
 525 If an encoded-word is broken or your emacs implementation can not
 526 decode the charset included in it, it is not decoded.
 527
 528 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 529 if there are in decoded encoded-words (generated by bad manner MUA
 530 such as a version of Net$cape)."
 531   (if start-column
 532       ;; fold with max-column
 533       (eword-decode-and-fold-structured-field
 534        string start-column max-column must-unfold)
 535     ;; Don't fold
 536     (mapconcat (function eword-decode-token)
 537                (eword-lexical-analyze string must-unfold)
 538                "")
 539     ))
 540
 541 (defun eword-decode-unstructured-field-body (string &optional must-unfold)
 542   "Decode non us-ascii characters in STRING as unstructured field body.
 543 STRING is unfolded before decoding.
 544
 545 It decodes non us-ascii characters in FULL-NAME encoded as
 546 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 547 characters are regarded as variable `default-mime-charset'.
 548
 549 If an encoded-word is broken or your emacs implementation can not
 550 decode the charset included in it, it is not decoded.
 551
 552 If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
 553 if there are in decoded encoded-words (generated by bad manner MUA
 554 such as a version of Net$cape)."
 555   (eword-decode-string
 556    (decode-mime-charset-string string default-mime-charset)
 557    must-unfold))
 558
 559 (defun eword-extract-address-components (string)
 560   "Extract full name and canonical address from STRING.
 561 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 562 If no name can be extracted, FULL-NAME will be nil.
 563 It decodes non us-ascii characters in FULL-NAME encoded as
 564 encoded-words or invalid \"raw\" string.  \"Raw\" non us-ascii
 565 characters are regarded as variable `default-mime-charset'."
 566   (let* ((structure (car (std11-parse-address
 567                           (eword-lexical-analyze
 568                            (std11-unfold-string string) 'must-unfold))))
 569          (phrase  (std11-full-name-string structure))
 570          (address (std11-address-string structure))
 571          )
 572     (list phrase address)
 573     ))
 574
 575
 576 ;;; @ end
 577 ;;;
 578
 579 (provide 'eword-decode)
 580
 581 ;;; eword-decode.el ends here