gtk: image paste

original commit: ad9209f1e98f7569e5c6d3dcefe4f529d0dcec55

collects/mred/private/wx/gtk/clipboard.rkt

@@ -1,14 +1,15 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
-         scheme/foreign
+         ffi/unsafe
+         ffi/unsafe/alloc
          "../../syntax.rkt"
          "../../lock.rkt"
          "../common/queue.rkt"
          "../common/local.rkt"
          "../common/bstr.rkt"
           "utils.rkt"
-          "types.rkt")
+          "types.rkt"
-(unsafe!)
+          "pixbuf.rkt")
 
 (provide clipboard-driver%
          has-x-selection?
@@ -23,6 +24,13 @@
 (define _GtkDisplay _pointer)
 (define _GtkSelectionData (_cpointer 'GtkSelectionData))
 
+(define _freed-string (make-ctype _pointer 
+                                  (lambda (s) s)
+                                  (lambda (p)
+                                    (let ([s (cast p _pointer _string)])
+                                      (g_free p)
+                                      s))))
+
 ;; Recent versions of Gtk provide function calls to
 ;;  access data, but use structure when the functions are
 ;;  not available
@@ -54,7 +62,9 @@
   #:fail (lambda () GtkSelectionDataT-length))
 (define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer)
   #:fail (lambda () GtkSelectionDataT-data))
-(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _string))
+(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _freed-string))
+(define-gtk gtk_clipboard_wait_for_image (_fun _GtkClipboard -> _GdkPixbuf)
+  #:wrap (allocator gobject-unref))
 
 (define-cstruct _GtkTargetEntry ([target _pointer]
                                  [flags _uint]
@@ -172,7 +182,10 @@
     (or (gtk_clipboard_wait_for_text cb) ""))
 
   (define/public (get-bitmap-data)
-    #f)
+    (let ([pixbuf (gtk_clipboard_wait_for_image cb)])
+      (and pixbuf
+           (begin0
+            (pixbuf->bitmap pixbuf)
+            (gobject-unref pixbuf)))))
   
   (super-new))
-

collects/mred/private/wx/gtk/pixbuf.rkt

@@ -3,18 +3,22 @@
          ffi/unsafe
          ffi/unsafe/alloc
          racket/draw
+         racket/draw/local
+         racket/draw/cairo
          "../../lock.rkt"
          "../common/bstr.rkt"
          "utils.rkt"
          "types.rkt"
          (only-in '#%foreign ffi-callback))
 
-(provide _GdkPixbuf
+(provide bitmap->pixbuf
-         bitmap->pixbuf
+         pixbuf->bitmap
+         
+         _GdkPixbuf
          gtk_image_new_from_pixbuf
          release-pixbuf)
 
-(define _GdkPixbuf (_cpointer 'GdkPixbuf))
+(define _GdkPixbuf (_cpointer/null 'GdkPixbuf))
 
 (define release-pixbuf ((deallocator) g_object_unref))
 
@@ -31,6 +35,10 @@
 						  -> _GdkPixbuf)
   #:wrap (allocator release-pixbuf))
 
+(define-gdk gdk_cairo_set_source_pixbuf (_fun _cairo_t _GdkPixbuf _double* _double* -> _void))
+(define-gdk gdk_pixbuf_get_width (_fun _GdkPixbuf -> _int))
+(define-gdk gdk_pixbuf_get_height (_fun _GdkPixbuf -> _int))
+
 (define free-it (ffi-callback free
                               (list _pointer)
                               _void
@@ -59,3 +67,15 @@
                                  (* w 4)
                                  free-it
                                  #f)))))
+
+(define (pixbuf->bitmap pixbuf)
+  (let* ([w (gdk_pixbuf_get_width pixbuf)]
+         [h (gdk_pixbuf_get_height pixbuf)]
+         [bm (make-object bitmap% w h #f #t)]
+         [s (send bm get-cairo-surface)]
+         [cr (cairo_create s)])
+    (gdk_cairo_set_source_pixbuf cr pixbuf 0 0)
+    (cairo_rectangle cr 0 0 w h)
+    (cairo_fill cr)
+    (cairo_destroy cr)
+    bm))

collects/mred/private/wx/gtk/utils.rkt

@@ -28,6 +28,7 @@
          g_free
          _gpath/free
          _GSList
+         gfree
 
          g_object_set_data
          g_object_get_data
@@ -132,6 +133,7 @@
                                v)))))
 
 (define-glib g_free (_fun _pointer -> _void))
+(define gfree ((deallocator) g_free))
 
 (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
 (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))