gtk: fix clipboard; implement ye olde X selection

original commit: 82ab45b11d3f890d4830248feb95f38dcfe98c56

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,32 +83,38 @@
 (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)
+                  primary-atom
-                  (gdk_atom_intern "PRIMARY" #t))))
+		  clipboard-atom)))
   (define self-box #f)
 
   (define/public (get-client) client)
 
-  (define/public (set-client c types)
+  (define/public (set-client c orig-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)])
+    (let ([all-data (if x-selection?
-                          (send c get-data t))]
+			#f
-	      [types (for/list ([t (in-list types)])
+			(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))])
@@ -126,6 +134,8 @@
 		      (+ 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)])
@@ -137,7 +147,7 @@
 					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
+    ;; In atomic mode; if it's the selection (not clipboard),
-    ;; to any other thread
+    ;; then hopefully we're in the right eventspace
     (let ([bstr (if client
+		    (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)))))

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 () 

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]

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 outline-brush)
-(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 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))
+                                     (or (and (or (not (showcaret>= show-caret 'show-caret))
 						  (and s-caret-snip (not (pair? show-caret)))
-                                         (not hilite-on?)
+						  (not hilite-on?))
+					      (not show-xsel?))
                                          (= -startpos -endpos)
                                          (-endpos . < . pcounter)
                                          (-startpos . > . (+ pcounter (mline-len line))))]