Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-image.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents dbb370e3c29e
children fe104dbd9147
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers 1 ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers
2 2
3 ;; Copyright (C) 1995,1996 MORIOKA Tomohiko 3 ;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
4 ;; Copyright (C) 1996 Dan Rich 4 ;; Copyright (C) 1996 Dan Rich
5 5
6 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> 6 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;; Dan Rich <drich@morpheus.corp.sgi.com> 7 ;; Dan Rich <drich@morpheus.corp.sgi.com>
8 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp> 8 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
9 ;; Created: 1995/12/15 9 ;; Created: 1995/12/15
10 ;; Version: $Id: tm-image.el,v 1.3 1997/02/08 03:26:13 steve Exp $ 10 ;; Version: $Id: tm-image.el,v 1.4 1997/02/15 22:21:29 steve Exp $
11 11
12 ;; Keywords: mail, news, MIME, multimedia, image, picture, X-Face 12 ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
13 13
14 ;; This file is part of tm (Tools for MIME). 14 ;; This file is part of XEmacs.
15 15
16 ;; This program is free software; you can redistribute it and/or 16 ;; This program is free software; you can redistribute it and/or
17 ;; modify it under the terms of the GNU General Public License as 17 ;; modify it under the terms of the GNU General Public License as
18 ;; published by the Free Software Foundation; either version 2, or (at 18 ;; published by the Free Software Foundation; either version 2, or (at
19 ;; your option) any later version. 19 ;; your option) any later version.
22 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 22 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
24 ;; General Public License for more details. 24 ;; General Public License for more details.
25 25
26 ;; You should have received a copy of the GNU General Public License 26 ;; You should have received a copy of the GNU General Public License
27 ;; along with this program; see the file COPYING. If not, write to 27 ;; along with GNU XEmacs; see the file COPYING. If not, write to the
28 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
29 ;; Boston, MA 02111-1307, USA. 29 ;; Boston, MA 02111-1307, USA.
30 30
31 ;;; Commentary: 31 ;;; Commentary:
32 ;; If you use this program with MULE, please install 32 ;; If you use this program with MULE, please install
33 ;; etl8x16-bitmap.bdf font included in tl package. 33 ;; etl8x16-bitmap.bdf font included in tl package.
35 ;;; Code: 35 ;;; Code:
36 36
37 (require 'tm-view) 37 (require 'tm-view)
38 38
39 (cond (running-xemacs 39 (cond (running-xemacs
40 (require 'annotations) 40 (require 'images)
41 41
42 (set-alist 'mime-viewer/content-filter-alist 42 (defun-maybe image-inline-p (format)
43 "image/jpeg" 43 (or (memq format image-native-formats)
44 (if (featurep 'jpeg) ; Use built-in suport if available 44 (find-if (function
45 (function mime-preview/filter-for-inline-image) 45 (lambda (native)
46 (function mime-preview/filter-for-image) 46 (image-converter-chain format native)
47 )) 47 ))
48 48 image-native-formats)
49 (set-alist 'mime-viewer/content-filter-alist 49 ))
50 "image/gif" 50
51 (if (featurep 'gif) ; Use built-in suport if available 51 (image-register-netpbm-utilities)
52 (function mime-preview/filter-for-inline-image) 52 (image-register-converter 'pic 'ppm "pictoppm")
53 (function mime-preview/filter-for-image) 53 (image-register-converter 'mag 'ppm "magtoppm")
54 ))
55
56 (set-alist 'mime-viewer/content-filter-alist
57 "image/x-xpixmap"
58 (if (featurep 'xpm) ; Use built-in suport if available
59 (function mime-preview/filter-for-inline-image)
60 (function mime-preview/filter-for-image)
61 ))
62
63 (set-alist 'mime-viewer/content-filter-alist
64 "image/tiff" (function mime-preview/filter-for-image))
65 (set-alist 'mime-viewer/content-filter-alist
66 "image/x-tiff" (function mime-preview/filter-for-image))
67
68 (set-alist 'mime-viewer/content-filter-alist
69 "image/x-pic" (function mime-preview/filter-for-image))
70
71 (set-alist 'mime-viewer/content-filter-alist
72 "image/x-mag" (function mime-preview/filter-for-image))
73
74 (defvar tm-image/inline-image-types
75 (if (featurep 'gif)
76 (nconc
77 '("image/jpeg" "image/gif" "image/tiff"
78 "image/x-tiff" "image/x-pic" "image/x-mag"
79 "image/x-xbm" "image/x-xpixmap")
80 (if (featurep 'gif)
81 '("application/postscript")
82 )
83 )))
84 54
85 (defun bitmap-insert-xbm-file (file) 55 (defun bitmap-insert-xbm-file (file)
86 (let (gl) 56 (let ((gl (make-glyph (list (cons 'x file))))
87 (while (progn 57 (e (make-extent (point) (point)))
88 (setq gl (make-glyph file)) 58 )
89 (eq (image-instance-type (glyph-image-instance gl)) 59 (set-extent-end-glyph e gl)
90 'text)
91 ))
92 (make-annotation gl (point) 'text)
93 )) 60 ))
94 61
95 (defvar mime-viewer/image-converter-alist 62 ;;
96 '(("image/jpeg" . jpeg) 63 ;; X-Face
97 ("image/gif" . gif) 64 ;;
98 ("image/x-png" . png)
99 ("image/x-xpixmap" . xpm)
100 ))
101
102 (defvar mime-preview/x-face-function
103 (function mime-preview/x-face-function-use-highlight-headers))
104
105 (autoload 'highlight-headers "highlight-headers") 65 (autoload 'highlight-headers "highlight-headers")
106 66
107 (defun mime-preview/x-face-function-use-highlight-headers () 67 (defun mime-preview/x-face-function-use-highlight-headers ()
108 (highlight-headers (point-min) (re-search-forward "^$" nil t) t) 68 (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
109 ) 69 )
70
71 (add-hook 'mime-viewer/content-header-filter-hook
72 'mime-preview/x-face-function-use-highlight-headers)
73
110 ) 74 )
111 ((featurep 'mule) 75 ((featurep 'mule)
112 ;; for MULE 2.* or mule merged EMACS 76 ;; for MULE 2.* or mule merged EMACS
113 (require 'x-face-mule) 77 (require 'x-face-mule)
114 78
115 (defvar tm-image/inline-image-types '("image/x-mag" "image/x-xbm")) 79 (defvar image-native-formats '(xbm))
116 80
117 (defvar mime-preview/x-face-function 81 (defun-maybe image-inline-p (format)
118 (function x-face-decode-message-header)) 82 (memq format image-native-formats)
83 )
84
85 (defun-maybe image-normalize (format data)
86 (and (eq format 'xbm)
87 (vector 'xbm ':data data)
88 ))
89
90 ;;
91 ;; X-Face
92 ;;
93 (if (file-installed-p uncompface-program exec-path)
94 (add-hook 'mime-viewer/content-header-filter-hook
95 'x-face-decode-message-header)
96 )
119 )) 97 ))
120 98
121 (defvar mime-viewer/shell-command "/bin/sh") 99 (or (fboundp 'image-invalid-glyph-p)
122 (defvar mime-viewer/shell-arguments '("-c")) 100 (defsubst image-invalid-glyph-p (glyph)
101 (or (null (aref glyph 0))
102 (null (aref glyph 2))
103 (equal (aref glyph 2) "")
104 ))
105 )
106
107 (defvar mime-viewer/image-converter-alist nil)
108
109 (mapcar (function
110 (lambda (rule)
111 (let ((ctype (car rule))
112 (format (cdr rule))
113 )
114 (if (image-inline-p format)
115 (progn
116 (set-alist 'mime-viewer/content-filter-alist
117 ctype
118 (function mime-preview/filter-for-image))
119 (set-alist 'mime-viewer/image-converter-alist
120 ctype format)
121 (add-to-list
122 'mime-viewer/default-showing-Content-Type-list
123 ctype)
124 )
125 ))))
126 '(("image/jpeg" . jpeg)
127 ("image/gif" . gif)
128 ("image/tiff" . tiff)
129 ("image/x-tiff" . tiff)
130 ("image/xbm" . xbm)
131 ("image/x-xbm" . xbm)
132 ("image/x-xpixmap" . xpm)
133 ("image/x-pic" . pic)
134 ("image/x-mag" . mag)
135 ))
123 136
124 (defvar mime-viewer/ps-to-gif-command "pstogif") 137 (defvar mime-viewer/ps-to-gif-command "pstogif")
125
126 (defvar mime-viewer/graphic-converter-alist
127 '(("image/jpeg" . "djpeg -color 256 < %s | ppmtoxpm > %s")
128 ("image/gif" . "giftopnm < %s | ppmtoxpm > %s")
129 ("image/tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s")
130 ("image/x-tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s")
131 ("image/x-pic" . "pictoppm < %s | ppmquant 256 | ppmtoxpm > %s")
132 ("image/x-mag" . "magtoppm < %s | ppmtoxpm > %s")
133 ))
134
135
136 ;;; @ X-Face
137 ;;;
138
139 (defvar mime-viewer/x-face-to-xbm-command
140 (concat mime-viewer/x-face-to-pbm-command " | pbmtoxbm"))
141
142 (if mime-preview/x-face-function
143 (add-hook 'mime-viewer/content-header-filter-hook
144 mime-preview/x-face-function)
145 )
146 138
147 139
148 ;;; @ content filter for images 140 ;;; @ content filter for images
149 ;;; 141 ;;;
150 ;; (for XEmacs 19.12 or later) 142 ;; (for XEmacs 19.12 or later)
151 143
152 (defun mime-preview/filter-for-image (ctype params encoding) 144 (defun mime-preview/filter-for-image (ctype params encoding)
153 (let* ((mode mime::preview/original-major-mode)
154 (m (assq mode mime-viewer/code-converter-alist))
155 (filter (assoc-value ctype mime-viewer/graphic-converter-alist))
156 )
157 (if filter
158 (let* ((beg (point-min)) (end (point-max))
159 (orig-file
160 (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
161 (xbm-file (concat orig-file ".xbm"))
162 gl annot)
163 ;;(remove-text-properties beg end '(face nil))
164 (mime-decode-region beg end encoding)
165 (write-region (point-min)(point-max) orig-file)
166 (delete-region (point-min)(point-max))
167 (message "Now translating, please wait...")
168 (apply (function call-process)
169 mime-viewer/shell-command nil nil nil
170 (append mime-viewer/shell-arguments
171 (list (format filter orig-file xbm-file)))
172 )
173 (setq gl (make-glyph xbm-file))
174 (setq annot (make-annotation gl (point) 'text))
175 (unwind-protect
176 (delete-file orig-file)
177 (condition-case nil
178 (delete-file xbm-file)
179 (error nil)))
180 (goto-char (point-max))
181 (insert "\n")
182 (message "Translation done.")
183 )
184 (message (format "%s is not supported." ctype))
185 )))
186
187
188 ;;; @ content filter for xbm
189 ;;;
190
191 (defun mime-preview/filter-for-image/xbm (ctype params encoding)
192 (let* ((mode mime::preview/original-major-mode) 145 (let* ((mode mime::preview/original-major-mode)
193 (m (assq mode mime-viewer/code-converter-alist)) 146 (m (assq mode mime-viewer/code-converter-alist))
194 (charset (assoc "charset" params)) 147 (charset (assoc "charset" params))
195 (beg (point-min)) (end (point-max)) 148 (beg (point-min)) (end (point-max))
196 (xbm-file (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
197 ) 149 )
198 (remove-text-properties beg end '(face nil)) 150 (remove-text-properties beg end '(face nil))
151 (message "Decoding image...")
199 (mime-decode-region beg end encoding) 152 (mime-decode-region beg end encoding)
200 (write-region (point-min)(point-max) xbm-file) 153 (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist))
201 (delete-region (point-min)(point-max)) 154 (gl (image-normalize minor (buffer-string)))
202 (bitmap-insert-xbm-file xbm-file) 155 e)
203 (delete-file xbm-file)
204 ))
205
206 (set-alist 'mime-viewer/content-filter-alist
207 "image/xbm" (function mime-preview/filter-for-image/xbm))
208
209 (set-alist 'mime-viewer/content-filter-alist
210 "image/x-xbm" (function mime-preview/filter-for-image/xbm))
211
212
213 ;;; @ content filter for support in-line image types
214 ;;;
215 ;; (for XEmacs 19.14 or later)
216
217 (defun mime-preview/filter-for-inline-image (ctype params encoding)
218 (let* ((mode mime::preview/original-major-mode)
219 (m (assq mode mime-viewer/code-converter-alist))
220 (charset (assoc "charset" params))
221 (beg (point-min)) (end (point-max))
222 )
223 (remove-text-properties beg end '(face nil))
224 (mime-decode-region beg end encoding)
225 (let ((data (buffer-string))
226 (minor (assoc-value ctype mime-viewer/image-converter-alist))
227 gl e)
228 (delete-region (point-min)(point-max)) 156 (delete-region (point-min)(point-max))
229 (while (progn 157 (cond ((image-invalid-glyph-p gl)
230 (setq gl (make-glyph (vector minor :data data))) 158 (setq gl nil)
231 (eq (image-instance-type (glyph-image-instance gl)) 159 (message "Invalid glyph!")
232 'text) 160 )
233 )) 161 ((eq (aref gl 0) 'xbm)
234 (setq e (make-extent (point) (point))) 162 (let ((xbm-file
235 (set-extent-end-glyph e gl) 163 (make-temp-name (expand-file-name "tm" mime/tmp-dir))))
164 (insert (aref gl 2))
165 (write-region (point-min)(point-max) xbm-file)
166 (message "Decoding image...")
167 (delete-region (point-min)(point-max))
168 (bitmap-insert-xbm-file xbm-file)
169 (delete-file xbm-file)
170 )
171 (message "Decoding image... done")
172 )
173 (t
174 (setq gl (make-glyph gl))
175 (setq e (make-extent (point) (point)))
176 (set-extent-end-glyph e gl)
177 (message "Decoding image... done")
178 ))
236 ) 179 )
237 (insert "\n") 180 (insert "\n")
238 )) 181 ))
239 182
240 183
249 (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir))) 192 (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
250 (ps-file (concat file-base ".ps")) 193 (ps-file (concat file-base ".ps"))
251 (gif-file (concat file-base ".gif")) 194 (gif-file (concat file-base ".gif"))
252 ) 195 )
253 (remove-text-properties beg end '(face nil)) 196 (remove-text-properties beg end '(face nil))
197 (message "Decoding Postscript...")
254 (mime-decode-region beg end encoding) 198 (mime-decode-region beg end encoding)
255 (write-region (point-min)(point-max) ps-file) 199 (write-region (point-min)(point-max) ps-file)
200 (message "Decoding Postscript...")
256 (delete-region (point-min)(point-max)) 201 (delete-region (point-min)(point-max))
257 (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file) 202 (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file)
258 (let (gl) 203 (set-extent-end-glyph (make-extent (point) (point))
259 (while (progn 204 (make-glyph (vector 'gif :file gif-file)))
260 (setq gl (make-glyph (vector 'gif :file gif-file))) 205 (message "Decoding Postscript... done")
261 (eq (image-instance-type (glyph-image-instance gl))
262 'text)
263 ))
264 (make-annotation gl (point) 'text)
265 )
266 (delete-file ps-file) 206 (delete-file ps-file)
267 (delete-file gif-file) 207 (delete-file gif-file)
268 )) 208 ))
269 209
270 (set-alist 'mime-viewer/content-filter-alist 210 (set-alist 'mime-viewer/content-filter-alist
271 "application/postscript" 211 "application/postscript"
272 (function mime-preview/filter-for-application/postscript)) 212 (function mime-preview/filter-for-application/postscript))
273 213
274 214 (if (featurep 'gif)
275 ;;; @ setting 215 (add-to-list 'mime-viewer/default-showing-Content-Type-list
276 ;;; 216 "application/postscript")
277 217 )
278 (mapcar
279 (lambda (ctype)
280 (or (member ctype mime-viewer/default-showing-Content-Type-list)
281 (setq mime-viewer/default-showing-Content-Type-list
282 (cons ctype
283 mime-viewer/default-showing-Content-Type-list))
284 ))
285 tm-image/inline-image-types)
286 218
287 219
288 ;;; @ end 220 ;;; @ end
289 ;;; 221 ;;;
290 222