diff options
Diffstat (limited to 'library/safe.tcl')
| -rw-r--r-- | library/safe.tcl | 108 |
1 files changed, 87 insertions, 21 deletions
diff --git a/library/safe.tcl b/library/safe.tcl index d28573b..25bd020 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -83,6 +83,7 @@ proc ::safe::interpCreate {args} { set autoPath {} } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + RejectExcessColons $slave set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpCreate $slave $accessPath \ @@ -98,6 +99,8 @@ proc ::safe::interpInit {args} { if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + RejectExcessColons $slave + set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpInit $slave $accessPath \ [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath @@ -105,7 +108,7 @@ proc ::safe::interpInit {args} { # Check that the given slave is "one of us" proc ::safe::CheckInterp {slave} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {![info exists state] || ![::interp exists $slave]} { return -code error \ "\"$slave\" is not an interpreter managed by ::safe::" @@ -135,7 +138,7 @@ proc ::safe::interpConfigure {args} { # checks for the "-help" option. set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set TMP [list \ [list -accessPath $state(access_path)] \ @@ -164,7 +167,7 @@ proc ::safe::interpConfigure {args} { return -code error [::tcl::OptFlagUsage $desc $arg] } CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] @@ -213,7 +216,7 @@ proc ::safe::interpConfigure {args} { # create did set Args [::tcl::OptKeyParse ::safe::interpIC $args] CheckInterp $slave - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Get the current (and not the default) values of whatever has # not been given: @@ -321,8 +324,10 @@ proc ::safe::InterpCreate { withAutoPath } { # Create the slave. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. if {$slave ne ""} { - ::interp create -safe $slave + namespace eval :: [list ::interp create -safe $slave] } else { # empty argument: generate slave name set slave [::interp create -safe] @@ -391,7 +396,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au Log $slave "Setting auto_path=($raw_auto_path)" NOTICE } - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # clear old autopath if it existed # build new one @@ -529,7 +534,8 @@ proc ::safe::DetokPath {slave tokenPath} { # # When debugging, use TranslatePath for the inverse operation. proc ::safe::interpFindInAccessPath {slave path} { - namespace upvar ::safe S$slave state + CheckInterp $slave + namespace upvar ::safe [VarName $slave] state if {![dict exists $state(access_path,remap) $path]} { return -code error "$path not found in access path" @@ -546,7 +552,8 @@ proc ::safe::interpFindInAccessPath {slave path} { proc ::safe::interpAddToAccessPath {slave path} { # first check if the directory is already in there # (inlined interpFindInAccessPath). - namespace upvar ::safe S$slave state + CheckInterp $slave + namespace upvar ::safe [VarName $slave] state if {[dict exists $state(access_path,remap) $path]} { return [dict get $state(access_path,remap) $path] @@ -647,7 +654,7 @@ proc ::safe::InterpInit { # Sync the paths used to search for Tcl modules. This can be done only # now, after tm.tcl was loaded. - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {[llength $state(tm_path_slave)] > 0} { ::interp eval $slave [list \ ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] @@ -679,12 +686,16 @@ proc ::safe::AddSubDirs {pathList} { } # This procedure deletes a safe slave managed by Safe Tcl and cleans up -# associated state: +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". proc ::safe::interpDelete {slave} { Log $slave "About to delete" NOTICE - namespace upvar ::safe S$slave state + # CheckInterp $slave + namespace upvar ::safe [VarName $slave] state # When an interpreter is deleted with [interp delete], any sub-interpreters # are deleted automatically, but this leaves behind their data in the Safe @@ -692,7 +703,7 @@ proc ::safe::interpDelete {slave} { # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp slaves $slave] { - if {[info exists ::safe::S[list $slave $sub]]} { + if {[info exists ::safe::[VarName [list $slave $sub]]]} { ::safe::interpDelete [list $slave $sub] } } @@ -768,7 +779,7 @@ proc ::safe::setLogCmd {args} { # proc ::safe::SyncAccessPath {slave} { variable AutoPathSync - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set slave_access_path $state(access_path,slave) if {$AutoPathSync} { @@ -798,7 +809,7 @@ proc ::safe::PathToken {n} { # translate virtual path into real path # proc ::safe::TranslatePath {slave path} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : @@ -1066,12 +1077,15 @@ proc ::safe::AliasSource {slave args} { return -code error "permission denied" } - # do the checks on the filename : + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. if {[catch { CheckFileName $slave $realfile } msg]} { Log $slave "$realfile:$msg" - return -code error $msg + return -code error -errorcode {POSIX EACCES} $msg } # Passed all the tests, lets source it. Note that we do this all manually @@ -1116,7 +1130,7 @@ proc ::safe::AliasLoad {slave file args} { # package name (can be empty if file is not). set package [lindex $args 0] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state # Determine where to load. load use a relative interp path and {} # means self, so we can directly and safely use passed arg. @@ -1178,7 +1192,7 @@ proc ::safe::AliasLoad {slave file args} { # the security here relies on "file dirname" answering the proper # result... needs checking ? proc ::safe::FileInAccessPath {slave file} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set access_path $state(access_path) if {[file isdirectory $file]} { @@ -1190,14 +1204,14 @@ proc ::safe::FileInAccessPath {slave file} { # potential pathname anomalies. set norm_parent [file normalize $parent] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {$norm_parent ni $state(access_path,norm)} { return -code error "\"$file\": not in access_path" } } proc ::safe::DirInAccessPath {slave dir} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set access_path $state(access_path) if {[file isfile $dir]} { @@ -1208,7 +1222,7 @@ proc ::safe::DirInAccessPath {slave dir} { # potential pathname anomalies. set norm_dir [file normalize $dir] - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state if {$norm_dir ni $state(access_path,norm)} { return -code error "\"$dir\": not in access_path" } @@ -1249,6 +1263,58 @@ proc ::safe::AliasExeName {slave} { return "" } +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$slave state +# becomes +# namespace upvar ::safe [VarName $slave] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {slave} { + set stripped [regsub -all -- {:::*} $slave ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $slave} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {slave} { + # return S$slave + return S[string map {:: @N @ @A} $slave] +} + proc ::safe::Setup {} { #### # |