diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 92c15665..7ee55836 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -40,9 +40,7 @@ ;; Ideally, this would count as an error that we can fix. It seems that we ;; don't always have enough control to use the right eventspace with a ;; retry point, though, so just bail out with the default. - #; - (internal-error (format "constrained-reply not within an unfreeze point for ~s" - thunk)) + #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 142e2402..82bee0c6 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -108,50 +108,62 @@ (define/public (get-client) client) (define/public (set-client c orig-types) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: (let ([all-data (if x-selection? + ;; In X selection mode, get the data on demand: #f + ;; In clipboard mode, we can get the data + ;; now, so it's ready if anyone asks: (for/list ([t (in-list orig-types)]) (send c get-data t)))] [types (for/list ([t (in-list orig-types)]) (if (equal? t "TEXT") "UTF8_STRING" t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - (set! client-types types) - (set! client-orig-types orig-types) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (let-values ([(orig-types types all-data) + ;; For "TEXT", provide "UTF8_STRING", "STRING", and "TEXT": + (if (member "TEXT" orig-types) + (values (append orig-types (list "TEXT" "TEXT")) + (append types (list "STRING" "TEXT")) + (and all-data (append all-data + (let loop ([all-data all-data] + [orig-types orig-types]) + (if (equal? "TEXT" (car orig-types)) + (list (car all-data) (car all-data)) + (loop (cdr all-data) (cdr orig-types))))))) + (values orig-types types all-data))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings)))) + (free target-strings))))) (define/public (replaced s-box) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode (when (ptr-equal? s-box self-box) (set! self-box #f) (let ([c client]) @@ -177,11 +189,11 @@ (list-ref client-orig-types i))) #"")) #"")]) - (gtk_selection_data_set sel-data - (gdk_atom_intern (list-ref client-types i) #t) - 8 - bstr - (bytes-length bstr)))) + (gtk_selection_data_set sel-data + (gdk_atom_intern (list-ref client-types i) #t) + 8 + bstr + (bytes-length bstr)))) (define/public (get-data format) (let ([process (lambda (v) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index fb371bf3..110e8932 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -173,10 +173,10 @@ (and wx (send wx get-eventspace)) ;; event to get X selection data? (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) - (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) - (= (GdkEventSelection-selection s) - primary-atom)) - (get-selection-eventspace))) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0fb02212..0dc4d8c1 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -54,7 +54,7 @@ (define _gfloat _float) (define _GdkEventType _int) -(define _GdkAtom _int) +(define _GdkAtom _long) (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow]