basis/x11/clipboard/clipboard.factor

   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 ;
   6 IN: x11.clipboard
   7
   8 ! This code was based on by McCLIM's Backends/CLX/port.lisp
   9 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
  10
  11 : XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
  12
  13 : XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
  14
  15 TUPLE: x-clipboard atom contents ;
  16
  17 : <x-clipboard> ( atom -- clipboard )
  18     "" x-clipboard boa ;
  19
  20 : selection-property ( -- n )
  21     "org.factorcode.Factor.SELECTION" x-atom ;
  22
  23 : convert-selection ( win selection -- )
  24     swap >r >r dpy get r> XA_UTF8_STRING selection-property r>
  25     CurrentTime XConvertSelection drop ;
  26
  27 : snarf-property ( prop-return -- string )
  28     dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
  29
  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 ;
  34
  35 : selection-from-event ( event window -- string )
  36     swap XSelectionEvent-property zero? [
  37         drop f
  38     ] [
  39         selection-property 1 window-property utf8 decode
  40     ] if ;
  41
  42 : own-selection ( prop win -- )
  43     dpy get -rot CurrentTime XSetSelectionOwner drop
  44     flush-dpy ;
  45
  46 : set-targets-prop ( evt -- )
  47     dpy get swap
  48     [ XSelectionRequestEvent-requestor ] keep
  49     XSelectionRequestEvent-property
  50     "TARGETS" x-atom 32 PropModeReplace
  51     {
  52         "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
  53     } [ x-atom ] map >c-int-array
  54     4 XChangeProperty drop ;
  55
  56 : set-timestamp-prop ( evt -- )
  57     dpy get swap
  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 ;
  63
  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>
  74     XSendEvent drop
  75     flush-dpy ;
  76
  77 : send-notify-success ( evt -- )
  78     dup XSelectionRequestEvent-property send-notify ;
  79
  80 : send-notify-failure ( evt -- )
  81     0 send-notify ;