(defun gdk-cairo-reset-clip (drawable &optional (context cl-cairo2:*context*))
(gdk_cairo_reset_clip (slot-value context 'cl-cairo2:pointer) drawable))
+
+;; This looks nearly as bad as it actually is. gdk_pixbuf only supports
+;; 32-bit pixels / 8 bits per channel, with RGB bytes in _reverse order_
+;; from cairo. Needs big-endian testing.
+(defun gdk-pixbuf-from-cairo-image (image)
+ (let ((width (cairo:image-surface-get-width image))
+ (height (cairo:image-surface-get-height image))
+ (src (cairo:image-surface-get-data image :pointer-only t))
+ (src-stride (cairo:image-surface-get-stride image))
+ (format (cairo:image-surface-get-format image)))
+ (unless (or (eq format :argb32) (eq format :rgb24))
+ (error "Unsupported format: ~A~%" format))
+ (let* ((pixbuf (gdk::gdk-pixbuf-new :rgb (eq format :argb32) 8
+ width height))
+ (dest-stride (gdk:pixbuf-rowstride pixbuf))
+ (dest (gdk:pixbuf-pixels pixbuf)))
+ (flet ((offset (x c y s) (+ (* x 4) c (* y s))))
+ (dotimes (y height)
+ (dotimes (x width)
+ (setf (mem-ref dest :uint8 (offset x 0 y dest-stride))
+ (mem-ref src :uint8 (offset x 2 y src-stride)))
+ (setf (mem-ref dest :uint8 (offset x 1 y dest-stride))
+ (mem-ref src :uint8 (offset x 1 y src-stride)))
+ (setf (mem-ref dest :uint8 (offset x 2 y dest-stride))
+ (mem-ref src :uint8 (offset x 0 y src-stride)))
+ (setf (mem-ref dest :uint8 (offset x 3 y dest-stride))
+ (mem-ref src :uint8 (offset x 3 y src-stride))))))
+ pixbuf)))
+
#:gdk-cairo-set-source-pixbuf
#:gdk-cairo-set-source-pixmap
#:gdk-cairo-region
- #:gdk-cairo-reset-clip))
+ #:gdk-cairo-reset-clip
+ #:gdk-pixbuf-from-cairo-image))
(export 'pixbuf-get-from-image)
+(defcfun gdk-pixbuf-new (g-object pixbuf :already-referenced)
+ (colorspace colorspace)
+ (has-alpha :boolean)
+ (bits-per-sample :int)
+ (width :int)
+ (height :int))
+
(defcfun gdk-pixbuf-scale-simple (g-object pixbuf :already-referenced)
(src (g-object pixbuf))
(dest-width :int)
(actions gdk-drag-action))
(defun drag-dest-set (widget flags targets actions)
- (with-foreign-boxed-array (n-targets targets-ptr target-entry targets)
- (gtk-drag-dest-set widget flags targets-ptr n-targets actions)))
+ (if (eq targets nil)
+ (gtk-drag-dest-set widget flags (null-pointer) 0 actions)
+ (with-foreign-boxed-array (n-targets targets-ptr target-entry targets)
+ (gtk-drag-dest-set widget flags targets-ptr n-targets actions))))
(export 'drag-dest-set)
(gtk-selection-data-set-pixbuf selection-data data))
(defun foreign-to-int-or-array (ptr fmt len)
- (let ((ctype (case fmt (8 :int8) (16 :int16) (32 :int32))))
- (if (= len 1)
+ (let ((ctype (case fmt (8 :int8) (16 :int16) (32 :long)))
+ (clen (/ len (if (= fmt 32) (foreign-type-size :long) fmt))))
+ (if (= clen 1)
(mem-ref ptr ctype)
- (let ((array (make-array len :element-type 'fixnum)))
- (loop for i from 0 below len
+ (let ((array (make-array clen :element-type 'fixnum)))
+ (loop for i from 0 below clen
do (setf (aref array i) (mem-aref ptr ctype)))
array))))
-;; As of writing, gtk is not 64-bit clean. This may not work as intended
-;; for fmt>8.
(defun selection-get (selection-data)
(let ((fmt (gtk-selection-data-get-format selection-data))
(len (gtk-selection-data-get-length selection-data))
(ptr (gtk-selection-data-get-data selection-data)))
(values
- (if (= fmt 8)
- (foreign-string-to-lisp ptr :count len)
- (foreign-to-int-or-array ptr fmt (/ len (/ fmt 8))))
+ (cond
+ ((= len -1) nil)
+ ((= fmt 8) (foreign-string-to-lisp ptr :count len))
+ (t (foreign-to-int-or-array ptr fmt len)))
(gtk-selection-data-get-data-type selection-data)
fmt)))