1 ;;; mm-decode.el --- Functions for decoding MIME things
2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; This file is part of GNU Emacs.
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)
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.
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.
31 (defvar mm-inline-media-tests
32 '(("image/jpeg" mm-inline-image (featurep 'jpeg))
33 ("image/png" mm-inline-image (featurep 'png))
34 ("image/gif" mm-inline-image (featurep 'gif))
35 ("image/tiff" mm-inline-image (featurep 'tiff))
36 ("image/xbm" mm-inline-image (eq (device-type) 'x))
37 ("image/xpm" mm-inline-image (featurep 'xpm))
38 ("text/plain" mm-inline-text t)
39 ("text/html" mm-inline-text (featurep 'w3))
41 "Alist of media types/test that say whether the media types can be displayed inline.")
43 (defvar mm-user-display-methods
44 '(("image/.*" . inline)
45 ("text/.*" . inline)))
47 (defvar mm-user-automatic-display
48 '("text/plain" "image/gif"))
50 (defvar mm-tmp-directory "/tmp/"
51 "Where mm will store its temporary files.")
53 ;;; Internal variables.
55 (defvar mm-dissection-list nil)
57 (defun mm-dissect-buffer (&optional no-strict-mime)
58 "Dissect the current buffer and return a list of MIME handles."
60 (let (ct ctl type subtype cte)
62 (drums-narrow-to-header)
63 (when (and (or no-strict-mime
64 (mail-fetch-field "mime-version"))
65 (setq ct (mail-fetch-field "content-type")))
66 (setq ctl (drums-parse-content-type ct))
67 (setq cte (mail-fetch-field "content-transfer-encoding"))))
69 (setq type (split-string (car ctl) "/"))
70 (setq subtype (cadr type)
73 ((equal type "multipart")
74 (mm-dissect-multipart ctl))
76 (mm-dissect-singlepart ctl (and cte (intern cte))
79 (defun mm-dissect-singlepart (ctl cte &optional force)
81 (not (equal "text/plain" (car ctl))))
82 (let ((res (list (list (mm-copy-to-buffer) ctl cte nil))))
83 (push (car res) mm-dissection-list)
86 (defun mm-remove-all-parts ()
87 "Remove all MIME handles."
89 (mapcar 'mm-remove-part mm-dissection-list)
90 (setq mm-dissection-list nil))
92 (defun mm-dissect-multipart (ctl)
93 (goto-char (point-min))
94 (let ((boundary (concat "\n--" (drums-content-type-get ctl 'boundary)))
96 (while (search-forward boundary nil t)
101 (narrow-to-region start (point))
102 (setq parts (nconc (mm-dissect-buffer t) parts)))))
104 (setq start (point)))
107 (defun mm-copy-to-buffer ()
108 "Copy the contents of the current buffer to a fresh buffer."
110 (let ((obuf (current-buffer))
112 (goto-char (point-min))
113 (search-forward "\n\n" nil t)
115 (set-buffer (generate-new-buffer " *mm*"))
116 (insert-buffer-substring obuf beg)
119 (defun mm-display-part (handle)
120 "Display the MIME part represented by HANDLE."
122 (mailcap-parse-mailcaps)
124 (mm-remove-part handle)
125 (let* ((type (caadr handle))
126 (method (mailcap-mime-info type))
127 (user-method (mm-user-method type)))
128 (if (eq user-method 'inline)
131 (mm-display-inline handle))
132 (mm-display-external handle (or user-method method)))))))
134 (defun mm-display-external (handle method)
135 "Display HANDLE using METHOD."
136 (mm-with-unibyte-buffer
137 (insert-buffer-substring (car handle))
138 (mm-decode-content-transfer-encoding (nth 2 handle))
139 (if (functionp method)
140 (let ((cur (current-buffer)))
141 (switch-to-buffer (generate-new-buffer "*mm*"))
142 (insert-buffer-substring cur)
144 (setcar (nthcdr 3 handle) (current-buffer)))
145 (let* ((file (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
147 (write-region (point-min) (point-max)
148 file nil 'nomesg nil 'no-conversion)
150 (start-process "*display*" nil shell-file-name
151 "-c" (format method file)))
152 (setcar (nthcdr 3 handle) (cons file process))
153 (message "Displaying %s..." (format method file))))))
155 (defun mm-remove-part (handle)
156 "Remove the displayed MIME part represented by HANDLE."
157 (let ((object (nth 3 handle)))
159 ;; Internally displayed part.
160 ((mm-annotationp object)
161 (delete-annotation object))
162 ((or (functionp object)
164 (eq (car object) 'lambda)))
166 ;; Externally displayed part.
169 (delete-file (car object))
172 (kill-process (cdr object))
175 (when (buffer-live-p object)
176 (kill-buffer object))))
177 (setcar (nthcdr 3 handle) nil)))
179 (defun mm-display-inline (handle)
180 (let* ((type (caadr handle))
181 (function (cadr (assoc type mm-inline-media-tests))))
182 (funcall function handle)))
184 (defun mm-inlinable-p (type)
185 "Say whether TYPE can be displayed inline."
186 (let ((alist mm-inline-media-tests)
189 (when (equal type (caar alist))
190 (setq test (caddar alist)
192 (setq test (eval test)))
196 (defun mm-user-method (type)
197 "Return the user-defined method for TYPE."
198 (let ((methods mm-user-display-methods)
200 (while (setq method (pop methods))
201 (when (string-match (car method) type)
202 (when (or (not (eq (cdr method) 'inline))
203 (mm-inlinable-p type))
204 (setq result (cdr method)
208 (defun mm-automatic-display-p (type)
209 "Return the user-defined method for TYPE."
210 (let ((methods mm-user-automatic-display)
212 (while (setq method (pop methods))
213 (when (string-match method type)
218 (defun add-mime-display-method (type method)
219 "Make parts of TYPE be displayed with METHOD.
220 This overrides entries in the mailcap file."
221 (push (cons type method) mm-user-display-methods))
223 (defun mm-destroy-part (handle)
224 "Destroy the data structures connected to HANDLE."
225 (mm-remove-part handle)
226 (when (buffer-live-p (car handle))
227 (kill-buffer (car handle))))
229 (defun mm-quote-arg (arg)
230 "Return a version of ARG that is safe to evaluate in a shell."
231 (let ((pos 0) new-pos accum)
232 ;; *** bug: we don't handle newline characters properly
233 (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos))
234 (push (substring arg pos new-pos) accum)
236 (push (list (aref arg new-pos)) accum)
237 (setq pos (1+ new-pos)))
240 (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
243 ;;; Functions for displaying various formats inline
246 (defun mm-inline-image (handle)
247 (let ((type (cadr (split-string (caadr handle) "/")))
249 (mm-with-unibyte-buffer
250 (insert-buffer-substring (car handle))
251 (mm-decode-content-transfer-encoding (nth 2 handle))
252 (setq image (make-image-specifier
253 (vector (intern type) :data (buffer-string)))))
254 (let ((annot (make-annotation image nil 'text)))
255 (set-extent-property annot 'mm t)
256 (set-extent-property annot 'duplicable t)
257 (setcar (nthcdr 3 handle) annot))))
259 (defun mm-inline-text (handle)
260 (let ((type (cadr (split-string (caadr handle) "/")))
261 text buffer-read-only)
262 (mm-with-unibyte-buffer
263 (insert-buffer-substring (car handle))
264 (mm-decode-content-transfer-encoding (nth 2 handle))
265 (setq text (buffer-string)))
267 ((equal type "plain")
273 (let (buffer-read-only)
274 (delete-region ,(set-marker (make-marker) b)
275 ,(set-marker (make-marker) (point)))))))))))
280 ;; mm-decode.el ends here