<u style="display: none;">... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... no changes ... <a href='free'>http://www.ringtones-dir.com'>free ringtones</a> : [L1 ] - HTTP://www.ringtones-dir.com download ringtones : [nokia ringtones|http://www.ringtones-dir.com ] - nokia ringtones|HTTP://www.ringtones-dir.com : http://www.ringtones-dir.com/download/ : [http://www.ringtones-dir.com ring tones] : [http://www.ringtones-dir.com | ringtones download] : "samsung ringtones" http://www.ringtones-dir.com : [L2 ] </u>SDW This is an example implementation of a client/server arrangment to execute commands in a remote safe interpreter.
This script may be out of date. Check Sean's website for changes: http://www.etoyoc.com/programs
namespace eval ::rpc {
variable mysock
variable sport
variable connections
proc trace string {
puts $string
}
###
# Change me, should be an odd number
# smaller than the random number range
###
variable secret_key 666
variable secret_range 10000
proc hash {arglist {key {}}} {
set accum 0
if { $key == {} } {
variable secret_key
set key $secret_key
}
foreach s $arglist {
set accum [expr ($accum + $s) % $key]
}
return $accum
}
proc init {interp port} {
variable mysock
variable sport
variable error_log_file
set sport $port
set mysock [socket -server [list ::rpc::newcon $interp] $port]
}
proc newcon {interp sock addr port} {
fconfigure $sock -buffering line -translation crlf
trace [list OPEN $sock from $addr]
upvar #0 [namespace current]::${sock} state
array set state [list interp $interp ipaddr $addr ipport $port state ready]
fileevent $sock readable [list ::rpc::getline $sock]
}
proc closechan {sock} {
catch { close $sock }
trace "$sock closed"
###
# Wake up any pending command
###
set [namespace current]::${sock}_block -1
update
catch {unset [namespace current]::${sock}_block}
array unset [namespace current]::${sock}
}
proc getline {sock} {
upvar #0 [namespace current]::${sock} state
if { [gets $sock line] < 0 } {
closechan $sock
return
}
state_$state(state) $sock $line
}
proc state_ready {sock line} {
upvar #0 [namespace current]::${sock} state
variable secret_range
switch [lindex $line 0] {
NOOP {
puts $sock [list NOOP]
}
AUTH {
set n [expr rand() * 10]
set state(challenge) {}
for {set x 0} { $x < $n } { incr x } {
lappend state(challenge) [expr int(rand() * $secret_range)]
}
puts $sock [list CHAL $state(challenge)]
}
RESP {
set response [lindex $line 1]
set correct [hash $state(challenge)]
if { $response != $correct } {
closechan $sock
}
set state(state) auth
puts $sock "OK"
}
QUIT {
closechan $sock
}
}
}
proc state_auth {sock line} {
upvar #0 [namespace current]::${sock} state
switch [lindex $line 0] {
EVAL {
puts $sock "BEGIN SCRIPT, TERMIATE WITH '.'"
set state(state) data
set state(script) {}
}
NOOP {
puts $sock NOOP
}
}
}
proc state_data {sock line} {
upvar #0 [namespace current]::${sock} state
if { $line == "." } {
set buffer [decode $state(script)]
###
# Eval script
###
set ::errorInfo {}
set err [catch { interp eval $state(interp) $buffer } reply]
if $err {
puts $sock ERROR
puts $sock [encode [list $err $reply $::errorInfo]]
} else {
if ![regexp
$reply] {
if { [string length $reply] > 32768 } {
set reply [join $reply ]
}
}
if [regexp
$reply] {
puts $sock MULTILINE
puts $sock [encode $reply]
puts $sock .
} else {
puts $sock [list RETURN $reply]
}
}
# puts $sock [list RETURN]
set state(state) auth
} else {
if { $state(script) == {} } {
set state(script) $line
} else {
append state(script)
$line
}
}
}
proc encode buffer {
regsub -all "." $buffer " .." buffer
return $buffer
}
proc decode buffer {
regsub -all ".." $buffer " ." buffer
return $buffer
}
###
# Begin Client Code
###
proc reval_init {handle server port {key {}}} {
upvar #0 [namespace current]::${handle} token
if { $key == {} } {
variable secret_key
set key $secret_key
}
array set token [list handle $handle server $server port $port secret_key $key sock {}]
}
proc reval_wake handle {
upvar #0 [namespace current]::${handle} token
set sock $token(sock)
###
# Check for echo
###
if { $sock != {} } {
if [catch {
sendline $sock NOOP $handle NOOP line
}] {
set sock {}
}
}
if { $sock == {} } {
trace [list OPENING connection to $token(server) at $token(port)]
set sock [socket $token(server) $token(port)]
fconfigure $sock -buffering line -translation crlf -blocking 1
set token(sock) $sock
sendline $sock AUTH $handle CHAL line
set hash [hash [lindex $line 1] $token(secret_key)]
sendline $sock [list RESP $hash] $handle OK line
}
set token(sock) $sock
return $sock
}
proc reval_reset {handle sock} {
upvar #0 [namespace current]::${handle} token
closechan $sock
set token(sock) {}
}
proc sendline {sock sendline handle token resultvar} {
upvar 1 $resultvar reply
puts $sock $sendline
if { [gets $sock reply] < 0 } {
reval_reset $sock $handle
error "Connection Closed"
}
if { [lindex $reply 0] != "$token" } {
error "Server sent [lindex $line 0] instead of $token in response to $sendline"
}
return $reply
}
proc recvline {sock} {
if { [gets $sock line] < 0 } {
closechan $sock
error "Connection Closed"
}
return $line
}
proc getblock {sock varname} {
upvar 1 $varname result
set result {}
while 1 {
if {[gets $sock line] < 0 } {
error "Connection Reset"
}
if { $line == "." } break
append result
$line
}
return [decode [string range $result 1 end]]
}
proc reval {handle args} {
if { [llength $args] == 1 } {
set args [lindex $args 0]
}
set sock [reval_wake $handle]
sendline $sock EVAL $handle BEGIN line
puts $sock [encode $args]
puts $sock .
set reply [recvline $sock]
switch [lindex $reply 0] {
RETURN {
return [lindex $reply 1]
}
ERROR {
if [catch {getblock $sock reply} err] {
reval_reset $handle $sock
error $err
}
return -code [lindex $reply 0] -errorinfo [lindex $reply 2] [lindex $reply 1]
}
MULTILINE {
if [catch {getblock $sock reply} err] {
reval_reset $handle $sock
error $err
}
return $reply
}
}
}
}
Starting a server process:
interp create -safe example
::rpc::init example 8016 1337
###
# Important, or the server will never
# start listening
###
vwait foreverStarting a client process:
::rpc::reval_init localhost localhost 8016 1337
set stmt {expr 1 + 1}
set reply [::rpc::reval localhost $stmt]
puts [list $stmt = $reply]
Related topics include "Tuplespace", "remote execution using tcl and Pcom", "remote ssh tcl", 'mkextensions' mkRinterp, "Distributing a series of tasks", and so on. And so on includes ... "comm".