From 81cba32fb5460c70d7218736c668b0fb19e08258 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 16 Jan 2017 11:13:31 -0700 Subject: [PATCH] Implement gtk-window-get-clipboard-text. --- src/gtk/Includes/gdk.cdecl | 6 +- src/gtk/Includes/gtk.cdecl | 1 + src/gtk/Includes/gtkclipboard.cdecl | 28 +++++++++ src/gtk/gdk.scm | 96 +++++++++++++++++++++++++++++ src/gtk/gtk-widget.scm | 18 ++++++ src/gtk/gtk.pkg | 13 +++- 6 files changed, 160 insertions(+), 2 deletions(-) create mode 100644 src/gtk/Includes/gtkclipboard.cdecl 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 + (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? 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-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)) -- 2.25.1