Implement gtk-window-get-clipboard-text.

diff --git a/src/gtk/Includes/gdk.cdecl b/src/gtk/Includes/gdk.cdecl
index eacd37a0f69683f4080c076d308e5df811c600cc..6a4e15b2e11a90f27e2aaf5ab20a1d0d520dc35f 100644 (file)
--- a/src/gtk/Includes/gdk.cdecl
+++ b/src/gtk/Includes/gdk.cdecl
@@ -17,4 +17,8 @@ gdk/gdk.h |#
 (extern void gdk_rectangle_union
        (src1 (* GdkRectangle))
        (src2 (* GdkRectangle))
-       (dest (* GdkRectangle)))
\ No newline at end of file
+       (dest (* GdkRectangle)))
+
+(extern GdkAtom gdk_atom_intern
+       (atom_name (* (const gchar)))
+       (only_if_exists gboolean))
\ No newline at end of file

diff --git a/src/gtk/Includes/gtk.cdecl b/src/gtk/Includes/gtk.cdecl
index 7fc290245294d28e3e4bffa3cc769d546d51aeae..be1d4c2e31649a5456af95a186e362aa503f5d20 100644 (file)
--- a/src/gtk/Includes/gtk.cdecl
+++ b/src/gtk/Includes/gtk.cdecl
@@ -4,6 +4,7 @@ gtk/gtk.h |#
 
 (include "gdk")
 (include "gtkadjustment")
+(include "gtkclipboard")
 (include "gtkcontainer")
 (include "gtkcssprovider")
 (include "gtkenums")

diff --git a/src/gtk/Includes/gtkclipboard.cdecl b/src/gtk/Includes/gtkclipboard.cdecl
new file mode 100644 (file)
index 0000000..072c60b
--- /dev/null
+++ b/src/gtk/Includes/gtkclipboard.cdecl
@@ -0,0 +1,28 @@
+#| -*-Scheme-*-
+
+gtk/gtkclipboard.h |#
+
+(callback void
+         receive_clipboard_text
+         (clipboard (* GtkClipboard))
+         (text (* (const gchar)))
+         (ID gpointer))
+
+(extern (* GtkClipboard)
+       gtk_clipboard_get_for_display
+       (display (* GdkDisplay))
+       (selection GdkAtom))
+
+(extern void
+       gtk_clipboard_set_text
+       (clipboard (* GtkClipboard))
+       (text (* (const gchar)))
+       (len gint))
+
+(extern void
+       gtk_clipboard_request_text
+       (clipboard (* GtkClipboard))
+       (CALLBACK GtkClipboardTextReceivedFunc)
+       (ID gpointer))
+
+(typedef GtkClipboardTextReceivedFunc (* mumble))
\ No newline at end of file

diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm
index 4f8c92f4e902b13952564f0a10cdd4f88d307734..e6d7763b2273fea6bd84d6400e2d5cc748c853f6 100644 (file)
--- a/src/gtk/gdk.scm
+++ b/src/gtk/gdk.scm
@@ -211,6 +211,102 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
      (%set-pixbuf-loader-close-hook! loader thunk)
      (if (pixbuf-loader-closed? loader)
         (thunk)))))
+\f
+;;; GdkDisplays
+
+(define-record-type <gdk-display>
+    (make-gdk-display alien atoms clipboard queue callback-idv)
+    gdk-display?
+  (alien gdk-display/alien)
+  (atoms gdk-display/atoms set-gdk-display/atoms!)
+  (clipboard gdk-display/clipboard set-gdk-display/clipboard!)
+  (queue gdk-display/queue)
+  (callback-idv gdk-display/callback-idv))
+
+(define displays (make-weak-eqv-hash-table))
+
+(define (get-gdk-display alien)
+  (let ((bignum (alien/address alien)))
+    (or (hash-table/get displays bignum #f)
+       (let ((alien (copy-alien alien))
+             (callback-idv (vector #f))
+             (queue (make-thread-queue 1)))
+         (let ((display (make-gdk-display alien '() #f queue callback-idv)))
+           (add-glib-cleanup display (make-gdk-display-cleanup callback-idv))
+           (hash-table/put! displays bignum display)
+           display)))))
+
+(define (make-gdk-display-cleanup callback-idv)
+  (named-lambda (gdk-display-cleanup)
+    (cleanup-callback callback-idv)))
+
+(define (cleanup-callback callback-idv)
+  (let ((id (vector-ref callback-idv 0)))
+    (if id
+       (begin
+         (de-register-c-callback id)
+         (vector-set! callback-idv 0 #f)))))
+
+(define (clipboard display)
+  (or (gdk-display/clipboard display)
+      (let ((atom (get-atom display '|CLIPBOARD|))
+           (gdkdisplay (gdk-display/alien display))
+           (clipboard (make-alien '|GtkClipboard|)))
+       (set-gdk-display/clipboard! display clipboard)
+       (C-call "gtk_clipboard_get_for_display" clipboard gdkdisplay atom)
+       clipboard)))
+
+(define (get-atom display symbol)
+  (let ((entry (assq symbol (gdk-display/atoms display))))
+    (if entry
+       (cdr entry)
+       (let ((atom (make-alien '(struct |_GdkAtom|))))
+         (C-call "gdk_atom_intern" atom (symbol-name symbol) 0)
+         (set-gdk-display/atoms! display
+                                 (cons (cons symbol atom)
+                                       (gdk-display/atoms display)))
+         atom))))
+
+(define (gdk-display-set-clipboard-text display string)
+  (%trace "; gdk-display-set-clipboard-text "display"\n")
+  (let ((string (string->utf8-string string)))
+    (C-call "gtk_clipboard_set_text"
+            (clipboard display)
+            string (string-length string))))
+
+(define (gdk-display-get-clipboard-text display msec)
+  (%trace "; gdk-display-get-clipboard-text "display" "msec"\n")
+  (if (vector-ref (gdk-display/callback-idv display) 0)
+      (error "Operation pending:" display))
+  (let ((queue (gdk-display/queue display))
+       (callback-idv (gdk-display/callback-idv display)))
+    (%trace "; gdk-display-get-clipboard-text registering\n")
+    (let ((callback-id (make-text-callback-id queue)))
+      (vector-set! callback-idv 0 callback-id)
+      (thread-queue/empty! queue)
+      (C-call "gtk_clipboard_request_text"
+             (clipboard display)
+             (C-callback "receive_clipboard_text")
+             callback-id)
+      (%trace "; gdk-display-get-clipboard-text waiting\n")
+      (let ((text (thread-queue/dequeue-no-hang! queue msec)))
+       (%trace "; gdk-display-get-clipboard-text finishing\n")
+       (cleanup-callback callback-idv)
+       (if (string? text)
+           text
+           (error "Operation failed:" display))))))
+
+(define (make-text-callback-id queue)
+  (C-callback
+   (named-lambda (gdk-display-get-clipboard-text-callback clipboard char*)
+     (declare (ignore clipboard))
+     (if (alien-null? char*)
+        (queue! queue #t)
+        (queue! queue (c-peek-cstring char*))))))
+
+(define (queue! queue value)
+  (thread-queue/queue! queue value)
+  (maybe-yield-glib))
 
 (define %trace? #f)
 

diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm
index 74054ef9f87b9338480f1f8f62b51304e66d5a28..fc38132215ed5f70300b8b4fea5726c81e1f3c8b 100644 (file)
--- a/src/gtk/gtk-widget.scm
+++ b/src/gtk/gtk-widget.scm
@@ -1030,6 +1030,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (declare (ignore GdkEvent))
     (callback window)))
 
+(define gtk-clipboard-timeout 5000)
+
+(define (gtk-window-get-clipboard-text window)
+  (guarantee-gtk-window window 'gtk-window-get-clipboard-text)
+  (let* ((gdkdisplay (C-call "gtk_widget_get_display"
+                            (make-alien '|GtkDisplay|)
+                            (gobject-alien window)))
+        (gdk-display (get-gdk-display gdkdisplay)))
+    (gdk-display-get-clipboard-text gdk-display gtk-clipboard-timeout)))
+
+(define (gtk-window-set-clipboard-text window string)
+  (guarantee-gtk-window window 'gtk-window-set-clipboard-text)
+  (let* ((gdkdisplay (C-call "gtk_widget_get_display"
+                           (make-alien '|GtkDisplay|)
+                           (gobject-alien window)))
+        (gdk-display (get-gdk-display gdkdisplay)))
+    (gdk-display-set-clipboard-text gdk-display string)))
+
 (define %trace? #f)
 
 (define-syntax %trace

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index d33f15950f2c60aba383ada6ec76b2e122cd8b52..1cf24f2180407ccc0de7b065777d468a63660be0 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -42,6 +42,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   ;;(depends-on "gtk-const.bin")
   (import (cairo)
          make-cairo-cleanup check-cairo-status)
+  (import (runtime ffi)
+         alien/address)
+  (import (glib main)
+         maybe-yield-glib)
   (export (gtk)
          gdk-cairo-create
          gdk-window-process-updates
@@ -116,6 +120,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
          gtk-window-resize
          gtk-window-present
          set-gtk-window-delete-event-callback!
+         gtk-clipboard-timeout
+         gtk-window-get-clipboard-text
+         gtk-window-set-clipboard-text
          <gtk-label> gtk-label? guarantee-gtk-label
          gtk-label-new
          gtk-label-get-text gtk-label-set-text
@@ -146,7 +153,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
          gtk-paned-get-position gtk-paned-set-position
          <gtk-paned-view> gtk-paned-view? gtk-paned-view-new)
   (import (pango) make-pango-layout guarantee-pango-font-description)
-  (import (gio) gfile?))
+  (import (gio) gfile?)
+  (import (gtk gdk)
+         get-gdk-display
+         gdk-display-get-clipboard-text
+         gdk-display-set-clipboard-text))
 
 (define-package (gtk widget)
   (parent (gtk))