Mercurial > emacs
comparison lisp/mail/rmailmm.el @ 88306:7b65aade5e20
new file, based on Alexander Pohoyda's code.
author | Alex Schroeder <alex@gnu.org> |
---|---|
date | Tue, 31 Jan 2006 20:53:28 +0000 |
parents | |
children | b72b8d536511 |
comparison
equal
deleted
inserted
replaced
88305:7d98f9b9bb70 | 88306:7b65aade5e20 |
---|---|
1 ;;; rmailmm.el --- MIME decoding and display stuff for RMAIL | |
2 | |
3 ;; Copyright (C) 2006 Free Software Foundation, Inc. | |
4 | |
5 ;; Maintainer: FSF | |
6 ;; Keywords: mail | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
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) | |
13 ;; any later version. | |
14 | |
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. | |
19 | |
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. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; Essentially based on the design of Alexander Pohoyda's MIME | |
28 ;; extensions (mime-display.el and mime.el). The current design tries | |
29 ;; to work on the current buffer, without changing it's text. All it | |
30 ;; does is add text properties: It uses the text property `invisible' | |
31 ;; to hide MIME boundaries and ignored media types, and it uses the | |
32 ;; text property `display' to display something instead of the actual | |
33 ;; MIME part. | |
34 | |
35 ;;; Code: | |
36 | |
37 ;;; Variables | |
38 | |
39 (defcustom mime-media-type-handlers-alist | |
40 '(("multipart/.*" mime-multipart-handler) | |
41 ("message/rfc822" mime-toggler-handler) | |
42 ("message/delivery-status" mime-entity-hider-handler) | |
43 ("message/x-body" mime-entity-hider-handler) | |
44 ("message/x-command-input" mime-message/x-command-input-handler) | |
45 ("message/external-body" mime-message/external-body-handler) | |
46 ("text/.*" mime-text-handler) | |
47 ("text/\\(x-\\)?patch" mime-bulk-handler) | |
48 ("image/.*" mime-image-handler) | |
49 ("application/pgp-signature" mime-application/pgp-signature-handler) | |
50 ("\\(image\\|audio\\|video\\|application\\)/.*" mime-bulk-handler)) | |
51 "Alist of media type handlers, also known as agents. | |
52 Every handler is a list of type (string symbol) where STRING is a | |
53 regular expression to match the media type with and SYMBOL is a | |
54 function to run." | |
55 :type 'list | |
56 :group 'mime) | |
57 | |
58 (defcustom mime-attachment-dirs-alist | |
59 '(("text/.*" ("~/Documents")) | |
60 ("image/.*" ("~/Pictures")) | |
61 (".*" ("/tmp/"))) | |
62 "Default directories to save attachments into. Each media type may have | |
63 it's own directory." | |
64 :type 'list | |
65 :group 'mime) | |
66 | |
67 (defvar mime-total-number-of-bulk-attachments 0 | |
68 "A total number of attached bulk bodyparts in the message. If more than 3, | |
69 offer a way to save all attachments at once.") | |
70 (put 'mime-total-number-of-bulk-attachments 'permanent-local t) | |
71 | |
72 ;;; Utility Functions | |
73 | |
74 (defun mime-hide-region (from to) | |
75 "Put text property `invisible' on the region FROM TO." | |
76 (put-text-property from to 'invisible t)) | |
77 | |
78 (defun mime-unhide-region (from to) | |
79 "Remove the text property `invisible' on the region FROM TO." | |
80 (remove-text-properties from to '(invisible nil))) | |
81 | |
82 (defun mime-display-region-as (from to text) | |
83 "Put text property `display' with value TEXT on the region FROM TO." | |
84 (put-text-property from to 'display text)) | |
85 | |
86 ;;; Buttons | |
87 | |
88 (defun mime-save (button) | |
89 "Save the attachment using info in the BUTTON." | |
90 (let* ((filename (button-get button 'filename)) | |
91 (directory (button-get button 'directory)) | |
92 (data (button-get button 'data))) | |
93 (setq filename (expand-file-name | |
94 (read-file-name "Save as: " | |
95 directory nil nil filename))) | |
96 (when (file-regular-p filename) | |
97 (error (message "File `%s' already exists" filename))) | |
98 (with-temp-file filename | |
99 (set-buffer-file-coding-system 'no-conversion) | |
100 (insert data)))) | |
101 | |
102 (define-button-type 'mime-save | |
103 'action 'mime-save) | |
104 | |
105 ;;; Handlers | |
106 | |
107 (defun mime-text-handler (content-type | |
108 content-disposition | |
109 content-transfer-encoding) | |
110 "Handle the current buffer as a plain text MIME part.") | |
111 | |
112 (defun mime-bulk-handler (content-type | |
113 content-disposition | |
114 content-transfer-encoding) | |
115 "Handle the current buffer as an attachment to download." | |
116 (setq mime-total-number-of-bulk-attachments | |
117 (1+ mime-total-number-of-bulk-attachments)) | |
118 ;; Find the default directory for this media type | |
119 (let* ((directory (catch 'directory | |
120 (dolist (entry mime-attachment-dirs-alist) | |
121 (when (string-match (car entry) (car content-type)) | |
122 (throw 'directory (cadr entry)))))) | |
123 (filename (or (cdr (assq 'name (cdr content-type))) | |
124 (cdr (assq 'filename (cdr content-disposition))) | |
125 "noname")) | |
126 (button (format "\nAttached %s file: %s" | |
127 (car content-type) | |
128 (let ((data (buffer-string))) | |
129 (with-temp-buffer | |
130 (insert-button filename :type 'mime-save | |
131 'filename filename | |
132 'directory directory | |
133 'data data) | |
134 (buffer-string)))))) | |
135 (mime-display-region-as (point-min) (point-max) button))) | |
136 | |
137 (defun mime-multipart-handler (content-type | |
138 content-disposition | |
139 content-transfer-encoding) | |
140 "Handle the current buffer as a multipart MIME body. | |
141 The current buffer should be narrowed to the body. CONTENT-TYPE, | |
142 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values | |
143 of the respective parsed headers. See `mime-handle' for their | |
144 format." | |
145 ;; Some MUAs start boundaries with "--", while it should start | |
146 ;; with "CRLF--", as defined by RFC 2046: | |
147 ;; The boundary delimiter MUST occur at the beginning of a line, | |
148 ;; i.e., following a CRLF, and the initial CRLF is considered to | |
149 ;; be attached to the boundary delimiter line rather than part | |
150 ;; of the preceding part. | |
151 ;; We currently don't handle that. | |
152 (let ((boundary (cdr (assq 'boundary content-type))) | |
153 (beg (point-min)) | |
154 next) | |
155 (unless boundary | |
156 (error "No boundary defined" content-type content-disposition | |
157 content-transfer-encoding)) | |
158 (setq boundary (concat "\n--" boundary)) | |
159 ;; Hide the body before the first bodypart | |
160 (goto-char beg) | |
161 (when (and (search-forward boundary nil t) | |
162 (looking-at "[ \t]*\n")) | |
163 (mime-hide-region beg (match-end 0)) | |
164 (setq beg (match-end 0))) | |
165 ;; Reset the counter | |
166 (setq mime-total-number-of-bulk-attachments 0) | |
167 ;; Loop over all body parts, where beg points at the beginning of | |
168 ;; the part and end points at the end of the part. next points at | |
169 ;; the beginning of the next part. | |
170 (while (search-forward boundary nil t) | |
171 (setq end (match-beginning 0)) | |
172 ;; If this is the last boundary according to RFC 2046, hide the | |
173 ;; epilogue, else hide the boundary only. | |
174 (cond ((looking-at "--[ \t]*\n") | |
175 (setq next (point-max))) | |
176 ((looking-at "[ \t]*\n") | |
177 (setq next (match-end 0))) | |
178 (t | |
179 (error "Malformed boundary" content-type | |
180 content-disposition content-transfer-encoding))) | |
181 (mime-hide-region end next) | |
182 ;; Handle the part. | |
183 (save-match-data | |
184 (save-excursion | |
185 (save-restriction | |
186 (narrow-to-region beg end) | |
187 ;; FIXME: Do decoding of content-transfer-encoding | |
188 (mime-show)))) | |
189 (setq beg next) | |
190 (goto-char beg)))) | |
191 | |
192 (defun test-mime-multipart-handler () | |
193 "Test of a mail used as an example in RFC 2046." | |
194 (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com> | |
195 To: Ned Freed <ned@innosoft.com> | |
196 Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST) | |
197 Subject: Sample message | |
198 MIME-Version: 1.0 | |
199 Content-type: multipart/mixed; boundary=\"simple boundary\" | |
200 | |
201 This is the preamble. It is to be ignored, though it | |
202 is a handy place for composition agents to include an | |
203 explanatory note to non-MIME conformant readers. | |
204 | |
205 --simple boundary | |
206 | |
207 This is implicitly typed plain US-ASCII text. | |
208 It does NOT end with a linebreak. | |
209 --simple boundary | |
210 Content-type: text/plain; charset=us-ascii | |
211 | |
212 This is explicitly typed plain US-ASCII text. | |
213 It DOES end with a linebreak. | |
214 | |
215 --simple boundary-- | |
216 | |
217 This is the epilogue. It is also to be ignored.")) | |
218 (switch-to-buffer (get-buffer-create "*test*")) | |
219 (erase-buffer) | |
220 (insert mail) | |
221 (mime-show t) | |
222 (buffer-string))) | |
223 | |
224 ;;; Main code | |
225 | |
226 (defun mime-handle (content-type content-disposition content-transfer-encoding) | |
227 "Handle the current buffer as a MIME part. | |
228 The current buffer should be narrowed to the respective body. | |
229 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING | |
230 are the values of the respective parsed headers. The parsed | |
231 headers for CONTENT-TYPE and CONTENT-DISPOSITION have the form | |
232 | |
233 \(VALUE . ALIST) | |
234 | |
235 In other words: | |
236 | |
237 \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) | |
238 | |
239 VALUE is a string and ATTRIBUTE is a symbol. | |
240 | |
241 Consider the following header, for example: | |
242 | |
243 Content-Type: multipart/mixed; | |
244 boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\" | |
245 | |
246 The parsed header value: | |
247 | |
248 \(\"multipart/mixed\" | |
249 \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))" | |
250 (if (string= "inline" (car content-disposition)) | |
251 (let ((stop nil)) | |
252 (dolist (entry mime-media-type-handlers-alist) | |
253 (when (and (string-match (car entry) (car content-type)) (not stop)) | |
254 (progn | |
255 (setq stop (funcall (cadr entry) content-type | |
256 content-disposition | |
257 content-transfer-encoding)))))) | |
258 ;; treat everything else as an attachment | |
259 (mime-bulk-handler content-type | |
260 content-disposition | |
261 content-transfer-encoding))) | |
262 | |
263 (defun mime-show (&optional show-headers) | |
264 "Handle the current buffer as a MIME message. | |
265 If SHOW-HEADERS is non-nil, then the headers of the current part | |
266 are not all hidden, as they usually are \(except for | |
267 message/rfc822 content types\). This is usually only used for | |
268 the top-level call. | |
269 | |
270 The current buffer must be narrowed to a single message. | |
271 This function will be called recursively if multiple parts | |
272 are available." | |
273 (let ((end (point-min)) | |
274 content-type | |
275 content-transfer-encoding | |
276 content-disposition) | |
277 ;; `point-min' returns the beginning and `end' points at the end | |
278 ;; of the headers. We're not using `rmail-header-get-header' | |
279 ;; because we must be able to handle the case of no headers | |
280 ;; existing in a part. In this case end is at point-min. | |
281 (goto-char (point-min)) | |
282 ;; If we're showing a part without headers, then it will start | |
283 ;; with a newline. | |
284 (if (eq (char-after) ?\n) | |
285 (setq end (1+ (point))) | |
286 (when (search-forward "\n\n" nil t) | |
287 (setq end (match-end 0)) | |
288 (save-restriction | |
289 (narrow-to-region (point-min) end) | |
290 ;; FIXME: Default disposition of the multipart entities should | |
291 ;; be inherited. | |
292 (setq content-type | |
293 (mail-fetch-field "Content-Type") | |
294 content-transfer-encoding | |
295 (mail-fetch-field "Content-Transfer-Encoding") | |
296 content-disposition | |
297 (mail-fetch-field "Content-Disposition"))))) | |
298 (if content-type | |
299 (setq content-type (mail-header-parse-content-type | |
300 content-type)) | |
301 ;; FIXME: Default "message/rfc822" in a "multipart/digest" | |
302 ;; according to RFC 2046. | |
303 (setq content-type '("text/plain"))) | |
304 (setq content-disposition | |
305 (if content-disposition | |
306 (mail-header-parse-content-disposition content-disposition) | |
307 ;; If none specified, we are free to choose what we deem | |
308 ;; suitable according to RFC 2183. We like inline. | |
309 '("inline"))) | |
310 ;; Hide headers. | |
311 (if (or (string= (car content-type) "message/rfc822") | |
312 show-headers) | |
313 (rmail-header-hide-headers) | |
314 (mime-hide-region (point-min) end)) | |
315 ;; Unrecognized disposition types are to be treated like | |
316 ;; attachment according to RFC 2183. | |
317 (unless (string= (car content-disposition) "inline") | |
318 (setq content-disposition '("attachment"))) | |
319 (save-restriction | |
320 (narrow-to-region end (point-max)) | |
321 (mime-handle content-type content-disposition | |
322 content-transfer-encoding)))) |