proc comment {text} {}comment { Zarutian 24. june 2005: what I have been working with: }
wm withdraw .
proc comment args {}
proc save_state args {
# ná í stikur fallsins/ferilins
set vars [lindex $args 0]
set op [lindex $args end]
if {$op == "leave"} {
# assumes that template for the traced procedure is
# kept in variable body in the traced procedure's stackframe
upvar body body
set subst [list %body% [list $body]]
foreach item $vars {
upvar $item tmp
lappend subst "%[set item]%"
lappend subst [list $tmp ]
}
puts "debug: $subst"
set caller [lindex [info level 1] 0]
proc $caller [list [info args $caller]] [string map $subst $body]
}
}
proc lcombine {listA listB} {
set res [list]
foreach item $listA {
lappend res $item
}
foreach item $listB {
lappend res $item
}
set res
}
proc clock_millisecs {} {
# crude but gets the job done for now
set a [clock seconds]
set b [clock clicks -millisec]
set c [string range $b end-2 end]
while {[string index $c 0] == "0"} {
set c [string range $c 1 end]
}
if {[string index $b 0] == "-"} {
set b [format "%03d" [expr 1000 -$c]]
} else {
set b $c
}
return "[set a][set b]"
}
proc makeReplicatedSafeInterp {sync_proc {seed -1}} {
set me [lindex [info level 0] 0]
proc $me [list sync_proc [list seed [incr seed]]] [info body $me]
set name "replicaInterp[set seed]"
set body {
# nearly instance variables ;-)
set body %body% ; # sort of template for the procedure
set sync_proc %sync_proc%
set sub_interp %sub_interp%
set state_log %state_log%
# stuff to save
set vars [list sync_proc sub_interp state_log]
trace add execution [lindex [info level 0] 0] leave [list save_state $vars]
# initilize
set dispatch [list]
# method dispatch: (or nearly so)
switch -exact -- [lindex $args 0] {
"snapshot" {
return $state_log
}
"alias_called" {
set dispatch $sub_interp
lappend dispatch "invokehidden"
set dispatch [lcombine $dispatch [lrange $args 1 end]]
lappend state_log [list [clock_millisecs] [lrange $args 1 end]]
}
"eval" {
$sync_proc cause [lrange $args 1 end] [lindex [info level 0] 0]
set dispatch $sub_interp
lappend dispatch "eval"
set dispatch [lcombine $dispatch [lrange $args 1 end]]
}
"eval-without-cause" {
set dispatch $sub_interp
lappend dispatch "eval"
set dispatch [lcombine $dispatch [lrange $args 1 end]]
}
default {
set dispatch $sub_interp
set dispatch [lcombine $dispatch $args]
}
}
if {[llength $dispatch] > 0} {
return [eval $dispatch]
}
}
set sub_interp [interp create -safe]
foreach item { after append binary catch close fcopy fileevent flush foreach gets incr info interp lappend lset namespace package proc puts read regexp regsub rename scan seek set trace unset } {
$sub_interp hide $item
$sub_interp alias $item $name alias_called $item
}
set subst [list %body% [list $body] %sync_proc% [list $sync_proc] %sub_interp% [list $sub_interp] %state_log% "{}"]
proc $name args [string map $subst $body]
return $name
}
comment {
Command: Side-effects? (does invokation of the command change the var env?) after yes append yes array yes (array set) binary yes (binary scan) break nope (flow control) case nope catch yes (if args more than 1) clock no (simply calculation and an accessor) close yes (I/O) concat nope continue nope (flow control) eof nope (I/O state checker) error nope (???) eval nope (???) expr nope (calculations) fblocked nope (I/O state checker) fcopy yes (I/O) fileevent yes (I/O) flush yes (I/O) for nope (not directly) foreach yes (changes some var as it iterates throug a list) format nope gets yes (I/O) global nope (just opens up access for the current procedure to access that global var) if nope incr yes info yes (info script) interp yes (???) join nope lappend yes lindex nope linsert nope list nope llength nope lrange nope lreplace nope lsearch nope lset yes lsort nope namespace yes package yes pid nope proc yes puts yes (I/O) read yes (I/O) regexp yes regsub yes rename yes return nope (flow control) scan yes seek yes set yes split nope string nope subst nope (not directly) switch nope tell nope (I/O state checker/accessor) time nope (not directly) trace yes unset yes update nope uplevel see eval upvar ??? variable see global vwait nope while nope
}
comment {
proc prepend {varname data} {
upvar $varname tmp
set tmp "[set data][set tmp]"
}
proc lexclude {b a} {
# returns list a where all elements of list b have been removed.
set tmp [list]
foreach item $a {
if {[lsearch $b $item] == -1} {
lappend tmp $item
}
}
return $tmp
}
comment {Zarutian 19 june 2005: This developed out of the idea outlined by the Croquet Project (http://www.opencroquet.org/Croquet_Technologies/architecture.html ). Which is to replicate state of an object over many machines and synchronize those replicas.
This is a bit crude and thrown together implemention.
First, start of by setting up an slave interp. Alias after to be able to capture after scripts.
}
set i [interp create -safe]
proc slave_after args {
puts "debug: [info level 0]"
set i [lindex $args 0]
if {[lindex $args 1] != "info"} {
store_after_script [lindex $args 0] [clock seconds] [lrange $args 1 end]
}
set tmp $i
lappend tmp "invokehidden"
lappend tmp "after"
foreach arg [lrange $args 1 end] { lappend tmp $arg }
puts "debug:\t \$tmp = [list $tmp]"
eval $tmp
}
$i hide after
$i alias after slave_after $i
comment {Then set up probe procedures for dumping the state of the slave interp.
}
#proc store_after_script {interp when_invoked args} {
# puts "debug: [info level 0]"
# variable after_scripts
# set first [lindex $args 0]
# if {[string is digit $first]} {
# while {[string length $first] < 4} {
# prepend first "0"
# }
# append after_scripts($interp) "when \{\[clock seconds\] > ($when_invoked +"
# append after_scripts($interp) " [string range $first 0 end-3])\} \{\n"
# append after_scripts($interp) " after [string range $first end-2 end] [list [lindex [lindex $args 1] 1]]\n"
# append after_scripts($interp) "\} 1000\n"
# } else {
# append after_scripts($interp) "when \{\[clock seconds\] > $when_invoked \} \{\n after "
# foreach arg $args {
# append after_scripts($interp) $arg
# append after_scripts($interp) " "
# }
# append after_scritps($interp) "\n\}\n"
# }
#}
proc store_after_script {interp when_invoked args} {
puts "debug: [info level 0]"
variable after_scripts
append after_scripts($interp) "reschedule_after_script $when_invoked [list $args]\n"
}
proc capture_after_scripts {interp} {
set res {
proc when {condition body {interval 1000}} {
if $condition $body else {
after $interval [info level 0]
}
}
}
variable after_scripts
if {[info exists after_scritps($interp)]} {
append res $after_scripts($interp)
}
return $res
}
# a helper functions:
proc interp_ns {interp namespace script} {
return [$interp eval [list namespace eval $namespace $script]]
}
proc list_vars {interp namespace} {
set globals [interp_ns $interp $namespace {info globals}]
if {$namespace == {}} { set globals {} }
set vars [interp_ns $interp $namespace {info vars}]
return [lexclude $globals $vars]
}
proc capture_vars {interp {namespace {}}} {
set vars [list_vars $interp $namespace]
set tmp "# variables: \n"
append tmp "namespace eval [list $namespace] \{\n"
foreach var $vars {
if {[interp_ns $interp $namespace [list array exists $var]]} {
append tmp "array set [list $var] [list [interp_ns $interp $namespace [list array get $var]]]\n"
} else {
append tmp "set [list $var] [list [interp_ns $interp $namespace [list set $var]]]\n"
}
}
append tmp "\}"
return $tmp
}
proc capture_procs {interp {namespace {}}} {
set procs [interp_ns $interp $namespace {info procs}]
set tmp "# procedures: \n"
append tmp "namespace eval [list $namespace] \{\n"
foreach proc $procs {
# dangerous asumption: expect that no variable will be named: {}
# why: because it's the only way to squease data out of [info default]
# proposed alt: add an -withDefaults to [info args]
set args [list]
foreach arg [interp_ns $interp $namespace [list info args $proc]] {
if {[interp_ns $interp $namespace [list info default $proc $arg {}]]} {
lappend args [list $arg [interp_ns $interp $namespace [list set {}]]]
} else {
lappend args $arg
}
catch { [interp_ns $interp $namespace [list unset {}]] }
}
set body [interp_ns $interp $namespace [list info body $proc]]
append tmp "proc [list $proc] [list $args] [list $body]\n"
}
append tmp "\}"
return $tmp
}
proc capture_varTraces {interp {namespace {}}} {
set vars [list_vars $interp $namespace]
set tmp "# traces on variables: \n"
append tmp "namespace eval [list $namespace] \{\n"
foreach var $vars {
set traces [interp_ns $interp $namespace [list trace info variable $var]]
foreach trace $traces {
append tmp "trace add variable [list $var] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
append tmp "\}"
return $tmp
}
proc capture_all {interp {namespace {}}} {
set tmp ""
if {$namespace == {}} {
append tmp "# Fascmile of interp state -BEGIN- \n"
}
append tmp "[capture_vars $interp $namespace]\n"
append tmp "[capture_procs $interp $namespace]\n"
append tmp "[capture_varTraces $interp $namespace]\n"
append tmp "[capture_after_scripts $interp]\n"
set children [$interp eval [list namespace children $namespace]]
if {[llength $children] > 0} {
foreach child $children {
append tmp [capture_all $interp $child]
}
}
if {$namespace == {}} {
append tmp "# Fascmile of interp state -END- \n"
}
return $tmp
}
proc update_replicas args {
puts "debug: [info level 0]"
variable channels_to_Replicas'_masters
foreach chan [set channels_to_Replicas'_masters] {
catch {
puts $chan "cause [list $args]"
flush $chan
}
}
}
comment {Next handle incoming requests from other instances of the same replicated slave interp
}
proc connection_handler {sock} {
variable buffers
append buffers($sock) [gets $sock]
append buffers($sock) "\n"
if {[info complete $buffers($sock)]} {
switch -exact -- [lindex $buffers($sock) 0] {
"cause" {
variable i
if {[lsearch [$i hidden] [lindex [lindex $buffers($sock) 1] 0]] != -1} {
set tmp $i
lappend tmp "invokehidden"
foreach item [lindex $buffers($sock) 1] { lappend tmp $item }
eval $tmp
} else {
$i eval [lindex $buffers($sock) 1]
}
}
"gimme_snapshot" {
variable i
set tmp [capture_all $i]
catch {
puts $sock "snapshot [list $tmp]"
flush $sock
}
}
}
unset buffers($sock)
}
if {[eof $sock]} { close $sock; return }
}
comment {Not fully tested yet
I am thinking I am aproaching this proplem from a wrong perspective.
Lars H, 20 June 2005: Maybe if you gave more of an explanation of how it's supposed to work someone could lend a hand. For starters, what's the idea behind doing something special with after? It's probably a key part of the approach, but to what end isn't terribly clear from the above.
As an aside, the many
puts "debug: ..."
lines are better coded like e.g.
putdebug ...
with
proc putdebug {str} {puts "debug: $str"}as they can then easily be disabled by a simple
proc putdebug {str} {}when you're not debugging.
Zarutian 22 june 2005: Well the basic idea is to store the starting state of an object (here an slave interp), instancenate an object by using that state (replicate the object) and synchronise these two (or more) replicas together by sending external influences to all replicas in the same sequence as they occur (from some coordnator's point of view which could be the origin replica of a given external influence). How's that for a sentence ;-)
Why I have such an intrest in after is that unfired after-scripts are part of the slave's interp state.
}
comment {Zarutian 19 june 2005 23:23 : Something like this would be cleaner:
proc makeReplicatedSafeInterp {sync_proc {seed -1}} {
proc [lindex [info level 0] 0] [list sync_chan [list seed [incr seed]]] [info body [lindex [info level 0]]
set body {
# nearly instance variables ;-)
set body %body%
set sync_proc %sync_proc%
set sub_interp %sub_interp%
set state_log %state_log%
# stuff to save
set subst [list \%body\% $body \%sync_proc\% $sync_proc \%sub_interp\% $sub_interp \%state_log\% $state_log]
trace add execution [lindex [info level 0] 0] leave save_state
# initilize
set dispatch false
# method dispatch: (or nearly so)
switch -exact -- [lindex $args 0] {
"alias_called" {
set tmp $sub_interp
lappend tmp "invokehidden"
foreach arg [lrange $args 1 end] {
lappend tmp arg
}
eval $tmp
}
"eval" {
$sync_proc cause [lrange $args 1 end] [lindex [info level 0] 0]
set dispatch true
}
default { set dispatch true }
}
# save yourself!
proc [lindex [info level 0] 0] args [string map $subst $body]
if {$dispatch} {
set tmp $sub_interp
foreach arg $args {
lappend tmp $arg
}
return [eval $tmp]
}
}
set subst [list \%body\% $body \
\%sync_proc\% $sync_proc \
\%sub_interp\% $sub_interp \
]
proc "replicaInterp[set seed]" args [string map $subst $body]
}
proc save args {}
}}