- The 'server' is the machine on which the user interacts with a GUI. It needs wish.
- The 'client' is the machine where the software really turns. It only needs tclsh.
Client File #1 : distanciel.tcl
namespace eval distanciel {
variable server localhost
variable port 2006
variable socket
variable delayed
variable limit 10
variable operations
array set operations {unset Unset write Write read Read}
proc connect {args} {
variable server
variable port
variable socket
if {[catch {set socket [socket $server $port]}]} {
error "cannot connect to server $server on port $port"
}
return
}
proc send {args} {
for {set level 1} {
[uplevel $level namespace current] eq "::distanciel"
} {incr level} {}
set current [uplevel $level namespace current]
puts $current
connect
variable socket
# write <length>,data
set data [string length $args],[string length $current]\n
append data $current$args
for {set i 0} {$i < 3 && [set b [catch {puts -nonewline $socket $data} msg]]} {incr i} {
# do nothing
}
catch {flush $socket}
if {$b} {
error "cannot write after $i attempts"
}
# read <length>,data
gets $socket count
foreach {script data} [read $socket $count] {break}
close $socket
puts "script $script"
uplevel 1 $script
return $data
}
# create an local incarnation of a remote (Tk-related) proc
proc lambda {procname} {
#puts lambda=$procname
set body [send delegate [list info body $procname]]
set arglist [lambdaargs $procname]
# get the namespace
foreach {allctx procname} [context $procname] {break}
# creates locally the proc
puts $allctx,$procname,$arglist,$body
uplevel 1 [list proc ${allctx}::$procname $arglist $body]
}
source tools.tcl
proc lambdaargs {procname} {
set arglist [send delegate [list info args $procname]]
if {[llength $arglist] == 0} {return [list]}
foreach arg $arglist {
if {[send delegate [list info default $procname $arg dummy]]} {
lappend result [list $arg [send delegate [list default $procname $arg]]]
} else {
lappend result $arg
}
}
puts "lambdaargs $result"
return $result
}
proc delete {cmd op} {
send delegate $cmd
}
# when a variable has to be remotely controlled
# here we write data
proc wvar {varname value} {
trace remove variable $varname write distanciel::myvar
set $varname $value
trace add variable $varname write distanciel::myvar
}
# like incr : returns the incremented value, but without modifying the variable
proc getincr {var {increment 0}} {
upvar $var x
incr x 0
incr increment 0
return [expr {$x + $increment}]
}
proc normalize {varname} {
set i [string first ( $varname]
if {$i<0} {
return [list $varname ""]
}
list [string range $varname [getincr i -1]] \
[string range $varname [getincr i] end-1]
}
proc varread {varname {currentns ::}} {
if {[string range $varname 0 1] ne "::"} {
set varname $currentns$varname
}
puts here
if {![info exists $varname]} {
return
}
# install traces
watch $varname
# tell the server an update
puts herebeforedelegate
send delegate [list Write $varname [set $varname]]
}
proc watch {varname} {
#puts $varname
# adds the same trace proc to all possible operations : read, write and unset
trace add variable $varname write distanciel::myvar
# see principles : we do not need to remotely read
#trace add variable $varname read distanciel::myvar
trace add variable $varname unset distanciel::myvar
}
# given a var name and an eventual key, return the fully qualified name of the variable
proc yourvar {name key} {
if {$key eq ""} {
return $name
}
return ${name}($key)
}
#
# About -textvariable and -listvariable : these options allow the server to share
# data with the client, because they exists in the client, must be displayed
# and might be updated by the GUI server.
#
# principles :
# * each time a variable is set, the other side must be telled of that
# (with the problem raising when both sides update variables at the same time)
# * when a variable is unset (that cannot happen at the other, server side)
# it must be destroyed at the server side
# * if all the above conditions are met, no problem happen with reading variables
#
# unsets, reads or writes to a variable
proc myvar {var key op} {
foreach {ns var} [context $var] {break}
if {$ns eq ""} {
set ns [uplevel namespace current]
}
variable operations
set name ${ns}::[yourvar $var $key]
# translates an operation (read-write-unset) into a remote command
set cmd [list $operations($op) $name]
#puts $cmd
switch -- $op {
unset -
read {}
write {
lappend cmd [set $name]
}
}
send delegate $cmd
}
proc renproc {oldname newname op} {
send delegate [list rename $oldname $newname]
}
}
package provide distanciel 0.1Client file #2 : distclt.tcl
source distanciel.tcl
# let unknown know...
proc unknown {args} [string map {} {
set cmd [lindex $args 0]
switch -glob -- $cmd {
\.* {
if {[winfo exists $cmd]} {
return [distanciel::send delegate $args]
}
}
}
#puts $cmd
if {[string match ::tk::* $cmd] || [string match tk::* $cmd]} {
# private Tk procs, or even widget commands !
puts $cmd
if {![catch {distanciel::lambda $cmd} msg]} {
return [uplevel $args]
}
puts "err: $msg"
}
if {[uplevel 1 namespace current] eq "::tk"} {
set cmd ::tk::$cmd
puts $cmd
if {![catch {distanciel::lambda $cmd} msg]} {
return [uplevel $args]
}
puts "err: $msg"
}
}][info body unknown]
namespace eval ::tk {
proc myvariable {name} {
foreach {ns var} [distanciel::context $name] {
if {$ns eq "::tk"} {
uplevel ::variable $var
return
}
}
uplevel ::variable $name
}
namespace eval unsupported {}
}
# widget list
foreach name {
button label frame entry text canvas checkbutton radiobutton menu menubutton
scrollbar spinbox listbox labelframe message tk_optionMenu panedwindow
toplevel
} {
set body {
# creates the widget
distanciel::send create [linsert $args 0 NAME $obj]
# instanciates a wrapper to handle widget methods
proc $obj {args} {
distanciel::send action [info level 0]
}
trace add command $obj rename distanciel::renproc
# next line causes severe errors
#trace add command $obj delete distanciel::renproc
return $obj
}
proc $name {obj args} [string map [list NAME $name] $body]
}
proc . {args} {
distanciel::send action [info level 0]
}
foreach name {
bell bind bindtags clipboard tk_chooseColor tk_chooseDirectory console
destroy tk_dialog event focus tk_focusNext tk_focusPrev tk_focusFollowsMouse
font tk_getOpenFile tk_getSaveFile grab grid image lower tk_messageBox
option pack tk_setPalette tk_bisque place tk_popup raise scale selection
send tk winfo wm tk_textCopy tk_testCut tk_textPaste tkwait
} {
proc $name {args} [string map [list NAME $name] {
distanciel::send delegate [linsert $args 0 NAME]
}]
}
foreach name {::tk::unsupported::ExposePrivateCommand
::tk::unsupported::ExposePrivateVariable} {
proc $name {args} [string map [list NAME $name] {
catch {distanciel::send delegate [linsert $args 0 NAME]}
}]
}
trace add execution exit enter distanciel::delete
# some hacks
# proc dputs {args} {puts $args}
# because we emulate Tk, and because some megawidgets call "package require Tk"
package provide Tk [package require Tcl]
set argv0 [lindex $argv 0]
set argv [lrange $argv 1 end]
source $argv0
while {1} {
update
after 30
distanciel::send script
}Server : distserver.tcl
package require Tk
source tools.tcl
proc dputs {arg} {
set fd [open traces.txt a]
puts $fd $arg
close $fd
}
file delete traces.txt
set script ""
set mybreak 0
array set watch ""
array unset watch *
set currentns ::
# used by distanciel::lambda
proc default {procname arg} {
info default $procname $arg value
return $value
}
proc recv {channel args} {
#fconfigure $channel -translation binary
gets $channel counts
foreach {count ns} [split $counts ,] {break}
incr count $ns
if {[catch {set data [read $channel $count]}]} {return}
set ::currentns [string range $data 0 [expr {$ns - 1}]]
set data [string range $data $ns end]
if {[llength $data]>2} {
dputs $data
error "internal error"
}
foreach {type cmd} $data {break}
set quit no
switch -- $type {
action -
create -
delegate {
dputs $data
set data [eval [linsert $cmd 0 $type]]
}
script {set data ""}
default {error "unknown request type, should be one of : $types"}
}
foreach {var keys} [array get ::watch] {
#dputs var=$var
if {[llength $keys] > 1} {
foreach key $keys {
callback [list distanciel::wvar ${var}($key) [set ${var}($key)]]
}
} elseif {$keys eq ""} {
callback [list distanciel::wvar $var [set $var]]
} else {
callback [list distanciel::wvar ${var}($keys) [set ${var}($keys)]]
}
}
# clear the array
array unset ::watch *
#dputs S:$::script
set data [list $::script $data]
set ::script ""
#dputs Resp:$data
puts -nonewline $channel [string length $data]\n$data
flush $channel
close $channel
if {$quit} {
# after 1000; # here to flush network buffers before exiting
exit
}
}
proc action {args} {
foreach {widget cmd} $args {break}
switch -- $cmd {
configure {
set args [linsert [configure [lrange $args 2 end]] 0 $widget $cmd]
}
cget {
return [cget $args]
}
add {
# $menu add command -command "MyCmd"
if {[lindex $args 2] eq "command"} {
dputs "menu $args"
set args [linsert [configure [lrange $args 3 end]] 0 $widget add command]
dputs "menu $args"
}
}
default {}
}
seceval $args
}
# TODO : proc Set
proc Set {var value} {
context $var $::currentns
set $var $value
}
# secure eval
proc seceval {arg} {
if {[catch {eval $arg} msg]} {
callback [list error $msg]
return
}
set msg
}
rename exit __exit__
proc exit {{code 0}} {
callback [list exit $code]
update
after 2000
__exit__
}
proc delegate {args} {
switch -- [lindex $args 0] {
exit {
# delay exit script
uplevel set quit yes
callback $args
return
}
bind {
if {[llength $args] == 3} {
#dputs $args
# skip the callback
set result [seceval $args]
#dputs $result
catch {
if {[llength $result] == 2 && [lindex $result 0] eq "callback"} {
set result [lindex $result 1]
}
}
return $result
}
if {[llength $args] == 4} {
# there is a script (bind may be called without)
set script [lindex $args 3]
if {[string index $script 0] eq "+"} {
# append the script to the current bindings
set plus +
set script [string range $script 1 end]
} else {
set plus ""
}
# the third argument to the bind command is a callback
lset args 3 $plus[list callback $script]
}
}
Unset {
# unset a shared variable
unset [lindex $args 1]
return
}
Write {
# set the shared variable to its new value
#dputs Write:$args
set var [lindex $args 1]
set value [lindex $args 2]
# remove traces before setting the variable to avoid aller-retour
trace remove variable $var write wvar
Set $var $value
trace add variable $var write wvar
# in order to be a little more synchronous,
# $value was replaced by [set $var]
return [set $var]
}
default {
# nothing to be done
}
}
# take the first pair
foreach {cmd obj} $args {break}
switch -- $obj {
configure {
set args [linsert [lindex [configure [lrange $args 2 end]] 0] 0 $cmd $obj]
}
cget {
return [cget $args]
}
default {}
}
#dputs del:$args
seceval $args
}
# instanciate a variable link
proc myvar {varname} {
dputs "myvar $varname"
set pos [string first ( $varname]
if {$pos>=0} {
set key [string range $varname [expr {$pos+1}] end-1]
set myvar [string range $varname 0 [incr pos -1]]
}
if {[info exists key]} {
if {![info exists $varname]} {
Set $varname ""
callback [list distanciel::varread $varname $::currentns]
} elseif {[trace info variable $varname] eq ""} {
trace add variable $varname write wvar
wvar $myvar $key write
if {[trace info variable $myvar] eq ""} {
trace add variable $myvar array wvar
}
}
return $varname
}
if {![info exists $varname]} {
Set $varname ""
callback [list distanciel::varread $varname $::currentns]
} elseif {[trace info variable $varname] eq ""} {
trace add variable $varname write wvar
wvar $varname "" write
}
# returns the var name
return $varname
}
proc wvar {name key op} {
# it overwrites previously trace invokations, if any
if {[llength [split $name ::]]==1} {
set name [uplevel namespace current]::$name
}
#dputs var=$name
if {$op eq "array"} {
foreach key [array names $name] {
wvar $name $key write
}
return
}
if {![info exists ::watch($name)]} {
set ::watch($name) $key
return
}
if {$key eq ""} {
# scalar variable
return
}
if {[lsearch -exact $::watch($name) $key]<0} {
lappend ::watch($name) $key
}
}
proc configure {args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
if {[llength $args] % 2 != 0} {return $args}
set l ""
foreach {opt value} $args {
switch -- $opt {
-command {
lappend l $opt [linsert $value 0 callback]
}
-listvariable -
-textvariable -
-yscrollvariable -
-xscrollvariable -
-variable {
lappend l $opt [myvar $value]
}
default {lappend l $opt $value}
}
}
#dputs config=$l
set l
}
proc cget {arg} {
foreach {obj cmd option} $arg {break}
set res [seceval $arg]
switch -- $option {
-command {
# value is {callback {cmd arg ...}}
# we want the command
set res [lindex $res 1]
}
default {
# nothing to be done
}
}
return $res
}
# create a widget instance
proc create {args} {
foreach {cmd obj} $args {break}
set l [linsert [configure [lrange $args 2 end]] 0 $cmd $obj]
dputs $l
seceval $l
}
proc callback {args} {
dputs callback//$args//[info level 1]
if {[llength $args] == 1} {set args [lindex $args 0]}
append ::script $args
append ::script \n
}
# not needed anymore
#callback {namespace eval tk {}}
# to share Tk private data with the client
foreach var [concat [info vars ::tk::*] [info vars ::tk_*]] {
if {[array exists $var]} {
foreach key [array names $var] {
myvar ${var}($key)
}
} else {
myvar $var
}
}
socket -server recv 2006Common file : the tools (tools.tcl) It must be present at both ends.
# common tools for distanciel
# By Stéphane Arnold 2006
proc context {name {globalns ::}} {
if {$globalns ne "::"} {set name $globalns$name}
set ns [wsplit $name ::]
set name [lindex $ns end]
set ns [lrange $ns 0 end-1]
# creates all intermediate namespace, if they do not exist
set allctx ""
foreach context $ns {
if {$context eq ""} {
append allctx ::
continue
}
if {$allctx ne "::" && $allctx ne ""} {
append allctx ::
}
append allctx $context
namespace eval $allctx {}
}
list $allctx $name
}
# Split a string $str after the separator $sep
# the built-in split command cannot do that
proc wsplit {str sep} {
set out ""
set sepLen [string length $sep]
if {$sepLen < 2} {
return [split $str $sep]
}
while {[set idx [string first $sep $str]] >= 0} {
if {$idx>0} {
# the left part : the current element
lappend out [string range $str 0 [expr {$idx-1}]]
}
# get the right part and iterate with it
set str [string range $str [incr idx $sepLen] end]
}
# there is no separator anymore, but keep in mind the right part must be appended
lappend out $str
}Client file #3 : the test program (mytest.tcl)
package require BWidget
Label .lbl -text "Hello Stéphane!"
Button .b -command exit -text Exit
set enter "Enter your text here"
proc echo {var key op} {
if {$key ne ""} {
puts [set $var($key)]
return
}
puts [set $var]
}
#trace add variable ::enter write echo
Entry .en -textvariable ::enter
Button .echo -command {tk_messageBox -message "You have typed : $::enter"} -text Echo
pack .lbl .b .en .echoHow to launch it :# on the server wish distserver.tcl & # on the client tclsh distclt.tcl mytest.tcl &
See also Remote Script Execution.
