# VERSION 1.3
# Code below by Zarutian is under the Creative Commons SH-BY lisence.
# Contact him if any other lisence is required.
proc makeSerializableSafeSlaveInterp {interp} {
interp create $interp -safe
foreach command [$interp eval {info commands}] {
$interp hide $command
$interp alias $command passThrough $interp $command
}
$interp alias rename slaveRename $interp
}
proc passThrough args {
set interp [lindex $args 0]
set command [lindex $args 1]
set args [lrange $args 2 end]
set temp [list $interp invokehidden [set command]]
foreach arg $args {
lappend temp $arg
}
return [eval $temp]
}
proc slaveRename args {
set interp [lindex $args 0]
set oldname [lindex $args 1]
set newname [lindex $args 2]
if {[$interp invokehidden info procs $oldname] != {}} {
return [$interp invokehidden rename $oldname $newname]
}
$interp invokehidden rename $oldname {}
$interp alias $newname passThrough $interp $oldname
}
proc serializeInterp {interp {ns {}}} {
set result [list]
if {$ns == {}} {
if {[llength [interp invokehidden $interp -global file channels]] > 0} {
error "cant serialize an interp that has IO channels open!"
}
}
set vars [interp invokehidden $interp -global info vars [set ns]::*]
foreach var $vars {
if {[$interp invokehidden -global array exists $var]} {
lappend result [list array $var [interp invokehidden $interp -global array get $var]]
} else {
lappend result [list scalar $var [interp invokehidden $interp -global set $var]]
}
}
set procs [interp invokehidden $interp -global info procs [set ns]::*]
foreach proc $procs {
lappend result [list proc $proc [interp invokehidden $interp -global info args $proc] [interp invokehidden $interp -global info body $proc]]
}
foreach item [interp aliases $interp] {
#set alias [interp alias $interp $item]
# if {([lindex $alias 0] == "passThrough") && \
# ([lindex $alias 1] == $interp) && \
# ([lindex $alias 2] != $item) && \
# ([interp target $interp] == {}} {
# lappend result [list mapping $item [lindex $alias 2]]
#}
lappend result [list alias $item [interp target $interp $item] [interp alias $interp $item]]
}
set packages [interp invokehidden $interp -global package names]
foreach name $packages {
set versions [interp invokehidden $interp -global package versions $name]
if {[llength $versions] == 0} {
set versions [interp invokehidden $interp -global package present $name]
}
foreach version $versions {
set script [interp invokehidden $interp -global package ifneeded $name $version]
set present [interp invokehidden $interp -global package present $name $version]
lappend result [list package $name $version $script $present]
}
}
foreach child [interp invokehidden $interp -global namespace children $ns] {
foreach item [serializeInterp $interp $child] { lappend result $item }
}
foreach slave [interp slaves $interp] {
lappend result [list slave_interp $slave [serializeInterp [join $interp $slave]]]
}
return $result
}
proc deserializeInterp {interp state} {
foreach item $state {
set op [lindex $item 0]
switch -exact -- $op {
"array" {
set name [lindex $item 1]
set data [lindex $item 2]
interp invokehidden $interp -global array set $name $data
}
"scalar" {
set name [lindex $item 1]
set data [lindex $item 2]
interp invokehidden $interp -global set $name $data
}
"proc" {
set name [lindex $item 1]
set args [lindex $item 2]
set body [lindex $item 3]
interp invokehidden $interp -global proc $name $args $body
}
#"mapping" {
# # set newname [lindex $item 1]
# # set oldname [lindex $item 2]
# # interp alias $interp $newname {} passThrough $interp $oldname
#}
"slave_interp" {
set name [lindex $item 1]
set data [lindex $item 2]
deserializeInterp [join $interp $name] $data
}
"alias" {
# possible security hole if state is passed through 3rd party
# and not verified agenst hash-key or public key on return
set slavecommand [lindex $item 1]
set target [lindex $item 2]
set command&args [lrange $item 3 end]
set t [list interp alias $interp $slavecommand $target]
foreach item [set command&args] { lappend t $item }
eval $t
}
"invoked" {
# mainly used when the slave isnt allways running
# and one is using journaling to keep track of the state
set command&args [lindex $item 1]
interp eval $interp [set command&args]
}
"package" {
set name [lindex $item 1]
set version [lindex $item 2]
set script [lindex $item 3]
set present [lindex $item 4]
interp invokehidden $interp -global package ifneeded $name $version $script]
}
default { error "deserializeInterp: unknown op [lindex $item 0]"}
}
}
}Zarutian 3. August 2006: the above code has been tested somewhat, but not extensivelyRS 2006-08-14: Note that this code from above set name [lindex $item 1]
set version [lindex $item 2]
set script [lindex $item 3]
set present [lindex $item 4]can also be written as foreach {- name version script present} $item breakMatter of style, and taste, of course... :^)schlenk 2006-08-14: And if you're up for using Tcl 8.5 you can use lassign for the same.Zarutian 7. december 2006: I am still figuring out how I can serialize the slave interp's callstack. (So I can use interp limit to implement preemptive scheduling of running tasks)See also safe, interp slaves and Safe Interps.
