summaryrefslogtreecommitdiffstats
path: root/library/safe.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/safe.tcl')
-rw-r--r--library/safe.tcl113
1 files changed, 60 insertions, 53 deletions
diff --git a/library/safe.tcl b/library/safe.tcl
index 95db3b2..2dd4aed 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -151,18 +151,10 @@ proc ::safe::interpConfigure {args} {
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
- -accessPath {
- return [list -accessPath $state(access_path)]
- }
- -statics {
- return [list -statics $state(staticsok)]
- }
- -nested {
- return [list -nested $state(nestedok)]
- }
- -deleteHook {
- return [list -deleteHook $state(cleanupHook)]
- }
+ -accessPath {return [list -accessPath $state(access_path)]}
+ -statics {return [list -statics $state(staticsok)]}
+ -nested {return [list -nested $state(nestedok)]}
+ -deleteHook {return [list -deleteHook $state(cleanupHook)]}
-noStatics {
# it is most probably a set in fact but we would need
# then to jump to the set part and it is not *sure*
@@ -200,7 +192,7 @@ proc ::safe::interpConfigure {args} {
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
- } then {
+ } {
set statics $state(staticsok)
} else {
set statics [InterpStatics]
@@ -208,7 +200,7 @@ proc ::safe::interpConfigure {args} {
if {
[::tcl::OptProcArgGiven -nested] ||
[::tcl::OptProcArgGiven -nestedLoadOk]
- } then {
+ } {
set nested [InterpNested]
} else {
set nested $state(nestedok)
@@ -499,7 +491,8 @@ proc ::safe::InterpInit {
# now, after tm.tcl was loaded.
namespace upvar ::safe S$slave state
if {[llength $state(tm_path_slave)] > 0} {
- ::interp eval $slave [list ::tcl::tm::add {*}$state(tm_path_slave)]
+ ::interp eval $slave [list \
+ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
}
return $slave
}
@@ -545,9 +538,9 @@ proc ::safe::interpDelete {slave} {
# remove the hook now, otherwise if the hook calls us somehow,
# we'll loop
unset state(cleanupHook)
- try {
+ if {[catch {
{*}$hook $slave
- } on error err {
+ } err]} {
Log $slave "Delete hook error ($err)"
}
}
@@ -665,7 +658,6 @@ proc ::safe::CheckFileName {slave file} {
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
-
proc ::safe::AliasGlob {slave args} {
Log $slave "GLOB ! $args" NOTICE
set cmd {}
@@ -679,9 +671,9 @@ proc ::safe::AliasGlob {slave args} {
}
if {$::tcl_platform(platform) eq "windows"} {
- set dirPartRE {^(.*)[\\/]}
+ set dirPartRE {^(.*)[\\/]([^\\/]*)$}
} else {
- set dirPartRE {^(.*)/}
+ set dirPartRE {^(.*)/([^/]*)$}
}
set dir {}
@@ -729,10 +721,10 @@ proc ::safe::AliasGlob {slave args} {
# access path of that slave. Done after basic argument processing so that
# we know if -nocomplain is set.
if {$got(-directory)} {
- try {
+ if {[catch {
set dir [TranslatePath $slave $virtualdir]
DirInAccessPath $slave $dir
- } on error msg {
+ } msg]} {
Log $slave $msg
if {$got(-nocomplain)} {
return
@@ -749,20 +741,32 @@ proc ::safe::AliasGlob {slave args} {
# Process remaining pattern arguments
set firstPattern [llength $cmd]
- while {$at < [llength $args]} {
- set opt [lindex $args $at]
- incr at
- if {[regexp $dirPartRE $opt -> thedir]} {
- try {
- set thedir [file join $virtualdir $thedir]
- DirInAccessPath $slave [TranslatePath $slave $thedir]
- } on error msg {
- Log $slave $msg
- if {$got(-nocomplain)} {
- continue
+ foreach opt [lrange $args $at end] {
+ if {![regexp $dirPartRE $opt -> thedir thefile]} {
+ set thedir .
+ }
+ if {$thedir eq "*"} {
+ set mapped 0
+ foreach d [glob -directory [TranslatePath $slave $virtualdir] \
+ -types d -tails *] {
+ catch {
+ DirInAccessPath $slave \
+ [TranslatePath $slave [file join $virtualdir $d]]
+ if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} {
+ lappend cmd [file join $d $thefile]
+ set mapped 1
+ }
}
- return -code error "permission denied"
}
+ if {$mapped} continue
+ }
+ if {[catch {
+ set thedir [file join $virtualdir $thedir]
+ DirInAccessPath $slave [TranslatePath $slave $thedir]
+ } msg]} {
+ Log $slave $msg
+ if {$got(-nocomplain)} continue
+ return -code error "permission denied"
}
lappend cmd $opt
}
@@ -772,26 +776,26 @@ proc ::safe::AliasGlob {slave args} {
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
- try {
- set entries [::interp invokehidden $slave glob {*}$cmd]
- } on error msg {
+ if {[catch {
+ ::interp invokehidden $slave glob {*}$cmd
+ } msg]} {
Log $slave $msg
return -code error "script error"
}
- Log $slave "GLOB @ $entries" NOTICE
+ Log $slave "GLOB < $msg" NOTICE
# Translate path back to what the slave should see.
set res {}
set l [string length $dir]
- foreach p $entries {
+ foreach p $msg {
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
}
lappend res $p
}
- Log $slave "GLOB @ $res" NOTICE
+ Log $slave "GLOB > $res" NOTICE
return $res
}
@@ -819,7 +823,7 @@ proc ::safe::AliasSource {slave args} {
return -code error $msg
}
set file [lindex $args $at]
-
+
# get the real path from the virtual one.
if {[catch {
set realfile [TranslatePath $slave $file]
@@ -827,7 +831,7 @@ proc ::safe::AliasSource {slave args} {
Log $slave $msg
return -code error "permission denied"
}
-
+
# check that the path is in the access path of that slave
if {[catch {
FileInAccessPath $slave $realfile
@@ -914,28 +918,30 @@ proc ::safe::AliasLoad {slave file args} {
# file loading
# get the real path from the virtual one.
- try {
+ if {[catch {
set file [TranslatePath $slave $file]
- } on error msg {
+ } msg]} {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
- try {
+ if {[catch {
FileInAccessPath $slave $file
- } on error msg {
+ } msg]} {
Log $slave $msg
return -code error "permission denied (path)"
}
}
- try {
- return [::interp invokehidden $slave load $file $package $target]
- } on error msg {
+ if {[catch {
+ ::interp invokehidden $slave load $file $package $target
+ } msg]} {
Log $slave $msg
return -code error $msg
}
+
+ return $msg
}
# FileInAccessPath raises an error if the file is not found in the list of
@@ -1015,14 +1021,15 @@ proc ::safe::AliasEncoding {slave option args} {
}
if {[string equal -length [string length $option] $option "system"]} {
- if {![llength $args]} {
+ if {[llength $args] == 0} {
# passed all the tests , lets source it:
- try {
- return [::interp invokehidden $slave encoding system]
- } on error msg {
+ if {[catch {
+ set sysenc [::interp invokehidden $slave encoding system]
+ } msg]} {
Log $slave $msg
return -code error "script error"
}
+ return $sysenc
}
set msg "wrong # args: should be \"encoding system\""
set code {TCL WRONGARGS}
generated by cgit v0.12 at 2025-12-21 01:42:55 (GMT)