Zarutian: The code/and or text by Zarutian on this page is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/2.5/ or send a letter to Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA.
proc comment args {}
proc makeReplicatedInterp {sync_proc {seed -1}} {
proc [lindex [info level 0] 0] [list sync_proc [list seed [incr seed]]] [info body [lindex [info level 0] 0]]
set interp [interp create -safe]
foreach item { fconfigure tell seek puts gets fileevent after } {
catch { $interp hide $item }
}
$interp eval {
proc info_proc name {
set argl {}
foreach arg [info args $name] {
if [info default $name $arg df] { lappend arg $df }
lappend argl $arg
}
list $argl [info body $name]
}
proc info_getVar name {
# must give the whole name if var is an array
upvar $name tmp
set traceStorage [trace info variable tmp]
foreach trace $traceStorage {
trace remove variable $name [lindex $trace 0] [lindex $trace 1]
}
set res [set tmp]
foreach trace $traceStorage {
trace add variable $name [lindex $trace 0] [lindex $trace 1]
}
return $res
}
}
set body {
# assumes that the resulting proc will have args
set interp %interp%
set sync_proc %sync_proc%
set delegate [list]
switch -exact -- [lindex $args 0] {
"eval" {
set delegate [concat [list $interp eval] [lrange $args 1 end]]
$sync_proc [lindex [info level 0] 0] [lrange $args 1 end]]
}
"eval-without-sync" {
set delegate [concat [list $interp eval] [lrange $args 1 end]]
}
"delete" {
interp delete $interp
}
"snapshot" {
set stack {}
set namespaces [list]
set body {
foreach ns [$interp eval [list namespace children [lindex $stack end]]] {
lappend stack $ns
eval $body
set stack [lrange $stack 0 end-1]
}
lappend namespaces [lindex $stack end]
}
eval $body
set res "# -Snapshot begins-\n"
foreach ns $namespaces {
append res "namespace eval [list $ns] \{\n"
# variables:
set vars [$interp eval [list namespace eval $ns [list info vars]]]
if {$ns != {}} {
set globals [$interp eval [list namespace eval $ns [list info globals]]]
set tmp [list]
foreach var $vars {
if {[lsearch -exact $globals $var] == -1} { lappend tmp $var }
}
set vars $tmp
}
foreach var $vars {
set fullname "[set ns]::[set var]"
if {[$interp eval [list array exists $fullname]]} {
foreach name [$interp eval [list array names $fullname]] {
set tmp "[set fullname]([set name])"
append res " set [list [set tmp]] [list [$interp eval [list info_getVar $tmp]]]\n"
}
} else {
append res " set [list [set var]] [list [$interp eval [list info_getVar $fullname]]]\n"
}
}
# procedures:
set procs [$interp eval [list namespace eval $ns [list info procs]]]
foreach proc $procs {
set fullname "[set ns]::[set proc]"
set lambda [$interp eval [list info_proc $fullname]]
append res " proc [list $proc] [list [lindex $lambda 0]] [list [lindex $lambda 1]]\n"
}
append res "\}\n"
# traces:
foreach var $vars {
set fullname "[set ns]::[set var]"
foreach trace [$interp eval [list trace info variable $fullname]] {
append res "trace add variable [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
foreach proc $procs {
set fullname "[set ns]::[set proc]"
foreach trace [$interp eval [list trace info command $fullname]] {
append res "trace add command [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
foreach trace [$interp eval [list trace info execution $fullname]] {
append res "trace add execution [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
}
append res "# -Snapshot ends-\n"
return $res
}
}
if {$delegate != {}} { return [eval $delegate] }
}
set id "replicatedInterp[set seed]"
proc $id args [string map [list %interp% $interp %sync_proc% $sync_proc] $body]
return $id
}Zarutian 27. june 2005: what I have been working with:
wm withdraw .
proc comment args {}
proc getCallstack {} {
set level [info level]
set tmp [list]
for {set i 0} { $i <= $level } { incr i } {
lappend tmp [info level $i]
}
return $tmp
}
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 ]
}
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 lremove {list item} {
set r [lsearch -exact $list $item]
return [lreplace $list $r $r]
}
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" {
set dispatch "return"
lappend dispatch $state_log
}
"alias_called" {
set dispatch $sub_interp
lappend dispatch "invokehidden"
set dispatch [lcombine $dispatch [lrange $args 1 end]]
# save_state doesn't work well with recursive functions I see
upvar state_log state_log2
lappend state_log2 [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]]
if {[llength $dispatch] > 0} {
set code [catch { eval $dispatch } res]
$sync_proc expected [lrange $args 1 end] $code $res [lindex [info level 0] 0]
}
}
"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
}
proc snapshotToTclScript {snapshot} {
# attemp 1
# this procedure is too big break it up into sub procedures
set variables() ""
set procedures() ""
set tracers_for_variables() ""
set tracers_for_commands() ""
set tracers_for_executions() ""
foreach item $snapshot {
set timestamp [lindex $item 0]
set command [lindex $item 1]
if {([lindex $command 0] == "set") && ([llength $command] == 3)} {
set variables([lindex $command 1]) [lindex $command 2]
} elseif {([lindex $command 0] == "unset") && ([llengthh $command] == 2)} {
unset variables([lindex $command 1])
} elseif {[lindex $command 0] == "array"} {
set arrayName [lindex $command 2]
if {[lindex $command 1] == "set"} {
foreach {name value} [lindex $command 3] {
set variables([set arrayName]([set name])) [set value]
}
} elseif {[lindex $command 1] == "unset"} {
foreach {name value} [array get variables] {
if {[string match "[set arrayName](*)" $name]} {
unset variables([set name])
}
}
}
} elseif {[lindex $command 0] == "proc"} {
# doesnt gets the namespace in which the proc was defined in
set procedures([lindex $command 1]) [list [lindex $command 2] [lindex $command 3]]
} elseif {[lindex $command 0] == "rename"} {
if {[lindex $command 2] == ""} {
unset procedures([lindex $command 1])
} else {
set tmp procedures([lindex $command 1])
unset procedures([lindex $command 1])
set procedures([lindex $command 2]) $tmp
}
} elseif {[lindex $command 0] == "trace"} {
set name [lindex $command 3]
set ops [lindex $command 4]
set cmd [lindex $command 5]
if {[lindex $command 1] == "add"} {
if {[lindex $command 2] == "command"} {
lappend tracers_for_commands($name) [list $ops $cmd]
} elseif {[lindex $command 2] == "execution"} {
lappend tracers_for_executions($name) [list $ops $cmd]
} elseif {[lindex $command 2] == "variable"} {
lappend tracers_for_variables($name) [list $ops $cmd]
}
} elseif {[lindex $command 1] == "remove"} {
if {[lindex $command 2] == "command"} {
set tracers_for_commands($name) [lremove $tracers_for_commands($name) [list $ops $cmd]]
} elseif {[lindex $command 2] == "execution"} {
set tracers_for_executions($name) [lremove $tracers_for_executions($name) [list $ops $cmd]]
} elseif {[lindex $command 2] == "variable"} {
set tracers_for_variables($name) [lremove $tracers_for_variables($name) [list $ops $cmd]]
}
} else {
# for the deprecaded trace commands, not supported
}
} elseif {[lindex $command 0] == "after"} {
# how shall I implement this?
# implemented as: when \{([clock_millisec] + $interval) < \[clock_millisec\]\} $body
# where $interval is the interval that after must wait and $body is the script body
# which will fire when the after fires?
# problem: if the above method is used then timing of two concurrent animation will
# be thrown right out of the window
}
}
set res "# Snapshot -begin-\n"
append res "# variables:\n"
foreach {key value} [array get variables] {
append res "set [list [set key]] [list [set value]]\n"
}
append res "# procedures:\n"
foreach {key value} [array get procedures] {
append res "proc [list [set key]] [list [lindex $value 0]] [list [lindex $value 1]]\n"
}
append res "# tracers for variables:\n"
foreach {key value} [array get tracers_for_variables] {
foreach trace $value {
append res "trace add variable [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
append res "# tracers for commands:\n"
foreach {key value} [array get tracers_for_commands] {
foreach trace $value {
append res "trace add command [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
append res "# tracers for executions:\n"
foreach {key value} [array get tracers_for_executions] {
foreach trace $value {
append res "trace add execution [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
}
}
append res "# Snapshot -end-\n"
return [set res]
}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 through 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
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
}Zarutian 2005-06-19: 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 $iThen 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
}
}
}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 }
}Not fully tested yet
I am thinking I am aproaching this proplem from a wrong perspective.
Lars H 2005-06-20: 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 interest in after is that unfired after-scripts are part of the slave's interp state.
Zarutian 2005-06-199 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 {}