From 207b051df4c87006f5adedabba3dbfab26859b04 Mon Sep 17 00:00:00 2001
From: Ryan Pavlik <rpavlik@gmail.com>
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