gtk: fix clipboard; implement ye olde X selection
original commit: 82ab45b11d3f890d4830248feb95f38dcfe98c56
This commit is contained in:
Matthew Flatt
parent
1ed409f26c
commit
f4d458d0fd
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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))))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user