From 207b051df4c87006f5adedabba3dbfab26859b04 Mon Sep 17 00:00:00 2001 From: Ryan Pavlik Date: Mon, 29 Aug 2011 09:25:34 -0500 Subject: [PATCH] Fixup for selection-data where format=32. X specification is odd. Added basic, ugly convenience function for cairo->pixbuf conversion, so cursors can be drawn on a cairo image surface. gtk-drag-dest-set now passes (null-pointer) if targets is nil; this invokes a special case in gtk where all dragging can be handled by the client. Conflicts: cairo/cairo.lisp gdk/gdk.pixbufs.lisp --- cairo/cairo.lisp | 29 +++++++++++++++++++++++++++++ cairo/cairo.package.lisp | 3 ++- gdk/gdk.pixbufs.lisp | 7 +++++++ gtk/gtk.dnd.lisp | 6 ++++-- gtk/gtk.selections.lisp | 18 +++++++++--------- 5 files changed, 51 insertions(+), 12 deletions(-) diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp index 41b9b0f..01bfaf3 100644 --- a/cairo/cairo.lisp +++ b/cairo/cairo.lisp @@ -62,3 +62,32 @@ to the expose event handler." (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))) + diff --git a/cairo/cairo.package.lisp b/cairo/cairo.package.lisp index 9e4073a..b60db94 100644 --- a/cairo/cairo.package.lisp +++ b/cairo/cairo.package.lisp @@ -6,4 +6,5 @@ #: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)) diff --git a/gdk/gdk.pixbufs.lisp b/gdk/gdk.pixbufs.lisp index 1908e96..1e25b7a 100644 --- a/gdk/gdk.pixbufs.lisp +++ b/gdk/gdk.pixbufs.lisp @@ -107,6 +107,13 @@ (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) diff --git a/gtk/gtk.dnd.lisp b/gtk/gtk.dnd.lisp index c52cb3e..baf433f 100644 --- a/gtk/gtk.dnd.lisp +++ b/gtk/gtk.dnd.lisp @@ -32,8 +32,10 @@ (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) diff --git a/gtk/gtk.selections.lisp b/gtk/gtk.selections.lisp index 0d8ac75..d5c0ab4 100644 --- a/gtk/gtk.selections.lisp +++ b/gtk/gtk.selections.lisp @@ -116,24 +116,24 @@ (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))) -- 1.7.10.4