Commit | Line | Data |
---|---|---|
715a2ca2 | 1 | ;;; mm-view.el --- functions for viewing MIME objects |
c113de23 GM |
2 | ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. |
3 | ||
4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
5 | ;; This file is part of GNU Emacs. | |
6 | ||
7 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
8 | ;; it under the terms of the GNU General Public License as published by | |
9 | ;; the Free Software Foundation; either version 2, or (at your option) | |
10 | ;; any later version. | |
11 | ||
12 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;; GNU General Public License for more details. | |
16 | ||
17 | ;; You should have received a copy of the GNU General Public License | |
18 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
19 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 | ;; Boston, MA 02111-1307, USA. | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;;; Code: | |
25 | ||
26 | (eval-when-compile (require 'cl)) | |
27 | (require 'mail-parse) | |
28 | (require 'mailcap) | |
29 | (require 'mm-bodies) | |
30 | (require 'mm-decode) | |
31 | ||
32 | (eval-and-compile | |
33 | (autoload 'gnus-article-prepare-display "gnus-art") | |
34 | (autoload 'vcard-parse-string "vcard") | |
35 | (autoload 'vcard-format-string "vcard") | |
36 | (autoload 'fill-flowed "flow-fill") | |
37 | (autoload 'diff-mode "diff-mode")) | |
38 | ||
39 | ;;; | |
40 | ;;; Functions for displaying various formats inline | |
41 | ;;; | |
42 | (defun mm-inline-image-emacs (handle) | |
43 | (let ((b (point-marker)) | |
44 | buffer-read-only) | |
45 | (insert "\n") | |
46 | (put-image (mm-get-image handle) b) | |
47 | (mm-handle-set-undisplayer | |
48 | handle | |
49 | `(lambda () (remove-images ,b (1+ ,b)))))) | |
50 | ||
51 | (defun mm-inline-image-xemacs (handle) | |
52 | (let ((b (point)) | |
53 | (annot (make-annotation (mm-get-image handle) nil 'text)) | |
54 | buffer-read-only) | |
55 | (insert "\n") | |
56 | (mm-handle-set-undisplayer | |
57 | handle | |
58 | `(lambda () | |
59 | (let (buffer-read-only) | |
60 | (delete-annotation ,annot) | |
61 | (delete-region ,(set-marker (make-marker) b) | |
62 | ,(set-marker (make-marker) (point)))))) | |
63 | (set-extent-property annot 'mm t) | |
64 | (set-extent-property annot 'duplicable t))) | |
65 | ||
66 | (eval-and-compile | |
722a8409 | 67 | (if (featurep 'xemacs) |
c113de23 GM |
68 | (defalias 'mm-inline-image 'mm-inline-image-xemacs) |
69 | (defalias 'mm-inline-image 'mm-inline-image-emacs))) | |
70 | ||
71 | (defvar mm-w3-setup nil) | |
72 | (defun mm-setup-w3 () | |
73 | (unless mm-w3-setup | |
74 | (require 'w3) | |
75 | (w3-do-setup) | |
76 | (require 'url) | |
77 | (require 'w3-vars) | |
78 | (require 'url-vars) | |
79 | (setq mm-w3-setup t))) | |
80 | ||
81 | (defun mm-inline-text (handle) | |
82 | (let ((type (mm-handle-media-subtype handle)) | |
83 | text buffer-read-only) | |
84 | (cond | |
85 | ((equal type "html") | |
86 | (mm-setup-w3) | |
87 | (setq text (mm-get-part handle)) | |
88 | (let ((b (point)) | |
89 | (url-standalone-mode t) | |
90 | (url-current-object | |
91 | (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) | |
92 | (width (window-width)) | |
93 | (charset (mail-content-type-get | |
94 | (mm-handle-type handle) 'charset))) | |
95 | (save-excursion | |
96 | (insert text) | |
97 | (save-restriction | |
98 | (narrow-to-region b (point)) | |
99 | (goto-char (point-min)) | |
100 | (if (or (and (boundp 'w3-meta-content-type-charset-regexp) | |
101 | (re-search-forward | |
102 | w3-meta-content-type-charset-regexp nil t)) | |
103 | (and (boundp 'w3-meta-charset-content-type-regexp) | |
104 | (re-search-forward | |
105 | w3-meta-charset-content-type-regexp nil t))) | |
106 | (setq charset (or (w3-coding-system-for-mime-charset | |
107 | (buffer-substring-no-properties | |
108 | (match-beginning 2) | |
109 | (match-end 2))) | |
110 | charset))) | |
111 | (delete-region (point-min) (point-max)) | |
112 | (insert (mm-decode-string text charset)) | |
113 | (save-window-excursion | |
114 | (save-restriction | |
115 | (let ((w3-strict-width width) | |
116 | ;; Don't let w3 set the global version of | |
117 | ;; this variable. | |
118 | (fill-column fill-column) | |
119 | (url-standalone-mode t)) | |
120 | (condition-case var | |
121 | (w3-region (point-min) (point-max)) | |
122 | (error))))) | |
123 | (mm-handle-set-undisplayer | |
124 | handle | |
125 | `(lambda () | |
126 | (let (buffer-read-only) | |
127 | (if (functionp 'remove-specifier) | |
128 | (mapcar (lambda (prop) | |
129 | (remove-specifier | |
130 | (face-property 'default prop) | |
131 | (current-buffer))) | |
132 | '(background background-pixmap foreground))) | |
133 | (delete-region ,(point-min-marker) | |
134 | ,(point-max-marker))))))))) | |
135 | ((or (equal type "enriched") | |
136 | (equal type "richtext")) | |
137 | (save-excursion | |
138 | (mm-with-unibyte-buffer | |
139 | (mm-insert-part handle) | |
140 | (save-window-excursion | |
141 | (enriched-decode (point-min) (point-max)) | |
142 | (setq text (buffer-string))))) | |
143 | (mm-insert-inline handle text)) | |
144 | ((equal type "x-vcard") | |
145 | (mm-insert-inline | |
146 | handle | |
147 | (concat "\n-- \n" | |
148 | (if (fboundp 'vcard-pretty-print) | |
149 | (vcard-pretty-print (mm-get-part handle)) | |
150 | (vcard-format-string | |
151 | (vcard-parse-string (mm-get-part handle) | |
152 | 'vcard-standard-filter)))))) | |
153 | (t | |
154 | (let ((b (point)) | |
155 | (charset (mail-content-type-get | |
156 | (mm-handle-type handle) 'charset))) | |
157 | (if (or (eq charset 'gnus-decoded) | |
158 | ;; This is probably not entirely correct, but | |
159 | ;; makes rfc822 parts with embedded multiparts work. | |
160 | (eq mail-parse-charset 'gnus-decoded)) | |
161 | (mm-insert-part handle) | |
162 | (insert (mm-decode-string (mm-get-part handle) charset))) | |
163 | (when (and (equal type "plain") | |
164 | (equal (cdr (assoc 'format (mm-handle-type handle))) | |
165 | "flowed")) | |
166 | (save-restriction | |
167 | (narrow-to-region b (point)) | |
168 | (goto-char b) | |
169 | (fill-flowed) | |
170 | (goto-char (point-max)))) | |
171 | (save-restriction | |
172 | (narrow-to-region b (point)) | |
173 | (set-text-properties (point-min) (point-max) nil) | |
174 | (mm-handle-set-undisplayer | |
175 | handle | |
176 | `(lambda () | |
177 | (let (buffer-read-only) | |
178 | (delete-region ,(point-min-marker) | |
179 | ,(point-max-marker))))))))))) | |
180 | ||
181 | (defun mm-insert-inline (handle text) | |
182 | "Insert TEXT inline from HANDLE." | |
183 | (let ((b (point))) | |
184 | (insert text) | |
185 | (mm-handle-set-undisplayer | |
186 | handle | |
187 | `(lambda () | |
188 | (let (buffer-read-only) | |
189 | (delete-region ,(set-marker (make-marker) b) | |
190 | ,(set-marker (make-marker) (point)))))))) | |
191 | ||
192 | (defun mm-inline-audio (handle) | |
193 | (message "Not implemented")) | |
194 | ||
195 | (defun mm-view-sound-file () | |
196 | (message "Not implemented")) | |
197 | ||
198 | (defun mm-w3-prepare-buffer () | |
199 | (require 'w3) | |
200 | (let ((url-standalone-mode t)) | |
201 | (w3-prepare-buffer))) | |
202 | ||
203 | (defun mm-view-message () | |
204 | (mm-enable-multibyte) | |
205 | (let (handles) | |
206 | (let (gnus-article-mime-handles) | |
207 | ;; Double decode problem may happen. See mm-inline-message. | |
208 | (run-hooks 'gnus-article-decode-hook) | |
209 | (gnus-article-prepare-display) | |
210 | (setq handles gnus-article-mime-handles)) | |
211 | (when handles | |
212 | (setq gnus-article-mime-handles | |
213 | (nconc gnus-article-mime-handles | |
214 | (if (listp (car handles)) | |
215 | handles (list handles)))))) | |
216 | (fundamental-mode) | |
217 | (goto-char (point-min))) | |
218 | ||
219 | (defun mm-inline-message (handle) | |
220 | (let ((b (point)) | |
221 | (charset (mail-content-type-get | |
222 | (mm-handle-type handle) 'charset)) | |
223 | gnus-displaying-mime handles) | |
224 | (when (and charset | |
225 | (stringp charset)) | |
226 | (setq charset (intern (downcase charset))) | |
227 | (when (eq charset 'us-ascii) | |
228 | (setq charset nil))) | |
229 | (save-excursion | |
230 | (save-restriction | |
231 | (narrow-to-region b b) | |
232 | (mm-insert-part handle) | |
233 | (let (gnus-article-mime-handles | |
234 | ;; disable prepare hook | |
235 | gnus-article-prepare-hook | |
236 | (gnus-newsgroup-charset | |
237 | (or charset gnus-newsgroup-charset))) | |
238 | (run-hooks 'gnus-article-decode-hook) | |
239 | (gnus-article-prepare-display) | |
240 | (setq handles gnus-article-mime-handles)) | |
241 | (goto-char (point-max)) | |
242 | (unless (bolp) | |
243 | (insert "\n")) | |
244 | (insert "----------\n\n") | |
245 | (when handles | |
246 | (setq gnus-article-mime-handles | |
247 | (nconc gnus-article-mime-handles | |
248 | (if (listp (car handles)) | |
249 | handles (list handles))))) | |
250 | (mm-handle-set-undisplayer | |
251 | handle | |
252 | `(lambda () | |
253 | (let (buffer-read-only) | |
722a8409 | 254 | (if (fboundp 'remove-specifier) |
c113de23 GM |
255 | ;; This is only valid on XEmacs. |
256 | (mapcar (lambda (prop) | |
257 | (remove-specifier | |
258 | (face-property 'default prop) (current-buffer))) | |
722a8409 | 259 | '(background background-pixmap foreground))) |
c113de23 GM |
260 | (delete-region ,(point-min-marker) ,(point-max-marker))))))))) |
261 | ||
ce9401f3 | 262 | (defun mm-display-inline-fontify (handle mode) |
c113de23 GM |
263 | (let (text) |
264 | (with-temp-buffer | |
265 | (mm-insert-part handle) | |
ce9401f3 | 266 | (funcall mode) |
c113de23 GM |
267 | (font-lock-fontify-buffer) |
268 | (when (fboundp 'extent-list) | |
269 | (map-extents (lambda (ext ignored) | |
270 | (set-extent-property ext 'duplicable t) | |
271 | nil) | |
272 | nil nil nil nil nil 'text-prop)) | |
273 | (setq text (buffer-string))) | |
274 | (mm-insert-inline handle text))) | |
275 | ||
ce9401f3 DL |
276 | (defun mm-display-patch-inline (handle) |
277 | (mm-display-inline-fontify handle 'diff-mode)) | |
278 | ||
279 | (defun mm-display-elisp-inline (handle) | |
280 | (mm-display-inline-fontify handle 'emacs-lisp-mode)) | |
281 | ||
c113de23 GM |
282 | (provide 'mm-view) |
283 | ||
715a2ca2 | 284 | ;;; mm-view.el ends here |