diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 82bee0c632..64f9edbd51 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -27,13 +27,6 @@ (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 @@ -59,15 +52,11 @@ _bytes _int -> _void)) -(define-gtk gtk_clipboard_wait_for_contents (_fun _GtkClipboard _GdkAtom -> (_or-null _GtkSelectionData))) (define-gtk gtk_selection_data_free (_fun _GtkSelectionData -> _void)) (define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int) #: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 -> _freed-string)) -(define-gtk gtk_clipboard_wait_for_image (_fun _GtkClipboard -> _GdkPixbuf) - #:wrap (allocator gobject-unref)) (define-cstruct _GtkTargetEntry ([target _pointer] [flags _uint] @@ -88,6 +77,59 @@ (define the-x-selection-driver #f) +;; ---------------------------------------- + +(define _request-fun (_fun #:atomic? #t _GtkClipboard (_or-null _GtkSelectionData) _pointer -> _void)) +(define _request-string-fun (_fun #:atomic? #t _GtkClipboard _string _pointer -> _void)) +(define _request-image-fun (_fun #:atomic? #t _GtkClipboard _GdkPixbuf _pointer -> _void)) + +(define (handle-receipt backref data convert) + (let ([l (ptr-ref backref _racket)]) + (free-immobile-cell backref) + (set-box! (car l) (and data (convert data))) + (semaphore-post (cdr l)))) + +(define (make-request-backref) + (let ([l (cons (box #f) (make-semaphore))]) + (values l (malloc-immobile-cell l)))) + +(define (wait-request-backref l) + (semaphore-wait (cdr l)) + (unbox (car l))) + +(define (request-received cb data backref) + (handle-receipt backref + data + (lambda (v) + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data v) + (gtk_selection_data_get_length v) + 1)]) + bstr)))) + +(define (string-request-received cb str backref) + (handle-receipt backref + str + (lambda (str) str))) + +(define (image-request-received cb pix backref) + (handle-receipt backref + pix + pixbuf->bitmap)) + +(define request_received (function-ptr request-received _request-fun)) +(define string_request_received (function-ptr string-request-received _request-string-fun)) +(define image_request_received (function-ptr image-request-received _request-image-fun)) + +(define-gtk gtk_clipboard_request_contents + (_fun _GtkClipboard _GdkAtom (_fpointer = request_received) _pointer -> _void)) +(define-gtk gtk_clipboard_request_text + (_fun _GtkClipboard (_fpointer = string_request_received) _pointer -> _void)) +(define-gtk gtk_clipboard_request_image + (_fun _GtkClipboard (_fpointer = image_request_received) _pointer -> _void)) + +;; ---------------------------------------- + (defclass clipboard-driver% object% (init-field [x-selection? #f]) @@ -195,29 +237,30 @@ bstr (bytes-length bstr)))) - (define/public (get-data format) - (let ([process (lambda (v) - (and v - (let ([bstr (scheme_make_sized_byte_string - (gtk_selection_data_get_data v) - (gtk_selection_data_get_length v) - 1)]) - (gtk_selection_data_free v) - bstr)))] - [format (if (equal? format "TEXT") - "UTF8_STRING" - format)]) - (process (gtk_clipboard_wait_for_contents cb (gdk_atom_intern format #t))))) + (define/public (get-data data-format) + (let* ([data-format (if (equal? data-format "TEXT") + "UTF8_STRING" + data-format)] + [atom (gdk_atom_intern data-format #t)]) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_contents cb atom backref) + l))))) (define/public (get-text-data) - (or (gtk_clipboard_wait_for_text cb) "")) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_text cb backref) + l)))) (define/public (get-bitmap-data) - (let ([pixbuf (gtk_clipboard_wait_for_image cb)]) - (and pixbuf - (begin0 - (pixbuf->bitmap pixbuf) - (gobject-unref pixbuf))))) + (wait-request-backref + (atomically + (let-values ([(l backref) (make-request-backref)]) + (gtk_clipboard_request_image cb backref) + l)))) (super-new))