core/ui/x11/clipboard.factor

   1 ! Copyright (C) 2006 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays gadgets kernel math namespaces sequences ;
   4 IN: x11
   5
   6 ! This code was based on by McCLIM's Backends/CLX/port.lisp
   7 ! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
   8
   9 TUPLE: x-clipboard atom contents ;
  10
  11 C: x-clipboard ( atom -- clipboard )
  12     [ set-x-clipboard-atom ] keep
  13     "" over set-x-clipboard-contents ;
  14
  15 : selection-property ( -- n )
  16     "org.factorcode.Factor.SELECTION" x-atom ;
  17
  18 : convert-selection ( win selection -- )
  19     swap >r >r dpy get r> XA_STRING selection-property r>
  20     CurrentTime XConvertSelection drop ;
  21
  22 : snarf-property ( prop-return -- string )
  23     dup *void* [ *char* ] [ drop f ] if ;
  24
  25 : window-property ( win prop delete? -- string )
  26     >r dpy get -rot 0 -1 r> AnyPropertyType
  27     0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
  28     [ XGetWindowProperty drop ] keep snarf-property ;
  29
  30 : selection-from-event ( event window -- string )
  31     >r XSelectionEvent-property zero? [
  32         r> drop f
  33     ] [
  34         r> selection-property 1 window-property
  35     ] if ;
  36
  37 : own-selection ( prop win -- )
  38     dpy get -rot CurrentTime XSetSelectionOwner drop
  39     flush-dpy ;
  40
  41 : clipboard-for-atom ( atom -- clipboard )
  42     {
  43         { [ dup XA_PRIMARY = ] [ drop selection get ] }
  44         { [ dup "CLIPBOARD" x-atom = ] [ drop clipboard get ] }
  45         { [ t ] [ drop <clipboard> ] }
  46     } cond ;
  47
  48 : set-selection-prop ( evt -- )
  49     dpy get swap
  50     [ XSelectionRequestEvent-requestor ] keep
  51     [ XSelectionRequestEvent-property ] keep
  52     >r XA_STRING 8 PropModeReplace r>
  53     XSelectionRequestEvent-selection
  54     clipboard-for-atom x-clipboard-contents
  55     dup string>char-alien swap length XChangeProperty drop ;
  56
  57 : set-targets-prop ( evt -- )
  58     dpy get swap
  59     [ XSelectionRequestEvent-requestor ] keep
  60     XSelectionRequestEvent-property
  61     "TARGETS" x-atom 32 PropModeReplace
  62     { "STRING" "TARGETS" "TIMESTAMP" } [ x-atom ] map >int-array
  63     32 XChangeProperty drop ;
  64
  65 : set-timestamp-prop ( evt -- )
  66     dpy get swap
  67     [ XSelectionRequestEvent-requestor ] keep
  68     [ XSelectionRequestEvent-property ] keep
  69     >r "TIMESTAMP" x-atom 32 PropModeReplace r>
  70     XSelectionRequestEvent-time 1array >int-array
  71     32 XChangeProperty drop ;
  72
  73 : send-notify ( evt prop -- )
  74     "XSelectionEvent" <c-object>
  75     SelectionNotify over set-XSelectionEvent-type
  76     [ set-XSelectionEvent-property ] keep
  77     over XSelectionRequestEvent-display   over set-XSelectionEvent-display
  78     over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
  79     over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
  80     over XSelectionRequestEvent-target    over set-XSelectionEvent-target
  81     over XSelectionRequestEvent-time      over set-XSelectionEvent-time
  82     >r dpy get swap XSelectionRequestEvent-requestor 0 0 r>
  83     XSendEvent drop
  84     flush-dpy ;
  85
  86 : send-notify-success ( evt -- )
  87     dup XSelectionRequestEvent-property send-notify ;
  88
  89 : send-notify-failure ( evt -- )
  90     0 send-notify ;
  91
  92 : x-clipboard@ ( gadget clipboard -- prop win )
  93     x-clipboard-atom swap find-world world-handle first ;
  94
  95 M: x-clipboard copy-clipboard
  96     [ x-clipboard@ own-selection ] keep
  97     set-x-clipboard-contents ;
  98
  99 M: x-clipboard paste-clipboard
 100     >r find-world world-handle first r> x-clipboard-atom
 101     convert-selection ;
 102
 103 : init-clipboard ( -- )
 104     XA_PRIMARY <x-clipboard> selection set-global
 105     "CLIPBOARD" x-atom <x-clipboard> clipboard set-global ;