suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gtk: fix clipboard; implement ye olde X selection

Browse Source 
original commit: 82ab45b11d3f890d4830248feb95f38dcfe98c56
This commit is contained in:
Matthew Flatt 2010-12-01 20:48:23 -07:00
parent 1ed409f26c
commit f4d458d0fd
4 changed files with 104 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
collects/mred/private/wx/gtk/clipboard.rkt
View File

@ -7,6 +7,7 @@
"../../lock.rkt" "../../lock.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"../common/local.rkt" "../common/local.rkt"
"../common/freeze.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"pixbuf.rkt") "pixbuf.rkt")
@ -16,11 +17,12 @@
has-x-selection? has-x-selection?
_GtkSelectionData _GtkSelectionData
gtk_selection_data_get_length 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 (has-x-selection?) #t)
(define _GdkAtom _int)
(define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkClipboard (_cpointer 'GtkClipboard))
(define _GtkDisplay _pointer) (define _GtkDisplay _pointer)
(define _GtkSelectionData (_cpointer 'GtkSelectionData)) (define _GtkSelectionData (_cpointer 'GtkSelectionData))
@ -81,63 +83,71 @@
(define clear_owner (define clear_owner
(function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) (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% (defclass clipboard-driver% object%
(init-field [x-selection? #f]) (init-field [x-selection? #f])
(when x-selection?
(set! the-x-selection-driver this))
(define client #f) (define client #f)
(define client-data #f) (define client-data #f)
(define client-types #f)
(define client-orig-types #f)
(define cb (gtk_clipboard_get (define cb (gtk_clipboard_get
(if x-selection? (if x-selection?
(gdk_atom_intern "CLIPBOARD" #t) primary-atom
(gdk_atom_intern "PRIMARY" #t)))) clipboard-atom)))
(define self-box #f) (define self-box #f)
(define/public (get-client) client) (define/public (get-client) client)
(define/public (set-client c types) (define/public (set-client c orig-types)
(if x-selection? ;; In clipboard mode (as opposed to X selection), we can get the data
;; For now, we can't call it on demand, so we don't call at all: ;; now, so it's ready if anyone asks:
(queue-event (send c get-client-eventspace) (let ([all-data (if x-selection?
(lambda () #f
(send c on-replaced))) (for/list ([t (in-list orig-types)])
;; In clipboard mode (as opposed to X selection), we can get the data (send c get-data t)))]
;; now, so it's ready if anyone asks: [types (for/list ([t (in-list orig-types)])
(let ([all-data (for/list ([t (in-list types)]) (if (equal? t "TEXT")
(send c get-data t))] "UTF8_STRING"
[types (for/list ([t (in-list types)]) t))])
(if (equal? t "TEXT") (let ([target-strings (malloc 'raw _byte (+ (length types)
"UTF8_STRING" (apply + (map string-utf-8-length types))))]
t))]) [targets (malloc _GtkTargetEntry (length types))])
(let ([target-strings (malloc 'raw _byte (+ (length types) (for/fold ([offset 0]) ([str (in-list types)]
(apply + (map string-utf-8-length types))))] [i (in-naturals)])
[targets (malloc _GtkTargetEntry (length types))]) (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)])
(for/fold ([offset 0]) ([str (in-list types)] (set-GtkTargetEntry-target! t (ptr-add target-strings offset))
[i (in-naturals)]) (set-GtkTargetEntry-flags! t 0)
(let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) (set-GtkTargetEntry-info! t i))
(set-GtkTargetEntry-target! t (ptr-add target-strings offset)) (let ([bstr (string->bytes/utf-8 str)])
(set-GtkTargetEntry-flags! t 0) (memcpy target-strings offset bstr 0 (bytes-length bstr))
(set-GtkTargetEntry-info! t i)) (let ([offset (+ offset (bytes-length bstr))])
(let ([bstr (string->bytes/utf-8 str)]) (ptr-set! (ptr-add target-strings offset) _byte 0)
(memcpy target-strings offset bstr 0 (bytes-length bstr)) (+ offset 1))))
(let ([offset (+ offset (bytes-length bstr))]) (set! client c)
(ptr-set! (ptr-add target-strings offset) _byte 0) (set! client-data all-data)
(+ offset 1)))) (set! client-types types)
(set! client c) (set! client-orig-types orig-types)
(set! client-data all-data)
(atomically (atomically
(let ([this-box (malloc-immobile-cell this)]) (let ([this-box (malloc-immobile-cell this)])
(set! self-box this-box) (set! self-box this-box)
(gtk_clipboard_set_with_data cb (gtk_clipboard_set_with_data cb
targets targets
(length types) (length types)
get_data get_data
clear_owner clear_owner
this-box))) this-box)))
(free target-strings))))) (free target-strings))))
(define/public (replaced s-box) (define/public (replaced s-box)
;; Called in Gtk event-dispatch thread --- atomically with respect ;; Called in Gtk event-dispatch thread --- atomically with respect
@ -148,19 +158,27 @@
(when c (when c
(set! client #f) (set! client #f)
(set! client-data #f) (set! client-data #f)
(set! client-types #f)
(set! client-orig-types #f)
(queue-event (send c get-client-eventspace) (queue-event (send c get-client-eventspace)
(lambda () (lambda ()
(send c on-replaced)))))) (send c on-replaced))))))
(free-immobile-cell s-box)) (free-immobile-cell s-box))
(define/public (provide-data i sel-data) (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 (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 (gtk_selection_data_set sel-data
(gdk_atom_intern "UTF8_STRING" #t) (gdk_atom_intern (list-ref client-types i) #t)
8 8
bstr bstr
(bytes-length bstr)))) (bytes-length bstr))))
@ -190,3 +208,9 @@
(gobject-unref pixbuf))))) (gobject-unref pixbuf)))))
(super-new)) (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)))))

13
collects/mred/private/wx/gtk/queue.rkt
View File

@ -6,6 +6,7 @@
"../../lock.rkt" "../../lock.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"../common/freeze.rkt" "../common/freeze.rkt"
"clipboard.rkt"
"const.rkt" "const.rkt"
"w32.rkt" "w32.rkt"
"unique.rkt") "unique.rkt")
@ -163,11 +164,19 @@
(let* ([gtk (gtk_get_event_widget evt)] (let* ([gtk (gtk_get_event_widget evt)]
[wx (and gtk (widget-hook gtk))]) [wx (and gtk (widget-hook gtk))])
(cond (cond
[(and (= (ptr-ref evt _int) GDK_EXPOSE) [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE)
wx wx
(send wx direct-update?)) (send wx direct-update?))
(gtk_main_do_event evt)] (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) => (lambda (e)
(let ([evt (gdk_event_copy evt)]) (let ([evt (gdk_event_copy evt)])
(queue-event e (lambda () (queue-event e (lambda ()

15
collects/mred/private/wx/gtk/types.rkt
View File

@ -8,6 +8,8 @@
_GdkScreen _GdkScreen
_gpointer _gpointer
_GType _GType
_GdkEventType
_GdkAtom
_fnpointer _fnpointer
_gboolean _gboolean
@ -27,6 +29,8 @@
(struct-out GdkEventConfigure) (struct-out GdkEventConfigure)
_GdkEventExpose _GdkEventExpose-pointer _GdkEventExpose _GdkEventExpose-pointer
(struct-out GdkEventExpose) (struct-out GdkEventExpose)
_GdkEventSelection _GdkEventSelection-pointer
(struct-out GdkEventSelection)
(struct-out GdkRectangle) (struct-out GdkRectangle)
_GdkColor _GdkColor-pointer _GdkColor _GdkColor-pointer
(struct-out GdkColor))) (struct-out GdkColor)))
@ -50,6 +54,8 @@
(define _gfloat _float) (define _gfloat _float)
(define _GdkEventType _int) (define _GdkEventType _int)
(define _GdkAtom _int)
(define-cstruct _GdkEventButton ([type _GdkEventType] (define-cstruct _GdkEventButton ([type _GdkEventType]
[window _GdkWindow] [window _GdkWindow]
[send_event _byte] [send_event _byte]
@ -123,6 +129,15 @@
[width _int] [width _int]
[height _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] (define-cstruct _GdkRectangle ([x _int]
[y _int] [y _int]
[width _int] [width _int]

14
collects/mred/private/wxme/text.rkt
View File

@ -49,12 +49,7 @@
(define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) (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-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 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 clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
(define (showcaret>= a b) (define (showcaret>= a b)
@ -5257,9 +5252,10 @@
hilite-some? hsxs hsxe hsys hsye hilite-some? hsxs hsxe hsys hsye
old-style)))))))))) old-style))))))))))
(let*-values ([(draw-first?) (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))) (and s-caret-snip (not (pair? show-caret)))
(not hilite-on?) (not hilite-on?))
(not show-xsel?))
(= -startpos -endpos) (= -startpos -endpos)
(-endpos . < . pcounter) (-endpos . < . pcounter)
(-startpos . > . (+ pcounter (mline-len line))))] (-startpos . > . (+ pcounter (mline-len line))))]