Mercurial > emacs
annotate lisp/gnus/mm-view.el @ 41346:42d60301f16a
(perl-mode): Don't use define-derived-mode.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Wed, 21 Nov 2001 11:01:55 +0000 |
parents | b6a0070476c7 |
children | b4833df45a4c |
rev | line source |
---|---|
38413
a26d9b55abb6
Some fixes to follow coding conventions in files from Gnus.
Pavel Janík <Pavel@Janik.cz>
parents:
33329
diff
changeset
|
1 ;;; mm-view.el --- functions for viewing MIME objects |
38635
b6a0070476c7
(autoload): Don't autoload `diff-mode' if it's
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
2 ;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. |
31717 | 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") | |
38635
b6a0070476c7
(autoload): Don't autoload `diff-mode' if it's
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
37 (unless (fboundp 'diff-mode) |
b6a0070476c7
(autoload): Don't autoload `diff-mode' if it's
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
38 (autoload 'diff-mode "diff-mode" "" t nil))) |
31717 | 39 |
40 ;;; | |
41 ;;; Functions for displaying various formats inline | |
42 ;;; | |
43 (defun mm-inline-image-emacs (handle) | |
44 (let ((b (point-marker)) | |
45 buffer-read-only) | |
46 (insert "\n") | |
47 (put-image (mm-get-image handle) b) | |
48 (mm-handle-set-undisplayer | |
49 handle | |
50 `(lambda () (remove-images ,b (1+ ,b)))))) | |
51 | |
52 (defun mm-inline-image-xemacs (handle) | |
53 (let ((b (point)) | |
54 (annot (make-annotation (mm-get-image handle) nil 'text)) | |
55 buffer-read-only) | |
56 (insert "\n") | |
57 (mm-handle-set-undisplayer | |
58 handle | |
59 `(lambda () | |
60 (let (buffer-read-only) | |
61 (delete-annotation ,annot) | |
62 (delete-region ,(set-marker (make-marker) b) | |
63 ,(set-marker (make-marker) (point)))))) | |
64 (set-extent-property annot 'mm t) | |
65 (set-extent-property annot 'duplicable t))) | |
66 | |
67 (eval-and-compile | |
33329 | 68 (if (featurep 'xemacs) |
31717 | 69 (defalias 'mm-inline-image 'mm-inline-image-xemacs) |
70 (defalias 'mm-inline-image 'mm-inline-image-emacs))) | |
71 | |
72 (defvar mm-w3-setup nil) | |
73 (defun mm-setup-w3 () | |
74 (unless mm-w3-setup | |
75 (require 'w3) | |
76 (w3-do-setup) | |
77 (require 'url) | |
78 (require 'w3-vars) | |
79 (require 'url-vars) | |
80 (setq mm-w3-setup t))) | |
81 | |
82 (defun mm-inline-text (handle) | |
83 (let ((type (mm-handle-media-subtype handle)) | |
84 text buffer-read-only) | |
85 (cond | |
86 ((equal type "html") | |
87 (mm-setup-w3) | |
88 (setq text (mm-get-part handle)) | |
89 (let ((b (point)) | |
90 (url-standalone-mode t) | |
91 (url-current-object | |
92 (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) | |
93 (width (window-width)) | |
94 (charset (mail-content-type-get | |
95 (mm-handle-type handle) 'charset))) | |
96 (save-excursion | |
97 (insert text) | |
98 (save-restriction | |
99 (narrow-to-region b (point)) | |
100 (goto-char (point-min)) | |
101 (if (or (and (boundp 'w3-meta-content-type-charset-regexp) | |
102 (re-search-forward | |
103 w3-meta-content-type-charset-regexp nil t)) | |
104 (and (boundp 'w3-meta-charset-content-type-regexp) | |
105 (re-search-forward | |
106 w3-meta-charset-content-type-regexp nil t))) | |
107 (setq charset (or (w3-coding-system-for-mime-charset | |
108 (buffer-substring-no-properties | |
109 (match-beginning 2) | |
110 (match-end 2))) | |
111 charset))) | |
112 (delete-region (point-min) (point-max)) | |
113 (insert (mm-decode-string text charset)) | |
114 (save-window-excursion | |
115 (save-restriction | |
116 (let ((w3-strict-width width) | |
117 ;; Don't let w3 set the global version of | |
118 ;; this variable. | |
119 (fill-column fill-column) | |
120 (url-standalone-mode t)) | |
121 (condition-case var | |
122 (w3-region (point-min) (point-max)) | |
123 (error))))) | |
124 (mm-handle-set-undisplayer | |
125 handle | |
126 `(lambda () | |
127 (let (buffer-read-only) | |
128 (if (functionp 'remove-specifier) | |
129 (mapcar (lambda (prop) | |
130 (remove-specifier | |
131 (face-property 'default prop) | |
132 (current-buffer))) | |
133 '(background background-pixmap foreground))) | |
134 (delete-region ,(point-min-marker) | |
135 ,(point-max-marker))))))))) | |
136 ((or (equal type "enriched") | |
137 (equal type "richtext")) | |
138 (save-excursion | |
139 (mm-with-unibyte-buffer | |
140 (mm-insert-part handle) | |
141 (save-window-excursion | |
142 (enriched-decode (point-min) (point-max)) | |
143 (setq text (buffer-string))))) | |
144 (mm-insert-inline handle text)) | |
145 ((equal type "x-vcard") | |
146 (mm-insert-inline | |
147 handle | |
148 (concat "\n-- \n" | |
149 (if (fboundp 'vcard-pretty-print) | |
150 (vcard-pretty-print (mm-get-part handle)) | |
151 (vcard-format-string | |
152 (vcard-parse-string (mm-get-part handle) | |
153 'vcard-standard-filter)))))) | |
154 (t | |
155 (let ((b (point)) | |
156 (charset (mail-content-type-get | |
157 (mm-handle-type handle) 'charset))) | |
158 (if (or (eq charset 'gnus-decoded) | |
159 ;; This is probably not entirely correct, but | |
160 ;; makes rfc822 parts with embedded multiparts work. | |
161 (eq mail-parse-charset 'gnus-decoded)) | |
162 (mm-insert-part handle) | |
163 (insert (mm-decode-string (mm-get-part handle) charset))) | |
164 (when (and (equal type "plain") | |
165 (equal (cdr (assoc 'format (mm-handle-type handle))) | |
166 "flowed")) | |
167 (save-restriction | |
168 (narrow-to-region b (point)) | |
169 (goto-char b) | |
170 (fill-flowed) | |
171 (goto-char (point-max)))) | |
172 (save-restriction | |
173 (narrow-to-region b (point)) | |
174 (set-text-properties (point-min) (point-max) nil) | |
175 (mm-handle-set-undisplayer | |
176 handle | |
177 `(lambda () | |
178 (let (buffer-read-only) | |
179 (delete-region ,(point-min-marker) | |
180 ,(point-max-marker))))))))))) | |
181 | |
182 (defun mm-insert-inline (handle text) | |
183 "Insert TEXT inline from HANDLE." | |
184 (let ((b (point))) | |
185 (insert text) | |
186 (mm-handle-set-undisplayer | |
187 handle | |
188 `(lambda () | |
189 (let (buffer-read-only) | |
190 (delete-region ,(set-marker (make-marker) b) | |
191 ,(set-marker (make-marker) (point)))))))) | |
192 | |
193 (defun mm-inline-audio (handle) | |
194 (message "Not implemented")) | |
195 | |
196 (defun mm-view-sound-file () | |
197 (message "Not implemented")) | |
198 | |
199 (defun mm-w3-prepare-buffer () | |
200 (require 'w3) | |
201 (let ((url-standalone-mode t)) | |
202 (w3-prepare-buffer))) | |
203 | |
204 (defun mm-view-message () | |
205 (mm-enable-multibyte) | |
206 (let (handles) | |
207 (let (gnus-article-mime-handles) | |
208 ;; Double decode problem may happen. See mm-inline-message. | |
209 (run-hooks 'gnus-article-decode-hook) | |
210 (gnus-article-prepare-display) | |
211 (setq handles gnus-article-mime-handles)) | |
212 (when handles | |
213 (setq gnus-article-mime-handles | |
214 (nconc gnus-article-mime-handles | |
215 (if (listp (car handles)) | |
216 handles (list handles)))))) | |
217 (fundamental-mode) | |
218 (goto-char (point-min))) | |
219 | |
220 (defun mm-inline-message (handle) | |
221 (let ((b (point)) | |
222 (charset (mail-content-type-get | |
223 (mm-handle-type handle) 'charset)) | |
224 gnus-displaying-mime handles) | |
225 (when (and charset | |
226 (stringp charset)) | |
227 (setq charset (intern (downcase charset))) | |
228 (when (eq charset 'us-ascii) | |
229 (setq charset nil))) | |
230 (save-excursion | |
231 (save-restriction | |
232 (narrow-to-region b b) | |
233 (mm-insert-part handle) | |
234 (let (gnus-article-mime-handles | |
235 ;; disable prepare hook | |
236 gnus-article-prepare-hook | |
237 (gnus-newsgroup-charset | |
238 (or charset gnus-newsgroup-charset))) | |
239 (run-hooks 'gnus-article-decode-hook) | |
240 (gnus-article-prepare-display) | |
241 (setq handles gnus-article-mime-handles)) | |
242 (goto-char (point-max)) | |
243 (unless (bolp) | |
244 (insert "\n")) | |
245 (insert "----------\n\n") | |
246 (when handles | |
247 (setq gnus-article-mime-handles | |
248 (nconc gnus-article-mime-handles | |
249 (if (listp (car handles)) | |
250 handles (list handles))))) | |
251 (mm-handle-set-undisplayer | |
252 handle | |
253 `(lambda () | |
254 (let (buffer-read-only) | |
33329 | 255 (if (fboundp 'remove-specifier) |
31717 | 256 ;; This is only valid on XEmacs. |
257 (mapcar (lambda (prop) | |
258 (remove-specifier | |
259 (face-property 'default prop) (current-buffer))) | |
33329 | 260 '(background background-pixmap foreground))) |
31717 | 261 (delete-region ,(point-min-marker) ,(point-max-marker))))))))) |
262 | |
31764 | 263 (defun mm-display-inline-fontify (handle mode) |
31717 | 264 (let (text) |
265 (with-temp-buffer | |
266 (mm-insert-part handle) | |
31764 | 267 (funcall mode) |
31717 | 268 (font-lock-fontify-buffer) |
269 (when (fboundp 'extent-list) | |
270 (map-extents (lambda (ext ignored) | |
271 (set-extent-property ext 'duplicable t) | |
272 nil) | |
273 nil nil nil nil nil 'text-prop)) | |
274 (setq text (buffer-string))) | |
275 (mm-insert-inline handle text))) | |
276 | |
31764 | 277 (defun mm-display-patch-inline (handle) |
278 (mm-display-inline-fontify handle 'diff-mode)) | |
279 | |
280 (defun mm-display-elisp-inline (handle) | |
281 (mm-display-inline-fontify handle 'emacs-lisp-mode)) | |
282 | |
31717 | 283 (provide 'mm-view) |
284 | |
38413
a26d9b55abb6
Some fixes to follow coding conventions in files from Gnus.
Pavel Janík <Pavel@Janik.cz>
parents:
33329
diff
changeset
|
285 ;;; mm-view.el ends here |