proc tcl_safeCreateInterp {slave} {
global auto_path
interp create -safe $slave
interp eval $slave [list set auto_path $auto_path]
return [tcl_safeInitInterp $slave]
}
proc tcl_safeInitInterp {slave} {
upvar global tcl_library tk_library auto_path tcl_platform
interp alias $slave source {} tclSafeAliasSource $slave
interp alias $slave load {} tclSafeAliasLoad $slave
tclAliasSubset $slave file file dir.* join root.* ext.* tail \
path.* split
interp alias $slave exit {} tcl_safeDeleteInterp $slave
if {$tcl_platform(platform) == "macintosh"} {
if {[catch {interp eval $slave [list source -rsrc Init]}]} {
if {[catch {interp eval $slave \
[list source [file join $tcl_library init.tcl]]}]} {
error "can't source init.tcl into slave $slave"
}
}
} else {
if {[catch {interp eval $slave \
[list source [file join $tcl_library init.tcl]]}]} {
error "can't source init.tcl into slave $slave"
}
}
interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave
interp eval $slave {package unknown tclPkgUnknown}
interp eval $slave \
[list proc tclPkgSource {dir args} {
if {[llength $args] == 2} {
source [lindex $args 0] [lindex $args 1]
} else {
source [lindex $args 0]
}
}]
foreach varName \
{tcl_library tcl_version tcl_patchLevel \
tcl_platform(platform) auto_path} {
upvar interp eval $slave [list set $varName $var]
}
foreach {varName value} {
auto_noexec 1
errorCode {}
errorInfo {}
env() {}
argv0 {}
argv {}
argc 0
tcl_interactive 0
} {
interp eval $slave [list set $varName $value]
}
interp eval $slave {
if {![info exists auto_path]} {
set auto_path {}
}
}
if {[info exists tk_library]} {
interp eval $slave [list set tk_library $tk_library]
}
interp eval $slave [list proc auto_execok {name} {return {}}]
return $slave
}
proc tcl_safeDeleteInterp {slave args} {
upvar
if {[info exists state(policyLoaded)]} {
set policy $state(policyLoaded)
set proc ${policy}_PolicyCleanup
if {[string compare [info proc $proc] $proc] == 0} {
$proc $slave
}
}
catch {unset state}
catch {interp delete $slave}
return
}
proc tclSafeComputePolicyPath {} {
global auto_path tclSafeAutoPathComputed tclSafePolicyPath
set recompute 0
if {(![info exists tclSafePolicyPath]) ||
("$tclSafePolicyPath" == "")} {
set tclSafePolicyPath ""
set tclSafeAutoPathComputed ""
set recompute 1
}
if {"$tclSafeAutoPathComputed" != "$auto_path"} {
set recompute 1
set tclSafeAutoPathComputed $auto_path
}
if {$recompute == 1} {
set tclSafePolicyPath ""
foreach i $auto_path {
lappend tclSafePolicyPath [file join $i policies]
}
}
return $tclSafePolicyPath
}
proc tclSafeAliasSource {slave args} {
global auto_path errorCode errorInfo
if {[llength $args] == 2} {
if {[string compare "-rsrc" [lindex $args 0]] != 0} {
return -code error "incorrect arguments to source"
}
if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \
msg]} {
return -code error $msg
}
} else {
set file [lindex $args 0]
if {[catch {tclFileInPath $file $auto_path $slave} msg]} {
return -code error "permission denied"
}
set errorInfo ""
if {[catch {interp invokehidden $slave source $file} msg]} {
return -code error $msg
}
}
return $msg
}
proc tclSafeAliasLoad {slave file args} {
global auto_path
if {[llength $args] == 2} {
set other [lindex $args 1]
foreach x $slave y $other {
if {[string length $x] == 0} {
break
} elseif {[string compare $x $y] != 0} {
return -code error "permission denied"
}
}
set slave $other
}
if {[string length $file] && \
[catch {tclFileInPath $file $auto_path $slave} msg]} {
return -code error "permission denied"
}
if {[catch {
switch [llength $args] {
0 {
interp invokehidden $slave load $file
}
1 -
2 {
interp invokehidden $slave load $file [lindex $args 0]
}
default {
error "too many arguments to load"
}
}
} msg]} {
return -code error $msg
}
return $msg
}
proc tclFileInPath {file path slave} {
set realcheckpath [tclSafeCheckAutoPath $path $slave]
set pwd [pwd]
if {[file isdirectory $file]} {
error "$file: not found"
}
set parent [file dirname $file]
if {[catch {cd $parent} msg]} {
error "$file: not found"
}
set realfilepath [file split [pwd]]
foreach dir $realcheckpath {
set match 1
foreach a [file split $dir] b $realfilepath {
if {[string length $a] == 0} {
break
} elseif {[string compare $a $b] != 0} {
set match 0
break
}
}
if {$match} {
cd $pwd
return 1
}
}
cd $pwd
error "$file: not found"
}
proc tclSafeCheckAutoPath {path slave} {
global auto_path
upvar
if {![info exists state(expanded_auto_path)]} {
set state(cached_auto_path) $path
} elseif {"$state(cached_auto_path)" != "$path"} {
set state(cached_auto_path) $path
} else {
return $state(expanded_auto_path)
}
set pwd [pwd]
set state(expanded_auto_path) ""
foreach dir $state(cached_auto_path) {
if {![catch {cd $dir}]} {
lappend state(expanded_auto_path) [pwd]
}
}
cd $pwd
return $state(expanded_auto_path)
}
proc tclSafeAliasPkgUnknown {slave package version {exact {}}} {
tclSafeLoadPkg $slave $package $version $exact
}
proc tclSafeLoadPkg {slave package version exact} {
if {[string length $version] == 0} {
set version 1.0
}
tclSafeLoadPkgInternal $slave $package $version $exact 0
}
proc tclSafeLoadPkgInternal {slave package version exact round} {
global auto_path
upvar
if {$round == 1} {
tclSafeResearchPolicyPath
if {[tclSafeLoadPolicy $slave $package $version]} {
return
}
}
if [tclSafeLoadPolicy $slave $package $version] {
return
}
rename source source.orig
proc source {args} "upvar dir dir
interp eval [list $slave] tclPkgSource \[list \$dir\] \$args"
if [catch {tclPkgUnknown $package $version $exact} err] {
global errorInfo
rename source {}
rename source.orig source
error "$err\n$errorInfo"
}
rename source {}
rename source.orig source
if {$round == 0} {
set ifneeded \
[interp eval $slave [list package ifneeded $package $version]]
if {"$ifneeded" == ""} {
return [tclSafeLoadPkgInternal $slave $package $version $exact 1]
}
}
}
proc tclSafeResearchPolicyPath {} {
global tclSafePolicyPath auto_index auto_path
if {![info exists tclSafePolicyPath]} {
set tclSafePolicyPath ""
}
set oldPolicyPath $tclSafePolicyPath
set newPolicyPath [tclSafeComputePolicyPath]
if {"$newPolicyPath" == "$oldPolicyPath"} {
return
}
for {set i [expr [llength $newPolicyPath] - 1]} \
{$i >= 0} \
{incr i -1} {
set dir [lindex $newPolicyPath $i]
set file [file join $dir tclIndex]
if {[file exists $file]} {
if {[catch {source $file} msg]} {
puts stderr "error sourcing $file: $msg"
}
}
foreach file [lsort [glob -nocomplain [file join $dir *]]] {
if {[file isdir $file]} {
set dir $file
set file [file join $file tclIndex]
if {[file exists $file]} {
if {[catch {source $file} msg]} {
puts stderr "error sourcing $file: $msg"
}
}
}
}
}
}
proc tclSafeLoadPolicy {slave package version} {
upvar global auto_index
set proc ${package}_PolicyInit
if {[info command $proc] == "$proc" ||
[info exists auto_index($proc)]} {
if [info exists state(policyLoaded)] {
error "security policy $state(policyLoaded) already loaded"
}
$proc $slave $version
interp eval $slave [list package provide $package $version]
set state(policyLoaded) $package
return 1
} else {
return 0
}
}
proc tclSafeSubset {command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval {$command $subcommand} [lrange $args 1 end]]
}
error "not allowed to invoke subcommand $subcommand of $command"
}
proc tclAliasSubset {slave alias target args} {
set pat ^(; set sep ""
foreach sub $args {
append pat $sep$sub
set sep |
}
append pat )\$
interp alias $slave $alias {} tclSafeSubset $target $pat
}