diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 06f01340..142e2402 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -7,6 +7,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/freeze.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") @@ -16,11 +17,12 @@ has-x-selection? _GtkSelectionData gtk_selection_data_get_length - gtk_selection_data_get_data)) + gtk_selection_data_get_data + primary-atom + get-selection-eventspace)) (define (has-x-selection?) #t) -(define _GdkAtom _int) (define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) @@ -81,63 +83,71 @@ (define clear_owner (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) +(define primary-atom (gdk_atom_intern "PRIMARY" #t)) +(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t)) + +(define the-x-selection-driver #f) (defclass clipboard-driver% object% (init-field [x-selection? #f]) + (when x-selection? + (set! the-x-selection-driver this)) + (define client #f) (define client-data #f) + (define client-types #f) + (define client-orig-types #f) (define cb (gtk_clipboard_get (if x-selection? - (gdk_atom_intern "CLIPBOARD" #t) - (gdk_atom_intern "PRIMARY" #t)))) + primary-atom + clipboard-atom))) (define self-box #f) (define/public (get-client) client) - (define/public (set-client c types) - (if x-selection? - ;; For now, we can't call it on demand, so we don't call at all: - (queue-event (send c get-client-eventspace) - (lambda () - (send c on-replaced))) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: - (let ([all-data (for/list ([t (in-list types)]) - (send c get-data t))] - [types (for/list ([t (in-list 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) - - (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))) + (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? + #f + (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))) - (free target-strings))))) + (free target-strings)))) (define/public (replaced s-box) ;; Called in Gtk event-dispatch thread --- atomically with respect @@ -148,19 +158,27 @@ (when c (set! client #f) (set! client-data #f) + (set! client-types #f) + (set! client-orig-types #f) (queue-event (send c get-client-eventspace) (lambda () (send c on-replaced)))))) (free-immobile-cell s-box)) (define/public (provide-data i sel-data) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode; if it's the selection (not clipboard), + ;; then hopefully we're in the right eventspace (let ([bstr (if client - (list-ref client-data i) + (if client-data + (list-ref client-data i) + (constrained-reply (send client get-client-eventspace) + (lambda () + (send client get-data + (list-ref client-orig-types i))) + #"")) #"")]) (gtk_selection_data_set sel-data - (gdk_atom_intern "UTF8_STRING" #t) + (gdk_atom_intern (list-ref client-types i) #t) 8 bstr (bytes-length bstr)))) @@ -190,3 +208,9 @@ (gobject-unref pixbuf))))) (super-new)) + +(define (get-selection-eventspace) + (and the-x-selection-driver + (let ([c (send the-x-selection-driver get-client)]) + (and c + (send c get-client-eventspace))))) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 80855f65..fb371bf3 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -6,6 +6,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" + "clipboard.rkt" "const.rkt" "w32.rkt" "unique.rkt") @@ -163,11 +164,19 @@ (let* ([gtk (gtk_get_event_widget evt)] [wx (and gtk (widget-hook gtk))]) (cond - [(and (= (ptr-ref evt _int) GDK_EXPOSE) + [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE) wx (send wx direct-update?)) (gtk_main_do_event evt)] - [(and wx (send wx get-eventspace)) + [(or + ;; event for a window that we control? + (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))) => (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 0274dc50..0fb02212 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,6 +8,8 @@ _GdkScreen _gpointer _GType + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -27,6 +29,8 @@ (struct-out GdkEventConfigure) _GdkEventExpose _GdkEventExpose-pointer (struct-out GdkEventExpose) + _GdkEventSelection _GdkEventSelection-pointer + (struct-out GdkEventSelection) (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -50,6 +54,8 @@ (define _gfloat _float) (define _GdkEventType _int) +(define _GdkAtom _int) + (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] [send_event _byte] @@ -123,6 +129,15 @@ [width _int] [height _int])) +(define-cstruct _GdkEventSelection ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) + (define-cstruct _GdkRectangle ([x _int] [y _int] [width _int] diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 050bfa9c..be32c886 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -49,12 +49,7 @@ (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) (define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) (define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) -(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") -(define outline-nonowner-brush (let ([b (new brush%)]) - (send b set-color "BLACK") - (send b set-stipple (make-object bitmap% xpattern 16 16)) - (send b set-style 'xor) - b)) +(define outline-nonowner-brush outline-brush) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -5257,9 +5252,10 @@ hilite-some? hsxs hsxe hsys hsye old-style)))))))))) (let*-values ([(draw-first?) - (or (not (showcaret>= show-caret 'show-caret)) - (and s-caret-snip (not (pair? show-caret))) - (not hilite-on?) + (or (and (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?)) + (not show-xsel?)) (= -startpos -endpos) (-endpos . < . pcounter) (-startpos . > . (+ pcounter (mline-len line))))]