1 ! Copyright (C) 2006, 2007 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.strings alien.syntax arrays
4 kernel math namespaces sequences io.encodings.string
5 io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
8 ! This code was based on by McCLIM's Backends/CLX/port.lisp
9 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
11 : XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
13 : XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
15 TUPLE: x-clipboard atom contents ;
17 : <x-clipboard> ( atom -- clipboard )
20 : selection-property ( -- n )
21 "org.factorcode.Factor.SELECTION" x-atom ;
23 : convert-selection ( win selection -- )
24 swap >r >r dpy get r> XA_UTF8_STRING selection-property r>
25 CurrentTime XConvertSelection drop ;
27 : snarf-property ( prop-return -- string )
28 dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
30 : window-property ( win prop delete? -- string )
31 >r dpy get -rot 0 -1 r> AnyPropertyType
32 0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
33 [ XGetWindowProperty drop ] keep snarf-property ;
35 : selection-from-event ( event window -- string )
36 swap XSelectionEvent-property zero? [
39 selection-property 1 window-property utf8 decode
42 : own-selection ( prop win -- )
43 dpy get -rot CurrentTime XSetSelectionOwner drop
46 : set-targets-prop ( evt -- )
48 [ XSelectionRequestEvent-requestor ] keep
49 XSelectionRequestEvent-property
50 "TARGETS" x-atom 32 PropModeReplace
52 "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
53 } [ x-atom ] map >c-int-array
54 4 XChangeProperty drop ;
56 : set-timestamp-prop ( evt -- )
58 [ XSelectionRequestEvent-requestor ] keep
59 [ XSelectionRequestEvent-property ] keep
60 >r "TIMESTAMP" x-atom 32 PropModeReplace r>
61 XSelectionRequestEvent-time 1array >c-int-array
62 1 XChangeProperty drop ;
64 : send-notify ( evt prop -- )
65 "XSelectionEvent" <c-object>
66 SelectionNotify over set-XSelectionEvent-type
67 [ set-XSelectionEvent-property ] keep
68 over XSelectionRequestEvent-display over set-XSelectionEvent-display
69 over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
70 over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
71 over XSelectionRequestEvent-target over set-XSelectionEvent-target
72 over XSelectionRequestEvent-time over set-XSelectionEvent-time
73 >r dpy get swap XSelectionRequestEvent-requestor 0 0 r>
77 : send-notify-success ( evt -- )
78 dup XSelectionRequestEvent-property send-notify ;
80 : send-notify-failure ( evt -- )