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