unmaintained/network-clipboard/network-clipboard.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io.server io.sockets io strings parser byte-arrays
   4 namespaces ui.clipboards ui.gadgets.panes ui.gadgets.scrollers
   5 ui.gadgets.buttons ui.gadgets.tracks ui.gadgets ui.operations
   6 ui.commands ui kernel splitting combinators continuations
   7 sequences io.streams.duplex models ;
   8 IN: network-clipboard
   9
  10 : clipboard-port 4444 ;
  11
  12 : get-request
  13     clipboard get clipboard-contents write ;
  14
  15 : contents ( -- str )
  16     [ 1024 read dup ] [ ] [ drop ] unfold concat ;
  17
  18 : set-request
  19     contents clipboard get set-clipboard-contents ;
  20
  21 : clipboard-server ( -- )
  22     clipboard-port internet-server "clip-server" [
  23         readln {
  24             { "GET" [ get-request ] }
  25             { "SET" [ set-request ] }
  26         } case
  27     ] with-server ;
  28
  29 \ clipboard-server H{
  30     { +nullary+ t }
  31     { +listener+ t }
  32 } define-command
  33
  34 : with-client ( addrspec quot -- )
  35     >r <client> r> with-stream ; inline
  36
  37 : send-text ( text host -- )
  38     clipboard-port <inet4> [ write ] with-client ;
  39
  40 TUPLE: host name ;
  41
  42 C: <host> host
  43
  44 M: string host-name ;
  45
  46 : send-clipboard ( host -- )
  47     host-name
  48     "SET\n" clipboard get clipboard-contents append swap send-text ;
  49
  50 [ host? ] \ send-clipboard H{ } define-operation
  51
  52 : ask-text ( text host -- text )
  53     clipboard-port <inet4>
  54     [ write flush contents ] with-client ;
  55
  56 : receive-clipboard ( host -- )
  57     host-name
  58     "GET\n" swap ask-text
  59     clipboard get set-clipboard-contents ;
  60
  61 [ host? ] \ receive-clipboard H{ } define-operation
  62
  63 : hosts. ( seq -- )
  64     "Hosts:" print
  65     [ dup <host> write-object nl ] each ;
  66
  67 TUPLE: network-clipboard-tool ;
  68
  69 \ network-clipboard-tool "toolbar" f {
  70     { f clipboard-server }
  71 } define-command-map
  72
  73 : <network-clipboard-tool> ( model -- gadget )
  74     \ network-clipboard-tool construct-empty [
  75         toolbar,
  76         [ hosts. ] <pane-control> <scroller> 1 track,
  77     ] { 0 1 } build-track ;
  78
  79 SYMBOL: network-clipboards
  80
  81 { } <model> network-clipboards set-global
  82
  83 : set-network-clipboards ( seq -- )
  84     network-clipboards get set-model ;
  85
  86 : add-network-clipboard ( host -- )
  87     network-clipboards get [ swap add ] change-model ;
  88
  89 : network-clipboard-tool ( -- )
  90     [
  91         network-clipboards get
  92         <network-clipboard-tool>
  93         "Network clipboard" open-window
  94     ] with-ui ;
  95
  96 MAIN: network-clipboard-tool