| 1 | ;;; mm-encode.el --- Functions for encoding 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-when-compile (require 'cl)) |
| 28 | (require 'mail-parse) |
| 29 | (require 'mailcap) |
| 30 | (eval-and-compile |
| 31 | (autoload 'mm-body-7-or-8 "mm-bodies")) |
| 32 | |
| 33 | (defvar mm-content-transfer-encoding-defaults |
| 34 | '(("text/x-patch" 8bit) |
| 35 | ("text/.*" qp-or-base64) |
| 36 | ("message/rfc822" 8bit) |
| 37 | ("application/emacs-lisp" 8bit) |
| 38 | ("application/x-patch" 8bit) |
| 39 | (".*" qp-or-base64)) |
| 40 | "Alist of regexps that match MIME types and their encodings. |
| 41 | If the encoding is `qp-or-base64', then either quoted-printable |
| 42 | or base64 will be used, depending on what is more efficient.") |
| 43 | |
| 44 | (defvar mm-use-ultra-safe-encoding nil |
| 45 | "If non-nil, use encodings aimed at Procrustean bed survival. |
| 46 | |
| 47 | This means that textual parts are encoded as quoted-printable if they |
| 48 | contain lines longer than 76 characters or starting with \"From \" in |
| 49 | the body. Non-7bit encodings (8bit, binary) are generally disallowed. |
| 50 | This is to reduce the probability that a broken MTA or MDA changes the |
| 51 | message. |
| 52 | |
| 53 | This variable should never be set directly, but bound before a call to |
| 54 | `mml-generate-mime' or similar functions.") |
| 55 | |
| 56 | (defun mm-insert-rfc822-headers (charset encoding) |
| 57 | "Insert text/plain headers with CHARSET and ENCODING." |
| 58 | (insert "MIME-Version: 1.0\n") |
| 59 | (insert "Content-Type: text/plain; charset=" |
| 60 | (mail-quote-string (downcase (symbol-name charset))) "\n") |
| 61 | (insert "Content-Transfer-Encoding: " |
| 62 | (downcase (symbol-name encoding)) "\n")) |
| 63 | |
| 64 | (defun mm-insert-multipart-headers () |
| 65 | "Insert multipart/mixed headers." |
| 66 | (let ((boundary "=-=-=")) |
| 67 | (insert "MIME-Version: 1.0\n") |
| 68 | (insert "Content-Type: multipart/mixed; boundary=\"" boundary "\"\n") |
| 69 | boundary)) |
| 70 | |
| 71 | (defun mm-default-file-encoding (file) |
| 72 | "Return a default encoding for FILE." |
| 73 | (if (not (string-match "\\.[^.]+$" file)) |
| 74 | "application/octet-stream" |
| 75 | (mailcap-extension-to-mime (match-string 0 file)))) |
| 76 | |
| 77 | (defun mm-safer-encoding (encoding) |
| 78 | "Return a safer but similar encoding." |
| 79 | (cond |
| 80 | ((memq encoding '(7bit 8bit quoted-printable)) 'quoted-printable) |
| 81 | ;; The remaing encodings are binary and base64 (and perhaps some |
| 82 | ;; non-standard ones), which are both turned into base64. |
| 83 | (t 'base64))) |
| 84 | |
| 85 | (defun mm-encode-content-transfer-encoding (encoding &optional type) |
| 86 | (cond |
| 87 | ((eq encoding 'quoted-printable) |
| 88 | (quoted-printable-encode-region (point-min) (point-max) t)) |
| 89 | ((eq encoding 'base64) |
| 90 | (when (equal type "text/plain") |
| 91 | (goto-char (point-min)) |
| 92 | (while (search-forward "\n" nil t) |
| 93 | (replace-match "\r\n" t t))) |
| 94 | (condition-case error |
| 95 | (base64-encode-region (point-min) (point-max)) |
| 96 | (error |
| 97 | (message "Error while decoding: %s" error) |
| 98 | nil))) |
| 99 | ((memq encoding '(7bit 8bit binary)) |
| 100 | ;; Do nothing. |
| 101 | ) |
| 102 | ((null encoding) |
| 103 | ;; Do nothing. |
| 104 | ) |
| 105 | ((functionp encoding) |
| 106 | (ignore-errors (funcall encoding (point-min) (point-max)))) |
| 107 | (t |
| 108 | (message "Unknown encoding %s; defaulting to 8bit" encoding)))) |
| 109 | |
| 110 | (defun mm-encode-buffer (type) |
| 111 | "Encode the buffer which contains data of TYPE. |
| 112 | The encoding used is returned." |
| 113 | (let* ((mime-type (if (stringp type) type (car type))) |
| 114 | (encoding |
| 115 | (or (and (listp type) |
| 116 | (cadr (assq 'encoding type))) |
| 117 | (mm-content-transfer-encoding mime-type))) |
| 118 | (bits (mm-body-7-or-8))) |
| 119 | ;; We force buffers that are 7bit to be unencoded, no matter |
| 120 | ;; what the preferred encoding is. |
| 121 | (when (eq bits '7bit) |
| 122 | (setq encoding bits)) |
| 123 | (mm-encode-content-transfer-encoding encoding mime-type) |
| 124 | encoding)) |
| 125 | |
| 126 | (defun mm-insert-headers (type encoding &optional file) |
| 127 | "Insert headers for TYPE." |
| 128 | (insert "Content-Type: " type) |
| 129 | (when file |
| 130 | (insert ";\n\tname=\"" (file-name-nondirectory file) "\"")) |
| 131 | (insert "\n") |
| 132 | (insert (format "Content-Transfer-Encoding: %s\n" encoding)) |
| 133 | (insert "Content-Disposition: inline") |
| 134 | (when file |
| 135 | (insert ";\n\tfilename=\"" (file-name-nondirectory file) "\"")) |
| 136 | (insert "\n") |
| 137 | (insert "\n")) |
| 138 | |
| 139 | (defun mm-content-transfer-encoding (type) |
| 140 | "Return a CTE suitable for TYPE to encode the current buffer." |
| 141 | (let ((rules mm-content-transfer-encoding-defaults)) |
| 142 | (catch 'found |
| 143 | (while rules |
| 144 | (when (string-match (caar rules) type) |
| 145 | (throw 'found |
| 146 | (let ((encoding |
| 147 | (if (eq (cadr (car rules)) 'qp-or-base64) |
| 148 | (mm-qp-or-base64) |
| 149 | (cadr (car rules))))) |
| 150 | (if mm-use-ultra-safe-encoding |
| 151 | (mm-safer-encoding encoding) |
| 152 | encoding)))) |
| 153 | (pop rules))))) |
| 154 | |
| 155 | (defun mm-qp-or-base64 () |
| 156 | (save-excursion |
| 157 | (let ((limit (min (point-max) (+ 2000 (point-min)))) |
| 158 | (n8bit 0)) |
| 159 | (goto-char (point-min)) |
| 160 | (skip-chars-forward "\x20-\x7f\r\n\t" limit) |
| 161 | (while (< (point) limit) |
| 162 | (incf n8bit) |
| 163 | (forward-char 1) |
| 164 | (skip-chars-forward "\x20-\x7f\r\n\t" limit)) |
| 165 | (if (< (* 6 n8bit) (- limit (point-min))) |
| 166 | 'quoted-printable |
| 167 | 'base64)))) |
| 168 | |
| 169 | (provide 'mm-encode) |
| 170 | |
| 171 | ;;; mm-encode.el ends here |