1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
23 ;; $Id: pixbuf.lisp,v 1.9 2008-12-10 03:01:34 espen Exp $
28 (defbinding %pixbuf-new () pointer
35 (defbinding %pixbuf-new-from-data () pointer
46 (defbinding %pixbuf-new-from-xpm-data () pointer
47 (data (vector string)))
49 (defbinding %pixbuf-new-from-file () pointer
51 (nil (or null gerror) :out))
53 (defbinding %pixbuf-new-from-file-at-size () pointer
57 (nil (or null gerror) :out))
59 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
60 (defbinding %pixbuf-new-from-file-at-scale () pointer
64 (preserve-aspect-ratio boolean)
65 (nil (or null gerror) :out))
67 (defun %pixbuf-load (filename width height preserve-aspect-p)
68 (multiple-value-bind (location gerror)
71 (%pixbuf-new-from-file-at-size filename width height))
73 #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
74 (error "Both :width and :height must be specified")
75 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
76 (%pixbuf-new-from-file-at-scale filename
77 (or width -1) (or height -1) preserve-aspect-p))
78 (t (%pixbuf-new-from-file filename)))
80 (signal-gerror gerror)
83 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.14.0")
85 (defbinding %pixbuf-new-from-stream () pointer
86 gio:input-stream-designator
87 (nil (or null gio:cancellable))
88 (nil (or null gerror) :out))
90 (defbinding %pixbuf-new-from-stream-at-scale () pointer
91 gio:input-stream-designator
94 (preserve-aspect-ratio boolean)
95 (nil (or null gio:cancellable))
96 (nil (or null gerror) :out))
98 (defun %load-from-stream (stream width height preserve-aspect-p)
99 (multiple-value-bind (location gerror)
102 (%pixbuf-new-from-stream-at-scale stream
103 (or width -1) (or height -1) preserve-aspect-p))
104 (t (%pixbuf-new-from-stream stream)))
106 (signal-gerror gerror)
109 (defmethod allocate-foreign ((pixbuf pixbuf) &key source (bits-per-sample 8)
110 (colorspace :rgb) (has-alpha t) width height
111 (preserve-aspect-ratio t) destroy stride)
114 (%pixbuf-new colorspace has-alpha bits-per-sample width height))
115 ((typep source 'pointer)
117 (%pixbuf-new-from-data source colorspace has-alpha bits-per-sample width height (or stride (* width (if has-alpha 4 3)))))
118 ((and (vectorp source) (stringp (aref source 0)))
119 (%pixbuf-new-from-xpm-data source))
120 ((typep source 'vector)
123 ((or (pathnamep source) (stringp source))
124 #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
125 (unless preserve-aspect-ratio
126 (warn ":preserve-aspect-ratio not supported with this version of Gtk"))
127 (%pixbuf-load source width height preserve-aspect-ratio))
128 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.14.0")
129 ((typep source 'gio:input-stream-designator)
130 (%load-from-stream source width height preserve-aspect-ratio))
131 ((call-next-method))))
134 (defbinding (pixbuf-subpixbuf "gdk_pixbuf_new_subpixbuf") ()
135 (or null (referenced pixbuf))
136 pixbuf (src-x int) (src-y int) (width int) (height int))
138 (defbinding pixbuf-copy () (or null (referenced pixbuf))
142 (defbinding pixbuf-get-option () (copy-of string)
146 (defun pixbuf-load (filename &key width height size (preserve-aspect-ratio t))
147 (make-instance 'pixbuf :source filename
148 :width (or size width) :height (or size height)
149 :preserve-aspect-ratio preserve-aspect-ratio))
152 ;; (defbinding pixbuf-get-file-info () (copy-of pixbuf-format)
153 ;; (filename pathname)
155 ;; (height int :out))
157 (defbinding %pixbuf-savev () boolean
163 (nil (or null gerror) :out))
165 (defun %pixbuf-save-options (options)
166 (let ((keys (make-array 0 :adjustable t :fill-pointer t))
167 (values (make-array 0 :adjustable t :fill-pointer t)))
169 for (key value) on options by #'cddr
170 do (vector-push-extend (string-downcase key) keys)
174 (symbol (string-downcase value))
175 (number (format nil "~A" value)))
177 (values keys values)))
179 (defgeneric pixbuf-save (pixbuf dest type &rest options))
181 (defmethod pixbuf-save (pixbuf (filename string) type &rest options)
182 (multiple-value-bind (ok-p gerror)
183 (multiple-value-call #'%pixbuf-savev
184 pixbuf filename (string-downcase type)
185 (%pixbuf-save-options options))
187 (signal-gerror gerror))))
189 (defmethod pixbuf-save (pixbuf (pathname pathname) type &rest options)
190 (apply #'pixbuf-save pixbuf (namestring (translate-logical-pathname pathname))
193 (define-callback stream-write-func boolean
194 ((data pointer) (length gsize) (gerror pointer) (stream-id pointer-data))
197 (let ((stream (find-user-data stream-id)))
199 (map-c-vector 'vector 'identity data '(unsigned-byte 8) length)
201 (serious-condition (condition)
202 (gerror-set-in-callback gerror (file-error-domain)
203 (enum-int :failed 'file-error-enum) (princ-to-string condition))
204 (return-from stream-write nil)))
207 (defbinding %pixbuf-save-to-callbackv (pixbuf stream type keys values) boolean
209 (stream-write-func callback)
210 (stream pointer-data)
214 (nil (or null gerror) :out))
216 (defmethod pixbuf-save (pixbuf (stream stream) type &rest options)
217 (let ((stream-id (register-user-data stream)))
219 (multiple-value-bind (ok-p gerror)
220 (multiple-value-call #'%pixbuf-save-to-callbackv
221 pixbuf stream-id (string-downcase type)
222 (%pixbuf-save-options options))
224 (signal-gerror gerror)))
225 (destroy-user-data stream-id))))
228 ;; (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
229 ;; (data (vector string)))
231 (defbinding %pixbuf-new-subpixbuf () pixbuf ;; or (referenced pixbuf)?
233 (x int) (y int) (width int) (height int))
235 (defbinding %pixbuf-copy () (referenced pixbuf)
238 (defun copy-pixbuf (pixbuf &optional x y width height)
239 (if (and (not x) (not y) (not width) (not height))
240 (%pixbuf-copy pixbuf)
241 (%pixbuf-new-subpixbuf pixbuf x y width height)))
243 (defbinding %pixbuf-get-from-drawable () (or null (referenced pixbuf))
244 (dest (or null pixbuf))
246 (colormap (or null colormap))
254 (defun pixbuf-get-from-drawable (drawable &key (src-x 0) (src-y 0) (dest-x 0) (dest-y 0) width height colormap dest)
255 (unless (or (and width height) (not (typep drawable 'window)))
256 (error "Width and height must be specified for windows"))
258 (%pixbuf-get-from-drawable dest drawable
261 ((slot-boundp drawable 'colormap) nil)
262 ((colormap-get-system)))
263 src-x src-y dest-x dest-y (or width -1) (or height -1))
264 (error "Couldn't get pixbuf from drawable")))
269 (defbinding %pixbuf-loader-new-with-type () pointer
271 (nil gerror-signal :out))
273 (defbinding %pixbuf-loader-new-with-mime-type () pointer
275 (nil gerror-signal :out))
277 (defmethod allocate-foreign ((loader pixbuf-loader) &key type mime-type)
279 ((and type mime-type)
280 (error "Only one of the keyword arguments :TYPE and :MIME-TYPE can be specified"))
281 (type (%pixbuf-loader-new-with-type type))
282 (mime-type (%pixbuf-loader-new-with-mime-type mime-type))
283 ((call-next-method))))
285 (defbinding pixbuf-loader-write (loader buffer &optional (length (length buffer))) boolean
286 (loader pixbuf-loader)
287 (buffer (unboxed-vector (unsigned-byte 8)))
289 (nil gerror-signal :out))
291 (defbinding pixbuf-loader-close () boolean
292 (loader pixbuf-loader)
293 (nil gerror-signal :out))
295 (defbinding pixbuf-loader-get-pixbuf () (or null pixbuf)
296 (loader pixbuf-loader))
298 (defbinding pixbuf-loader-get-animation () (or null pixbuf-animation)
299 (loader pixbuf-loader))
301 (defbinding pixbuf-loader-set-size () nil
302 (loader pixbuf-loader)
309 (defbinding pixbuf-add-alpha
310 (pixbuf &optional substitute-color (red 255) (green 255) (blue 255))
313 (substitute-color boolean)
318 ;; The purpose of this function is to be able to share pixel data
319 ;; between GdkPixbufs and Cairo image surfaces.
321 (defun pixbuf-swap-rgb (pixbuf)
322 (assert (= (pixbuf-bits-per-sample pixbuf) 8))
323 (assert (= (pixbuf-n-channels pixbuf) 4))
324 (assert (pixbuf-has-alpha-p pixbuf))
325 (let ((pixels (pixbuf-pixels pixbuf))
326 (stride (pixbuf-rowstride pixbuf))
327 (n-channels (pixbuf-n-channels pixbuf)))
328 (loop for y from 0 below (pixbuf-height pixbuf) do
329 (let ((row-offset (* y stride)))
330 (loop for x from 0 below (pixbuf-width pixbuf) do
331 (let* ((offset (+ row-offset (* n-channels x)))
332 (p0 (ref-uint-8 pixels offset))
333 (p2 (ref-uint-8 pixels (+ offset 2))))
334 (setf (ref-uint-8 pixels offset) p2)
335 (setf (ref-uint-8 pixels (+ offset 2)) p0)))))))
337 (defbinding (pixbuf-swap-rgb "clg_gdk_pixbuf_swap_rgb") () nil