1 ! Copyright (C) 2006, 2010 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.strings classes.struct
4 io.encodings.utf8 kernel namespaces sequences
5 specialized-arrays x11 x11.constants x11.xlib ;
9 ! This code was based on by McCLIM's Backends/CLX/port.lisp
10 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
12 : XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
13 : XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
14 : XA_TARGETS ( -- atom ) "TARGETS" x-atom ;
15 : XA_TIMESTAMP ( -- atom ) "TIMESTAMP" x-atom ;
16 : XA_TEXT ( -- atom ) "TEXT" x-atom ;
18 TUPLE: x-clipboard atom contents ;
20 : <x-clipboard> ( atom -- clipboard )
23 : selection-property ( -- n )
24 "org.factorcode.Factor.SELECTION" x-atom ;
26 : convert-selection ( win selection -- )
27 swap [ [ dpy get ] dip XA_UTF8_STRING selection-property ] dip
28 CurrentTime XConvertSelection drop ;
30 : snarf-property ( prop-return -- string )
31 dup *void* [ *void* utf8 alien>string ] [ drop f ] if ;
33 : window-property ( win prop delete? -- string )
34 [ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
35 0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
36 [ XGetWindowProperty drop ] keep snarf-property ;
38 : selection-from-event ( event window -- string )
40 [ drop f ] [ selection-property 1 window-property ] if ;
42 : own-selection ( prop win -- )
43 [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
46 : set-targets-prop ( evt -- )
47 [ dpy get ] dip [ requestor>> ] [ property>> ] bi
48 XA_TARGETS 32 PropModeReplace
49 XA_UTF8_STRING XA_STRING XA_TARGETS XA_TIMESTAMP int-array{ } 4sequence
50 4 XChangeProperty drop ;
52 : set-timestamp-prop ( evt -- )
55 [ property>> XA_TIMESTAMP 32 PropModeReplace ]
57 1 XChangeProperty drop ;
59 : send-notify ( evt prop -- )
60 XSelectionEvent <struct>
61 SelectionNotify >>type
63 over display>> >>display
64 over requestor>> >>requestor
65 over selection>> >>selection
66 over target>> >>target
68 [ [ dpy get ] dip requestor>> 0 0 ] dip
72 : send-notify-success ( evt -- )
73 dup property>> send-notify ;
75 : send-notify-failure ( evt -- )