From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 16 Jan 2017 18:13:31 +0000 (-0700)
Subject: Implement gtk-window-get-clipboard-text.
X-Git-Tag: mit-scheme-pucked-9.2.12~244
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=81cba32fb5460c70d7218736c668b0fb19e08258;p=mit-scheme.git

Implement gtk-window-get-clipboard-text.
---

diff --git a/src/gtk/Includes/gdk.cdecl b/src/gtk/Includes/gdk.cdecl
index eacd37a0f..6a4e15b2e 100644
--- 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 7fc290245..be1d4c2e3 100644
--- 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
index 000000000..072c60b90
--- /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 4f8c92f4e..e6d7763b2 100644
--- 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)))))
+
+;;; 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 74054ef9f..fc3813221 100644
--- 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 d33f15950..1cf24f218 100644
--- 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))