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

gtk: fix clipboard problems on 64-bit mode; provide more text formats

Browse Source 
original commit: 7a37b07e263a72ba40b7aed9c759a2ed84b4bb08
This commit is contained in:
Matthew Flatt 2010-12-02 06:16:51 -07:00
parent f4d458d0fd
commit 27c6805b43
4 changed files with 56 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/private/wx/common/freeze.rkt
View File

@ -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")

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

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

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

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

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

@ -54,7 +54,7 @@
(define _gfloat _float)
(define _GdkEventType _int)
(define _GdkAtom _int)
(define _GdkAtom _long)
(define-cstruct _GdkEventButton ([type _GdkEventType]
[window _GdkWindow]