cgit.sxemacs.org Git - gnus/blob - lisp/mm-bodies.el

   1 ;;; mm-bodies.el --- Functions for decoding MIME things
   2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-and-compile
  28   (or (fboundp  'base64-decode-region)
  29       (require 'base64))
  30   (autoload 'binhex-decode-region "binhex"))
  31
  32 (require 'mm-util)
  33 (require 'rfc2047)
  34 (require 'qp)
  35 (require 'uudecode)
  36
  37 ;; 8bit treatment gets any char except: 0x32 - 0x7f, CR, LF, TAB, BEL,
  38 ;; BS, vertical TAB, form feed, and ^_
  39 (defvar mm-7bit-chars "\x20-\x7f\r\n\t\x7\x8\xb\xc\x1f")
  40
  41 (defcustom mm-body-charset-encoding-alist
  42   '((iso-2022-jp . 7bit)
  43     (iso-2022-jp-2 . 7bit))
  44   "Alist of MIME charsets to encodings.
  45 Valid encodings are `7bit', `8bit', `quoted-printable' and `base64'."
  46   :type '(repeat (cons (symbol :tag "charset")
  47                        (choice :tag "encoding"
  48                                (const 7bit)
  49                                (const 8bit)
  50                                (const quoted-printable)
  51                                (const base64))))
  52   :group 'mime)
  53
  54 (defun mm-encode-body ()
  55   "Encode a body.
  56 Should be called narrowed to the body that is to be encoded.
  57 If there is more than one non-ASCII MULE charset, then list of found
  58 MULE charsets are returned.
  59 If successful, the MIME charset is returned.
  60 If no encoding was done, nil is returned."
  61   (if (not (mm-multibyte-p))
  62       ;; In the non-Mule case, we search for non-ASCII chars and
  63       ;; return the value of `mail-parse-charset' if any are found.
  64       (save-excursion
  65         (goto-char (point-min))
  66         (if (re-search-forward "[^\x0-\x7f]" nil t)
  67             (or mail-parse-charset
  68                 (message-options-get 'mm-encody-body-charset)
  69                 (message-options-set
  70                  'mm-encody-body-charset
  71                  (mm-read-charset "Charset used in the article: ")))
  72           ;; The logic in `mml-generate-mime-1' confirms that it's OK
  73           ;; to return nil here.
  74           nil))
  75     (save-excursion
  76       (goto-char (point-min))
  77       (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)))
  78             charset)
  79         (cond
  80          ;; No encoding.
  81          ((null charsets)
  82           nil)
  83          ;; Too many charsets.
  84          ((> (length charsets) 1)
  85           charsets)
  86          ;; We encode.
  87          (t
  88           (let ((charset (car charsets))
  89                 start)
  90             (when (or t
  91                       ;; We always decode.
  92                       (not (mm-coding-system-equal
  93                             charset buffer-file-coding-system)))
  94               (while (not (eobp))
  95                 (if (eq (mm-charset-after) 'ascii)
  96                     (when start
  97                       (save-restriction
  98                         (narrow-to-region start (point))
  99                         (mm-encode-coding-region start (point) charset)
 100                         (goto-char (point-max)))
 101                       (setq start nil))
 102                   (unless start
 103                     (setq start (point))))
 104                 (forward-char 1))
 105               (when start
 106                 (mm-encode-coding-region start (point) charset)
 107                 (setq start nil)))
 108             charset)))))))
 109
 110 (defun mm-body-encoding (charset &optional encoding)
 111   "Do Content-Transfer-Encoding and return the encoding of the current buffer."
 112   (let ((bits (mm-body-7-or-8)))
 113     (cond
 114      ((and (not mm-use-ultra-safe-encoding) (eq bits '7bit))
 115       bits)
 116      ((and (not mm-use-ultra-safe-encoding)
 117            (or (eq t (cdr message-posting-charset))
 118                (memq charset (cdr message-posting-charset))
 119                (eq charset mail-parse-charset)))
 120       bits)
 121      (t
 122       (let ((encoding (or encoding
 123                           (cdr (assq charset mm-body-charset-encoding-alist))
 124                           (mm-qp-or-base64))))
 125         (when mm-use-ultra-safe-encoding
 126           (setq encoding (mm-safer-encoding encoding)))
 127         (mm-encode-content-transfer-encoding encoding "text/plain")
 128         encoding)))))
 129
 130 (defun mm-body-7-or-8 ()
 131   "Say whether the body is 7bit or 8bit."
 132   (cond
 133    ((not (featurep 'mule))
 134     (if (save-excursion
 135           (goto-char (point-min))
 136           (skip-chars-forward mm-7bit-chars)
 137           (eobp))
 138         '7bit
 139       '8bit))
 140    (t
 141     ;; Mule version
 142     (if (and (null (delq 'ascii
 143                          (mm-find-charset-region (point-min) (point-max))))
 144              ;;!!!The following is necessary because the function
 145              ;;!!!above seems to return the wrong result under
 146              ;;!!!Emacs 20.3.  Sometimes.
 147              (save-excursion
 148                (goto-char (point-min))
 149                (skip-chars-forward mm-7bit-chars)
 150                (eobp)))
 151         '7bit
 152       '8bit))))
 153
 154 ;;;
 155 ;;; Functions for decoding
 156 ;;;
 157
 158 (defun mm-decode-content-transfer-encoding (encoding &optional type)
 159   (prog1
 160       (condition-case error
 161           (cond
 162            ((eq encoding 'quoted-printable)
 163             (quoted-printable-decode-region (point-min) (point-max)))
 164            ((eq encoding 'base64)
 165             (base64-decode-region
 166              (point-min)
 167              ;; Some mailers insert whitespace
 168              ;; junk at the end which
 169              ;; base64-decode-region dislikes.
 170              ;; Also remove possible junk which could
 171              ;; have been added by mailing list software.
 172              (save-excursion
 173                (goto-char (point-min))
 174                (while (re-search-forward "^[\t ]*\r?\n" nil t)
 175                  (delete-region (match-beginning 0) (match-end 0)))
 176                (goto-char (point-max))
 177                (when (re-search-backward "^[A-Za-z0-9+/]+=*[\t ]*$" nil t)
 178                  (forward-line)
 179                  (delete-region (point) (point-max)))
 180                (point-max))))
 181            ((memq encoding '(7bit 8bit binary))
 182             ;; Do nothing.
 183             )
 184            ((null encoding)
 185             ;; Do nothing.
 186             )
 187            ((memq encoding '(x-uuencode x-uue))
 188             (funcall mm-uu-decode-function (point-min) (point-max)))
 189            ((eq encoding 'x-binhex)
 190             (funcall mm-uu-binhex-decode-function (point-min) (point-max)))
 191            ((functionp encoding)
 192             (funcall encoding (point-min) (point-max)))
 193            (t
 194             (message "Unknown encoding %s; defaulting to 8bit" encoding)))
 195         (error
 196          (message "Error while decoding: %s" error)
 197          nil))
 198     (when (and
 199            (memq encoding '(base64 x-uuencode x-uue x-binhex))
 200            (equal type "text/plain"))
 201       (goto-char (point-min))
 202       (while (search-forward "\r\n" nil t)
 203         (replace-match "\n" t t)))))
 204
 205 (defun mm-decode-body (charset &optional encoding type)
 206   "Decode the current article that has been encoded with ENCODING.
 207 The characters in CHARSET should then be decoded."
 208   (if (stringp charset)
 209       (setq charset (intern (downcase charset))))
 210   (if (or (not charset)
 211           (eq 'gnus-all mail-parse-ignored-charsets)
 212           (memq 'gnus-all mail-parse-ignored-charsets)
 213           (memq charset mail-parse-ignored-charsets))
 214       (setq charset mail-parse-charset))
 215   (save-excursion
 216     (when encoding
 217       (mm-decode-content-transfer-encoding encoding type))
 218     (when (featurep 'mule)
 219       (let ((mule-charset (mm-charset-to-coding-system charset)))
 220         (if (and (not mule-charset)
 221                  (listp mail-parse-ignored-charsets)
 222                  (memq 'gnus-unknown mail-parse-ignored-charsets))
 223             (setq mule-charset
 224                   (mm-charset-to-coding-system mail-parse-charset)))
 225         (when (and charset mule-charset
 226                    ;; buffer-file-coding-system
 227                    ;;Article buffer is nil coding system
 228                    ;;in XEmacs
 229                    (mm-multibyte-p)
 230                    (or (not (eq mule-charset 'ascii))
 231                        (setq mule-charset mail-parse-charset))
 232                    (not (eq mule-charset 'gnus-decoded)))
 233           (mm-decode-coding-region (point-min) (point-max) mule-charset))))))
 234
 235 (defun mm-decode-string (string charset)
 236   "Decode STRING with CHARSET."
 237   (when (stringp charset)
 238     (setq charset (intern (downcase charset))))
 239   (when (or (not charset)
 240             (eq 'gnus-all mail-parse-ignored-charsets)
 241             (memq 'gnus-all mail-parse-ignored-charsets)
 242             (memq charset mail-parse-ignored-charsets))
 243     (setq charset mail-parse-charset))
 244   (or
 245    (when (featurep 'mule)
 246      (let ((mule-charset (mm-charset-to-coding-system charset)))
 247        (if (and (not mule-charset)
 248                 (listp mail-parse-ignored-charsets)
 249                 (memq 'gnus-unknown mail-parse-ignored-charsets))
 250            (setq mule-charset
 251                  (mm-charset-to-coding-system mail-parse-charset)))
 252        (when (and charset mule-charset
 253                   (mm-multibyte-p)
 254                   (or (not (eq mule-charset 'ascii))
 255                       (setq mule-charset mail-parse-charset)))
 256          (mm-decode-coding-string string mule-charset))))
 257    string))
 258
 259 (provide 'mm-bodies)
 260
 261 ;; mm-bodies.el ends here