106 lines
3.4 KiB
Factor
106 lines
3.4 KiB
Factor
! Copyright (C) 2006 Slava Pestov
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: alien arrays gadgets kernel math namespaces sequences ;
|
|
IN: x11
|
|
|
|
! This code was based on by McCLIM's Backends/CLX/port.lisp
|
|
! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
|
|
|
|
TUPLE: x-clipboard atom contents ;
|
|
|
|
C: x-clipboard ( atom -- clipboard )
|
|
[ set-x-clipboard-atom ] keep
|
|
"" over set-x-clipboard-contents ;
|
|
|
|
: selection-property ( -- n )
|
|
"org.factorcode.Factor.SELECTION" x-atom ;
|
|
|
|
: convert-selection ( win selection -- n )
|
|
swap >r >r dpy get r> XA_STRING selection-property r>
|
|
CurrentTime XConvertSelection drop ;
|
|
|
|
: snarf-property ( prop-return -- string )
|
|
dup *void* [ *char* ] [ drop f ] if ;
|
|
|
|
: window-property ( win prop delete? -- string )
|
|
>r dpy get -rot 0 -1 r> AnyPropertyType
|
|
0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
|
|
[ XGetWindowProperty drop ] keep snarf-property ;
|
|
|
|
: selection-from-event ( event window -- string )
|
|
>r XSelectionEvent-property zero? [
|
|
r> drop f
|
|
] [
|
|
r> selection-property 1 window-property
|
|
] if ;
|
|
|
|
: own-selection ( prop win -- )
|
|
dpy get -rot CurrentTime XSetSelectionOwner drop
|
|
flush-dpy ;
|
|
|
|
: clipboard-for-atom ( atom -- clipboard )
|
|
{
|
|
{ [ dup XA_PRIMARY = ] [ drop selection get ] }
|
|
{ [ dup "CLIPBOARD" x-atom = ] [ drop clipboard get ] }
|
|
{ [ t ] [ drop <clipboard> ] }
|
|
} cond ;
|
|
|
|
: set-selection-prop ( evt -- )
|
|
dpy get swap
|
|
[ XSelectionRequestEvent-requestor ] keep
|
|
[ XSelectionRequestEvent-property ] keep
|
|
>r XA_STRING 8 PropModeReplace r>
|
|
XSelectionRequestEvent-selection
|
|
clipboard-for-atom x-clipboard-contents
|
|
dup length XChangeProperty drop ;
|
|
|
|
: set-targets-prop ( evt -- )
|
|
dpy get swap
|
|
[ XSelectionRequestEvent-requestor ] keep
|
|
XSelectionRequestEvent-property
|
|
"TARGETS" x-atom 32 PropModeReplace
|
|
{ "STRING" "TARGETS" "TIMESTAMP" } [ x-atom ] map >int-array
|
|
32 XChangeProperty drop ;
|
|
|
|
: set-timestamp-prop ( evt -- )
|
|
dpy get swap
|
|
[ XSelectionRequestEvent-requestor ] keep
|
|
[ XSelectionRequestEvent-property ] keep
|
|
>r "TIMESTAMP" x-atom 32 PropModeReplace r>
|
|
XSelectionRequestEvent-time 1array >int-array
|
|
32 XChangeProperty drop ;
|
|
|
|
: send-notify ( evt prop -- )
|
|
"XSelectionEvent" <c-object>
|
|
SelectionNotify over set-XSelectionEvent-type
|
|
[ set-XSelectionEvent-property ] keep
|
|
over XSelectionRequestEvent-display over set-XSelectionEvent-display
|
|
over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
|
|
over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
|
|
over XSelectionRequestEvent-target over set-XSelectionEvent-target
|
|
over XSelectionRequestEvent-time over set-XSelectionEvent-time
|
|
>r dpy get swap XSelectionRequestEvent-requestor 0 0 r>
|
|
XSendEvent drop
|
|
flush-dpy ;
|
|
|
|
: send-notify-success ( evt -- )
|
|
dup XSelectionRequestEvent-property send-notify ;
|
|
|
|
: send-notify-failure ( evt -- )
|
|
0 send-notify ;
|
|
|
|
: x-clipboard@ ( gadget clipboard -- prop win )
|
|
x-clipboard-atom swap find-world world-handle first ;
|
|
|
|
M: x-clipboard copy-clipboard
|
|
[ x-clipboard@ own-selection ] keep
|
|
set-x-clipboard-contents ;
|
|
|
|
M: x-clipboard paste-clipboard
|
|
>r find-world world-handle first r> x-clipboard-atom
|
|
convert-selection ;
|
|
|
|
: init-clipboard ( -- )
|
|
XA_PRIMARY <x-clipboard> selection set-global
|
|
"CLIPBOARD" x-atom <x-clipboard> clipboard set-global ;
|