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

   1 ;;; mm-encode.el --- Functions for encoding MIME things
   2 ;; Copyright (C) 1998 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 (require 'mail-parse)
  28
  29 (defvar mm-mime-file-types
  30   '(("\\.rtf$" "text/richtext")
  31     ("\\.\\(html\\|htm\\)$" "text/html")
  32     ("\\.ps$" "application/postscript"
  33      (encoding quoted-printable)
  34      (disposition "attachment"))
  35     ("\\.\\(jpeg\\|jpg\\)$" "image/jpeg")
  36     ("\\.gif$" "image/gif")
  37     ("\\.png$" "image/png")
  38     ("\\.\\(tiff\\|tif\\)$" "image/tiff")
  39     ("\\.pic$" "image/x-pic")
  40     ("\\.mag$" "image/x-mag")
  41     ("\\.xbm$" "image/x-xbm")
  42     ("\\.xwd$" "image/x-xwd")
  43     ("\\.au$" "audio/basic")
  44     ("\\.mpg$" "video/mpeg")
  45     ("\\.txt$" "text/plain")
  46     ("\\.el$" "application/octet-stream"
  47      ("type" ."emacs-lisp"))
  48     ("\\.lsp$" "application/octet-stream"
  49      ("type" "common-lisp"))
  50     ("\\.tar\\.gz$" "application/octet-stream"
  51      ("type" "tar+gzip"))
  52     ("\\.tgz$" "application/octet-stream"
  53      ("type" "tar+gzip"))
  54     ("\\.tar\\.Z$" "application/octet-stream"
  55      ("type" "tar+compress"))
  56     ("\\.taz$" "application/octet-stream"
  57      ("type" "tar+compress"))
  58     ("\\.gz$" "application/octet-stream"
  59      ("type" "gzip"))
  60     ("\\.Z$" "application/octet-stream"
  61      ("type" "compress"))
  62     ("\\.lzh$" "application/octet-stream"
  63      ("type" . "lha"))
  64     ("\\.zip$" "application/zip")
  65     ("\\.diffs?$" "text/plain"
  66      ("type" . "patch"))
  67     ("\\.patch$" "application/octet-stream"
  68      ("type" "patch"))
  69     ("\\.signature" "text/plain")
  70     (".*" "application/octet-stream"))
  71   "*Alist of regexps and MIME types.")
  72
  73 (defvar mm-content-transfer-encoding-defaults
  74   '(("text/.*" quoted-printable)
  75     (".*" base64))
  76   "Alist of regexps that match MIME types and their encodings.")
  77
  78 (defun mm-insert-rfc822-headers (charset encoding)
  79   "Insert text/plain headers with CHARSET and ENCODING."
  80   (insert "MIME-Version: 1.0\n")
  81   (insert "Content-Type: text/plain; charset="
  82           (mail-quote-string (downcase (symbol-name charset))) "\n")
  83   (insert "Content-Transfer-Encoding: "
  84           (downcase (symbol-name encoding)) "\n"))
  85
  86 (defun mm-insert-multipart-headers ()
  87   "Insert multipart/mixed headers."
  88   (let ((boundary "=-=-="))
  89     (insert "MIME-Version: 1.0\n")
  90     (insert (format "Content-Type: multipart/mixed; boundary=\"%s\"\n"
  91                     boundary))
  92     boundary))
  93
  94 (defun mm-default-file-encoding (file)
  95   "Return a default encoding for FILE."
  96   (let ((types mm-mime-file-types)
  97         type)
  98     (catch 'found
  99       (while (setq type (pop types))
 100         (when (string-match (car type) file)
 101           (throw 'found (cdr type)))
 102         (pop types)))))
 103
 104 (defun mm-encode-content-transfer-encoding (encoding &optional type)
 105   (cond
 106    ((eq encoding 'quoted-printable)
 107     (quoted-printable-encode-region (point-min) (point-max)))
 108    ((eq encoding 'base64)
 109     (when (equal type "text/plain")
 110       (goto-char (point-min))
 111       (while (search-forward "\n" nil t)
 112         (replace-match "\r\n" t t)))
 113     (condition-case ()
 114         (base64-encode-region (point-min) (point-max))
 115       (error nil)))
 116    ((memq encoding '(7bit 8bit binary))
 117     )
 118    ((null encoding)
 119     )
 120    ((eq encoding 'x-uuencode)
 121     (condition-case ()
 122         (uudecode-encode-region (point-min) (point-max))
 123       (error nil)))
 124    ((functionp encoding)
 125     (condition-case ()
 126         (funcall encoding (point-min) (point-max))
 127       (error nil)))
 128    (t
 129     (message "Unknown encoding %s; defaulting to 8bit" encoding))))
 130
 131 (defun mm-encode-buffer (type)
 132   "Encode the buffer which contains data of TYPE.
 133 The encoding used is returned."
 134   (let* ((mime-type (if (stringp type) type (car type)))
 135          (encoding
 136           (or (and (listp type)
 137                    (cadr (assq 'encoding type)))
 138               (mm-content-transfer-encoding mime-type))))
 139     (mm-encode-content-transfer-encoding encoding mime-type)
 140     encoding))
 141
 142 (defun mm-insert-headers (type encoding &optional file)
 143   "Insert headers for TYPE."
 144   (insert "Content-Type: " (car type))
 145   (when file
 146     (insert ";\n\tname=\"" (file-name-nondirectory file) "\""))
 147   (insert "\n")
 148   (insert (format "Content-Transfer-Encoding: %s\n" encoding))
 149   (insert "Content-Disposition: inline")
 150   (when file
 151     (insert ";\n\tfilename=\"" (file-name-nondirectory file) "\""))
 152   (insert "\n")
 153   (insert "\n"))
 154
 155 (defun mm-content-transfer-encoding (type)
 156   "Return a CTE suitable for TYPE."
 157   (let ((rules mm-content-transfer-encoding-defaults))
 158     (catch 'found
 159       (while rules
 160         (when (string-match (caar rules) type)
 161           (throw 'found (cadar rules)))
 162         (pop rules)))))
 163
 164 (provide 'mm-encode)
 165
 166 ;;; mm-encode.el ends here