1 ;;; pmailmm.el --- MIME decoding and display stuff for PMAIL
3 ;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; Essentially based on the design of Alexander Pohoyda's MIME
28 ;; extensions (mime-display.el and mime.el). To use, copy a complete
29 ;; message into a new buffer and call (mime-show t).
33 ;; (autoload 'pmail-mime "pmailmm"
34 ;; "Show MIME message." t)
35 ;; (add-hook 'pmail-mode-hook
37 ;; (define-key pmail-mode-map (kbd "v")
47 (defcustom pmail-mime-media-type-handlers-alist
48 '(("multipart/.*" pmail-mime-multipart-handler
)
49 ("text/.*" pmail-mime-text-handler
)
50 ("text/\\(x-\\)?patch" pmail-mime-bulk-handler
)
51 ("application/pgp-signature" pmail-mime-application
/pgp-signature-handler
)
52 ("\\(image\\|audio\\|video\\|application\\)/.*" pmail-mime-bulk-handler
))
53 "Alist of media type handlers, also known as agents.
54 Every handler is a list of type (string symbol) where STRING is a
55 regular expression to match the media type with and SYMBOL is a
56 function to run. Handlers should return a non-nil value if the
61 (defcustom pmail-mime-attachment-dirs-alist
62 '(("text/.*" "~/Documents")
63 ("image/.*" "~/Pictures")
64 (".*" "~/Desktop" "~" "/tmp"))
65 "Default directories to save attachments into.
66 Each media type may have it's own list of directories in order of
67 preference. The first existing directory in the list will be
72 (defvar pmail-mime-total-number-of-bulk-attachments
0
73 "A total number of attached bulk bodyparts in the message. If more than 3,
74 offer a way to save all attachments at once.")
75 (put 'pmail-mime-total-number-of-bulk-attachments
'permanent-local t
)
79 (defun pmail-mime-save (button)
80 "Save the attachment using info in the BUTTON."
81 (let* ((filename (button-get button
'filename
))
82 (directory (button-get button
'directory
))
83 (data (button-get button
'data
)))
84 (while (file-exists-p (expand-file-name filename directory
))
85 (let* ((f (file-name-sans-extension filename
))
87 (when (string-match "-\\([0-9]+\\)$" f
)
88 (setq i
(1+ (string-to-number (match-string 1 f
)))
89 f
(substring f
0 (match-beginning 0))))
90 (setq filename
(concat f
"-" (number-to-string i
) "."
91 (file-name-extension filename
)))))
92 (setq filename
(expand-file-name
93 (read-file-name (format "Save as (default: %s): " filename
)
95 (expand-file-name filename directory
))
97 (when (file-regular-p filename
)
98 (error (message "File `%s' already exists" filename
)))
99 (with-temp-file filename
100 (set-buffer-file-coding-system 'no-conversion
)
103 (define-button-type 'pmail-mime-save
104 'action
'pmail-mime-save
)
108 (defun pmail-mime-text-handler (content-type
110 content-transfer-encoding
)
111 "Handle the current buffer as a plain text MIME part."
112 (let* ((charset (cdr (assq 'charset
(cdr content-type
))))
113 (coding-system (when charset
114 (intern (downcase charset
)))))
115 (when (coding-system-p coding-system
)
116 (decode-coding-region (point-min) (point-max) coding-system
))))
118 (defun test-pmail-mime-handler ()
119 "Test of a mail using no MIME parts at all."
120 (let ((mail "To: alex@gnu.org
121 Content-Type: text/plain; charset=koi8-r
122 Content-Transfer-Encoding: 8bit
125 \372\304\322\301\327\323\324\327\325\312\324\305\41"))
126 (switch-to-buffer (get-buffer-create "*test*"))
128 (set-buffer-multibyte nil
)
131 (set-buffer-multibyte t
)))
133 (defun pmail-mime-bulk-handler (content-type
135 content-transfer-encoding
)
136 "Handle the current buffer as an attachment to download."
137 (setq pmail-mime-total-number-of-bulk-attachments
138 (1+ pmail-mime-total-number-of-bulk-attachments
))
139 ;; Find the default directory for this media type
140 (let* ((directory (catch 'directory
141 (dolist (entry pmail-mime-attachment-dirs-alist
)
142 (when (string-match (car entry
) (car content-type
))
143 (dolist (dir (cdr entry
))
144 (when (file-directory-p dir
)
145 (throw 'directory dir
)))))))
146 (filename (or (cdr (assq 'name
(cdr content-type
)))
147 (cdr (assq 'filename
(cdr content-disposition
)))
149 (label (format "\nAttached %s file: " (car content-type
)))
150 (data (buffer-string)))
151 (delete-region (point-min) (point-max))
153 (insert-button filename
154 :type
'pmail-mime-save
159 (defun test-pmail-mime-bulk-handler ()
160 "Test of a mail used as an example in RFC 2183."
161 (let ((mail "Content-Type: image/jpeg
162 Content-Disposition: attachment; filename=genome.jpeg;
163 modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
164 Content-Description: a complete map of the human genome
165 Content-Transfer-Encoding: base64
167 iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
168 TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
169 +ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
170 WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
171 9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
172 UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
175 (switch-to-buffer (get-buffer-create "*test*"))
180 (defun pmail-mime-multipart-handler (content-type
182 content-transfer-encoding
)
183 "Handle the current buffer as a multipart MIME body.
184 The current buffer should be narrowed to the body. CONTENT-TYPE,
185 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
186 of the respective parsed headers. See `pmail-mime-handle' for their
188 ;; Some MUAs start boundaries with "--", while it should start
189 ;; with "CRLF--", as defined by RFC 2046:
190 ;; The boundary delimiter MUST occur at the beginning of a line,
191 ;; i.e., following a CRLF, and the initial CRLF is considered to
192 ;; be attached to the boundary delimiter line rather than part
193 ;; of the preceding part.
194 ;; We currently don't handle that.
195 (let ((boundary (cdr (assq 'boundary content-type
)))
198 (pmail-mm-get-boundary-error-message
199 "No boundary defined" content-type content-disposition
200 content-transfer-encoding
))
201 (setq boundary
(concat "\n--" boundary
))
202 ;; Hide the body before the first bodypart
203 (goto-char (point-min))
204 (when (and (search-forward boundary nil t
)
205 (looking-at "[ \t]*\n"))
206 (delete-region (point-min) (match-end 0)))
208 (setq pmail-mime-total-number-of-bulk-attachments
0)
209 ;; Loop over all body parts, where beg points at the beginning of
210 ;; the part and end points at the end of the part. next points at
211 ;; the beginning of the next part.
212 (setq beg
(point-min))
213 (while (search-forward boundary nil t
)
214 (setq end
(match-beginning 0))
215 ;; If this is the last boundary according to RFC 2046, hide the
216 ;; epilogue, else hide the boundary only. Use a marker for
217 ;; `next' because `pmail-mime-show' may change the buffer.
218 (cond ((looking-at "--[ \t]*\n")
219 (setq next
(point-max-marker)))
220 ((looking-at "[ \t]*\n")
221 (setq next
(copy-marker (match-end 0))))
223 (pmail-mm-get-boundary-error-message
224 "Malformed boundary" content-type content-disposition
225 content-transfer-encoding
)))
226 (delete-region end next
)
231 (narrow-to-region beg end
)
236 (defun test-pmail-mime-multipart-handler ()
237 "Test of a mail used as an example in RFC 2046."
238 (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
239 To: Ned Freed <ned@innosoft.com>
240 Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
241 Subject: Sample message
243 Content-type: multipart/mixed; boundary=\"simple boundary\"
245 This is the preamble. It is to be ignored, though it
246 is a handy place for composition agents to include an
247 explanatory note to non-MIME conformant readers.
251 This is implicitly typed plain US-ASCII text.
252 It does NOT end with a linebreak.
254 Content-type: text/plain; charset=us-ascii
256 This is explicitly typed plain US-ASCII text.
257 It DOES end with a linebreak.
261 This is the epilogue. It is also to be ignored."))
262 (switch-to-buffer (get-buffer-create "*test*"))
265 (pmail-mime-show t
)))
269 (defun pmail-mime-handle (content-type
271 content-transfer-encoding
)
272 "Handle the current buffer as a MIME part.
273 The current buffer should be narrowed to the respective body, and
274 point should be at the beginning of the body.
276 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
277 are the values of the respective parsed headers. The parsed
278 headers for CONTENT-TYPE and CONTENT-DISPOSITION have the form
284 \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
286 VALUE is a string and ATTRIBUTE is a symbol.
288 Consider the following header, for example:
290 Content-Type: multipart/mixed;
291 boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
293 The parsed header value:
295 \(\"multipart/mixed\"
296 \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
297 ;; Handle the content transfer encodings we know. Unknown transfer
298 ;; encodings will be passed on to the various handlers.
299 (cond ((string= content-transfer-encoding
"base64")
301 (base64-decode-region (point) (point-max)))
302 (setq content-transfer-encoding nil
)))
303 ((string= content-transfer-encoding
"quoted-printable")
304 (quoted-printable-decode-region (point) (point-max))
305 (setq content-transfer-encoding nil
))
306 ((string= content-transfer-encoding
"8bit")
307 ;; FIXME: Is this the correct way?
308 (set-buffer-multibyte nil
)))
309 ;; Inline stuff requires work. Attachments are handled by the bulk
311 (if (string= "inline" (car content-disposition
))
313 (dolist (entry pmail-mime-media-type-handlers-alist
)
314 (when (and (string-match (car entry
) (car content-type
)) (not stop
))
316 (setq stop
(funcall (cadr entry
) content-type
318 content-transfer-encoding
))))))
319 ;; Everything else is an attachment.
320 (pmail-mime-bulk-handler content-type
322 content-transfer-encoding
)))
324 (defun pmail-mime-show (&optional show-headers
)
325 "Handle the current buffer as a MIME message.
326 If SHOW-HEADERS is non-nil, then the headers of the current part
327 will shown as usual for a MIME message. The headers are also
328 shown for the content type message/rfc822. This function will be
329 called recursively if multiple parts are available.
331 The current buffer must contain a single message. It will be
333 (let ((end (point-min))
335 content-transfer-encoding
337 ;; `point-min' returns the beginning and `end' points at the end
338 ;; of the headers. We're not using `pmail-header-get-header'
339 ;; because we must be able to handle the case of no headers
340 ;; existing in a part. In this case end is at point-min.
341 (goto-char (point-min))
342 ;; If we're showing a part without headers, then it will start
344 (if (eq (char-after) ?
\n)
345 (setq end
(1+ (point)))
346 (when (search-forward "\n\n" nil t
)
347 (setq end
(match-end 0))
349 (narrow-to-region (point-min) end
)
350 ;; FIXME: Default disposition of the multipart entities should
353 (mail-fetch-field "Content-Type")
354 content-transfer-encoding
355 (mail-fetch-field "Content-Transfer-Encoding")
357 (mail-fetch-field "Content-Disposition")))))
359 (setq content-type
(mail-header-parse-content-type
361 ;; FIXME: Default "message/rfc822" in a "multipart/digest"
362 ;; according to RFC 2046.
363 (setq content-type
'("text/plain")))
364 (setq content-disposition
365 (if content-disposition
366 (mail-header-parse-content-disposition content-disposition
)
367 ;; If none specified, we are free to choose what we deem
368 ;; suitable according to RFC 2183. We like inline.
370 ;; Unrecognized disposition types are to be treated like
371 ;; attachment according to RFC 2183.
372 (unless (member (car content-disposition
) '("inline" "attachment"))
373 (setq content-disposition
'("attachment")))
374 ;; Hide headers and handle the part.
376 (cond ((string= (car content-type
) "message/rfc822")
377 (pmail-header-hide-headers)
378 (narrow-to-region end
(point-max)))
380 (pmail-header-hide-headers))
382 (delete-region (point-min) end
)))
383 (pmail-mime-handle content-type content-disposition
384 content-transfer-encoding
))))
387 "Copy buffer contents to a temporary buffer and handle MIME.
388 This calls `pmail-mime-show' to do the real job."
390 (let ((data (with-current-buffer pmail-buffer
394 (pmail-desc-get-start pmail-current-message
)
395 (pmail-desc-get-end pmail-current-message
)))))
396 (buf (get-buffer-create "*PMAIL*")))
398 (let ((inhibit-read-only t
))
404 (defun pmail-mm-get-boundary-error-message (message type disposition encoding
)
405 "Return MESSAGE with more information on the main mime components."
406 (error "%s; type: %s; disposition: %s; encoding: %s"
407 message type disposition encoding
))
411 ;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
412 ;; pmailmm.el ends here