basis/x11/clipboard/clipboard.factor

   1 ! Copyright (C) 2006, 2007 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.int x11 x11.constants x11.xlib ;
   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 [ [ dpy get ] dip XA_UTF8_STRING selection-property ] dip
  25     CurrentTime XConvertSelection drop ;
  26
  27 : snarf-property ( prop-return -- string )
  28     dup *void* [ *void* utf8 alien>string ] [ drop f ] if ;
  29
  30 : window-property ( win prop delete? -- string )
  31     [ [ dpy get ] 2dip 0 -1 ] dip 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 property>> 0 =
  37     [ drop f ] [ selection-property 1 window-property ] if ;
  38
  39 : own-selection ( prop win -- )
  40     [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
  41     flush-dpy ;
  42
  43 : set-targets-prop ( evt -- )
  44     [ dpy get ] dip [ requestor>> ] [ property>> ] bi
  45     "TARGETS" x-atom 32 PropModeReplace
  46     {
  47         "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
  48     } [ x-atom ] int-array{ } map-as
  49     4 XChangeProperty drop ;
  50
  51 : set-timestamp-prop ( evt -- )
  52     [ dpy get ] dip
  53     [ requestor>> ]
  54     [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
  55     [ time>> <int> ] tri
  56     1 XChangeProperty drop ;
  57
  58 : send-notify ( evt prop -- )
  59     XSelectionEvent <struct>
  60     SelectionNotify >>type
  61     swap >>property
  62     over display>>   >>display
  63     over requestor>> >>requestor
  64     over selection>> >>selection
  65     over target>>    >>target
  66     over time>>      >>time
  67     [ [ dpy get ] dip requestor>> 0 0 ] dip
  68     XSendEvent drop
  69     flush-dpy ;
  70
  71 : send-notify-success ( evt -- )
  72     dup property>> send-notify ;
  73
  74 : send-notify-failure ( evt -- )
  75     0 send-notify ;