Mercurial > hg > xemacs-beta

comparison lisp/w3/images.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; images.el,v --- Automatic image converters
2 ;; Author: wmperry
3 ;; Created: 1996/05/26 01:17:31
4 ;; Version: 1.14
5 ;; Keywords: images
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;; The emacsen compatibility package - load it up before anything else
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 (eval-and-compile
31 (load-library "w3-sysdp"))
32
33 (defvar image-temp-stack nil "Do no touch - internal storage.")
34 (defvar image-converters nil "Storage for the image converters.")
35 (defvar image-native-formats
36 (delq nil (cons (if (featurep 'x) 'xbm)
37 (mapcar (function (lambda (x) (if (featurep x) x)))
38 '(xpm gif jpeg tiff png))))
39 "A list of image formats that this version of emacs supports natively.")
40
41 (defun image-register-converter (from to converter)
42 "Register the image converter for FROM to TO. CONVERTER is the actual
43 command used to convert the image. If this is a string, it will be executed
44 in a subprocess. If a symbol, it is assumed to be a function. It will be
45 called with two arguments, the start and end of the data to be converted.
46 The function should replace that data with the new image data. The return
47 value is not significant."
48 (let* ((node (assq from image-converters))
49 (replace (assq to (cdr-safe node))))
50 (cond
51 (replace ; Replace existing converter
52 (setcdr replace converter)
53 (display-warning 'image (format "Replacing image converter %s->%s"
54 from to)))
55 (node ; Add to existing node
56 (setcdr node (cons (cons to converter) (cdr node))))
57 (t ; New toplevel converter
58 (setq image-converters (cons (cons from (list (cons to converter)))
59 image-converters))))))
60
61 (defun image-unregister-converter (from to)
62 "Unregister the image converter for FROM to TO"
63 (let* ((node (assq from image-converters))
64 (tos (cdr-safe node))
65 (new nil))
66 (while tos
67 (if (eq to (car (car tos)))
68 nil
69 (setq new (cons (car tos) new)))
70 (setq tos (cdr tos)))
71 (setcdr node new)))
72
73 (defun image-converter-registered-p (from to)
74 (cdr-safe (assq to (cdr-safe (assq from image-converters)))))
75
76 (defun image-converter-chain (from to)
77 "Return the shortest converter chain for image format FROM to TO"
78 (setq image-temp-stack (cons from image-temp-stack))
79 (let ((converters (cdr-safe (assq from image-converters)))
80 (thisone nil)
81 (possibles nil)
82 (done nil))
83 (while (and (not done) converters)
84 (setq thisone (car converters))
85 (cond
86 ((eq (car thisone) to)
87 (setq done t))
88 ((memq (car thisone) image-temp-stack)
89 nil)
90 (t
91 (setq possibles (cons (image-converter-chain (car thisone) to)
92 possibles))))
93 (setq converters (cdr converters)))
94 (setq image-temp-stack (cdr image-temp-stack)
95 possibles (sort (delq nil possibles)
96 (function
97 (lambda (x y)
98 (< (length (delete 'ignore x))
99 (length (delete 'ignore y)))))))
100 (if (not done)
101 (setq done (car possibles)))
102 (cond
103 ((eq done t) (list (cdr thisone)))
104 (done (setq done (cons (cdr thisone) done)))
105 (t nil))))
106
107 (defun image-normalize (format data)
108 "Return an image specification for XEmacs 19.13 and later. FORMAT specifies
109 the image format, DATA is the image data as a string. Any conversions to get
110 to a suitable internal image format will be carried out."
111 (setq image-temp-stack nil)
112 (if (stringp format) (setq format (intern format)))
113 (if (not (memq format image-native-formats))
114 (let* ((winner (car-safe
115 (sort (mapcar
116 (function
117 (lambda (x)
118 (cons x
119 (delete 'ignore
120 (image-converter-chain format
121 x)))))
122 image-native-formats)
123 (function
124 (lambda (x y)
125 (cond
126 ((null (cdr x)) nil)
127 ((= (length (cdr x))
128 (length (cdr y)))
129 (< (length (memq (car x)
130 image-native-formats))
131 (length (memq (car y)
132 image-native-formats))))
133 (t
134 (< (length (cdr x))
135 (length (cdr y))))))))))
136 (type (car-safe winner))
137 (chain (cdr-safe winner))
138 )
139 (if chain
140 (save-excursion
141 (set-buffer (generate-new-buffer " *image-conversion*"))
142 (erase-buffer)
143 (insert data)
144 (while chain
145 (cond
146 ((stringp (car chain))
147 (shell-command-on-region (point-min) (point-max)
148 (concat
149 "/bin/sh -c '"
150 (car chain)
151 " 2> /dev/null"
152 "'") t))
153 ((and (symbolp (car chain)) (fboundp (car chain)))
154 (funcall (car chain) (point-min) (point-max))))
155 (setq chain (cdr chain)))
156 (setq data (buffer-string))
157 (kill-buffer (current-buffer)))
158 (setq type format))
159 (vector type ':data data))
160 (vector format ':data data)))
161
162 (defun image-register-netpbm-utilities ()
163 "Register all the netpbm utility packages converters."
164 (interactive)
165 (if (image-converter-registered-p 'xpm 'gif)
166 nil
167 (image-register-converter 'pgm 'pbm "pgmtopbm")
168 (image-register-converter 'ppm 'pgm "ppmtopgm")
169 (image-register-converter 'pnm 'xpm "(ppmquant 256 | ppmtoxpm)")
170 (image-register-converter 'ppm 'xpm "(ppmquant 256 | ppmtoxpm)")
171 (image-register-converter 'xpm 'ppm "xpmtoppm")
172 (image-register-converter 'gif 'ppm "giftopnm")
173 (image-register-converter 'pnm 'gif "(ppmquant 256 | ppmtogif)")
174 (image-register-converter 'ppm 'gif "(ppmquant 256 | ppmtogif)")
175 (image-register-converter 'bmp 'ppm "bmptoppm")
176 (image-register-converter 'ppm 'bmp "ppmtobmp")
177 (image-register-converter 'ppm 'ps "pnmtops")
178 (image-register-converter 'pnm 'ps "pnmtops")
179 (image-register-converter 'ps 'pnm "pstopnm")
180 (image-register-converter 'g3 'pbm "g3topbm")
181 (image-register-converter 'macpt 'pbm "macptopbm")
182 (image-register-converter 'pbm 'macpt "pbmtomacp")
183 (image-register-converter 'pcx 'ppm "pcxtoppm")
184 (image-register-converter 'ppm 'pcx "ppmtopcx")
185 (image-register-converter 'pict 'ppm "picttoppm")
186 (image-register-converter 'ppm 'pict "ppmtopict")
187 (image-register-converter 'pnm 'sgi "pnmtosgi")
188 (image-register-converter 'tga 'ppm "tgatoppm")
189 (image-register-converter 'ppm 'tga "ppmtotga")
190 (image-register-converter 'sgi 'pnm "sgitopnm")
191 (image-register-converter 'tiff 'pnm "tifftopnm")
192 (image-register-converter 'pnm 'tiff "pnmtotiff")
193 (image-register-converter 'xbm 'pbm "xbmtopbm")
194 (image-register-converter 'pbm 'xbm "pbmtoxbm")
195 (image-register-converter 'png 'pnm "pngtopnm")
196 (image-register-converter 'pnm 'png "pnmtopng")
197 (image-register-converter 'pnm 'jbg "pbmtojbg")
198 (image-register-converter 'jbg 'pnm "jbgtopbm")
199 (image-register-converter 'jpeg 'ppm "djpeg")))
200
201 (provide 'images)