basis/x11/clipboard/clipboard.factor

   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 ;
   6 SPECIALIZED-ARRAY: int
   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 : 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 ;
  17
  18 TUPLE: x-clipboard atom contents ;
  19
  20 : <x-clipboard> ( atom -- clipboard )
  21     "" x-clipboard boa ;
  22
  23 : selection-property ( -- n )
  24     "org.factorcode.Factor.SELECTION" x-atom ;
  25
  26 : convert-selection ( win selection -- )
  27     swap [ [ dpy get ] dip XA_UTF8_STRING selection-property ] dip
  28     CurrentTime XConvertSelection drop ;
  29
  30 : snarf-property ( prop-return -- string )
  31     dup void* deref [ void* deref utf8 alien>string ] [ drop f ] if ;
  32
  33 : window-property ( win prop delete? -- string )
  34     [ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
  35     0 <Atom> 0 int <ref> 0 ulong <ref> 0 ulong <ref> f void* <ref>
  36     [ XGetWindowProperty drop ] keep snarf-property ;
  37
  38 : selection-from-event ( event window -- string )
  39     swap property>> 0 =
  40     [ drop f ] [ selection-property 1 window-property ] if ;
  41
  42 : own-selection ( prop win -- )
  43     [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
  44     flush-dpy ;
  45
  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 ;
  51
  52 : set-timestamp-prop ( evt -- )
  53     [ dpy get ] dip
  54     [ requestor>> ]
  55     [ property>> XA_TIMESTAMP 32 PropModeReplace ]
  56     [ time>> int <ref> ] tri
  57     1 XChangeProperty drop ;
  58
  59 : send-notify ( evt prop -- )
  60     XSelectionEvent <struct>
  61     SelectionNotify >>type
  62     swap >>property
  63     over display>>   >>display
  64     over requestor>> >>requestor
  65     over selection>> >>selection
  66     over target>>    >>target
  67     over time>>      >>time
  68     [ [ dpy get ] dip requestor>> 0 0 ] dip
  69     XSendEvent drop
  70     flush-dpy ;
  71
  72 : send-notify-success ( evt -- )
  73     dup property>> send-notify ;
  74
  75 : send-notify-failure ( evt -- )
  76     0 send-notify ;