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