diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | library/init.tcl | 4 | ||||
| -rw-r--r-- | library/safe.tcl | 140 | ||||
| -rw-r--r-- | library/tm.tcl | 14 | ||||
| -rw-r--r-- | tests/safe.test | 18 |
5 files changed, 160 insertions, 23 deletions
@@ -1,3 +1,10 @@ +2008-06-25 Andreas Kupries <andreask@activestate.com> + + * library/tm.tcl: Modified the handling of Tcl Modules and of the + * library/safe.tcl: Safe Base to interact nicely with each other, + * library/init.tcl: enabling requiring Tcl Modules in safe + * tests/safe.test: interpreters. Fixes [Bug 1999119]. + 2008-06-25 Don Porter <dgp@users.sourceforge.net> *** 8.6a1 TAGGED FOR RELEASE *** diff --git a/library/init.tcl b/library/init.tcl index 83981ae..3a3b105 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.106 2008/06/19 15:37:04 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.107 2008/06/25 17:40:03 andreas_kupries Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -156,7 +156,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { if {[interp issafe]} { - package unknown ::tclPkgUnknown + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} } else { # Set up search for Tcl Modules (TIP #189). # and setup platform specific unknown package handlers diff --git a/library/safe.tcl b/library/safe.tcl index 186c2e7..afdf639 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.tcl,v 1.16 2006/11/03 00:34:52 hobbs Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.17 2008/06/25 17:40:03 andreas_kupries Exp $ # # The implementation is based on namespaces. These naming conventions @@ -369,9 +369,21 @@ namespace eval ::safe { lappend slave_auto_path "\$[PathToken $i]" incr i } + # Extend the access list with the paths used to look for Tcl + # Modules. We safe the virtual form separately as well, as + # syncing it with the slave has to be defered until the + # necessary commands are present for setup. + foreach dir [::tcl::tm::list] { + lappend access_path $dir + Set [PathToken $i $slave] $dir + lappend slave_auto_path "\$[PathToken $i]" + lappend slave_tm_path "\$[PathToken $i]" + incr i + } Set $nname $i Set [PathListName $slave] $access_path Set [VirtualPathListName $slave] $slave_auto_path + Set [TmPathListName $slave] $slave_tm_path Set [StaticsOkName $slave] $staticsok Set [NestedOkName $slave] $nestedok @@ -448,6 +460,10 @@ proc ::safe::interpAddToAccessPath {slave path} { ::interp alias $slave encoding {} [namespace current]::AliasEncoding \ $slave + # Handling Tcl Modules, we need a restricted form of Glob. + ::interp alias $slave glob {} [namespace current]::AliasGlob \ + $slave + # This alias lets the slave have access to a subset of the 'file' # command functionality. @@ -463,8 +479,8 @@ proc ::safe::interpAddToAccessPath {slave path} { # by Tcl_MakeSafe(3) - # Source init.tcl into the slave, to get auto_load and other - # procedures defined: + # Source init.tcl and tm.tcl into the slave, to get auto_load + # and other procedures defined: if {[catch {::interp eval $slave\ {source [file join $tcl_library init.tcl]}} msg]} { @@ -472,6 +488,16 @@ proc ::safe::interpAddToAccessPath {slave path} { error "can't source init.tcl into slave $slave ($msg)" } + if {[catch {::interp eval $slave \ + {source [file join $tcl_library tm.tcl]}} msg]} { + Log $slave "can't source tm.tcl ($msg)" + error "can't source tm.tcl into slave $slave ($msg)" + } + + # Sync the paths used to search for Tcl modules. This can be + # done only now, after tm.tcl was loaded. + ::interp eval $slave [list ::tcl::tm::add {*}[Set [TmPathListName $slave]]] + return $slave } @@ -610,6 +636,10 @@ proc ::safe::setLogCmd {args} { proc VirtualPathListName {slave} { return "[InterpStateName $slave](access_path_slave)" } + # returns the variable name of the complete tm path list + proc TmPathListName {slave} { + return "[InterpStateName $slave](tm_path_slave)" + } # returns the variable name of the number of items proc PathNumberName {slave} { return "[InterpStateName $slave](access_path,n)" @@ -707,19 +737,96 @@ proc ::safe::setLogCmd {args} { } } + # AliasGlob is the target of the "glob" alias in safe interpreters. + + proc AliasGlob {slave args} { + Log $slave "GLOB ! $args" NOTICE + set cmd {} + set at 0 + + set dir {} + set virtualdir {} + + while {$at < [llength $args]} { + switch -glob -- [set opt [lindex $args $at]] { + -nocomplain - + -join { lappend cmd $opt ; incr at } + -directory { + lappend cmd $opt ; incr at + set virtualdir [lindex $args $at] + + # get the real path from the virtual one. + if {[catch {set dir [TranslatePath $slave $virtualdir]} msg]} { + Log $slave $msg + return -code error "permission denied" + } + # check that the path is in the access path of that slave + if {[catch {DirInAccessPath $slave $dir} msg]} { + Log $slave $msg + return -code error "permission denied" + } + lappend cmd $dir ; incr at + } + pkgIndex.tcl { + # Oops, this is globbing a subdirectory in regular + # package search. That is not wanted. Abort, + # handler does catch already (because glob was not + # defined before). See package.tcl, lines 484ff in + # tclPkgUnknown. + error "unknown command glob" + } + -* { + Log $slave "Safe base rejecting glob option '$opt'" + error "Safe base rejecting glob option '$opt'" + } + default { + lappend cmd $opt ; incr at + } + } + } + + Log $slave "GLOB = $cmd" NOTICE + + if {[catch {::interp invokehidden $slave glob {*}$cmd} msg]} { + Log $slave $msg + return -code error "script error" + } + + Log $slave "GLOB @ $msg" NOTICE + + # Translate path back to what the slave should see. + set res {} + foreach p $msg { + regsub -- ^$dir $p $virtualdir p + lappend res $p + } + + Log $slave "GLOB @ $res" NOTICE + return $res + } # AliasSource is the target of the "source" alias in safe interpreters. proc AliasSource {slave args} { set argc [llength $args] - # Allow only "source filename" + # Extended for handling of Tcl Modules to allow not only + # "source filename", but "source -encoding E filename" as + # well. + if {[lindex $args 0] eq "-encoding"} { + incr argc -2 + set encoding [lrange $args 0 1] + set at 2 + } else { + set at 0 + set encoding {} + } if {$argc != 1} { - set msg "wrong # args: should be \"source fileName\"" + set msg "wrong # args: should be \"source ?-encoding E? fileName\"" Log $slave "$msg ($args)" return -code error $msg } - set file [lindex $args 0] + set file [lindex $args $at] # get the real path from the virtual one. if {[catch {set file [TranslatePath $slave $file]} msg]} { @@ -740,7 +847,7 @@ proc ::safe::setLogCmd {args} { } # passed all the tests , lets source it: - if {[catch {::interp invokehidden $slave source $file} msg]} { + if {[catch {::interp invokehidden $slave source {*}$encoding $file} msg]} { Log $slave $msg return -code error "script error" } @@ -840,6 +947,25 @@ proc ::safe::setLogCmd {args} { } } + proc DirInAccessPath {slave dir} { + set access_path [GetAccessPath $slave] + + if {[file isfile $dir]} { + error "\"$dir\": is a file" + } + + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_dir [file normalize $dir] + foreach path $access_path { + lappend norm_access_path [file normalize $path] + } + + if {[lsearch -exact $norm_access_path $norm_dir] == -1} { + error "\"$dir\": not in access_path" + } + } + # This procedure enables access from a safe interpreter to only a subset of # the subcommands of a command: diff --git a/library/tm.tcl b/library/tm.tcl index aee74f5..f6ffe5d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -214,11 +214,11 @@ proc ::tcl::tm::UnknownHandler {original name args} { set satisfied 0 foreach path $paths { - if {![file exists $path]} { + if {![interp issafe] && ![file exists $path]} { continue } set currentsearchpath [file join $path $pkgroot] - if {![file exists $currentsearchpath]} { + if {![interp issafe] && ![file exists $currentsearchpath]} { continue } set strip [llength [file split $path]] @@ -352,9 +352,13 @@ proc ::tcl::tm::roots {paths} { foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { - path add [file normalize [file join $p ${major}.${n}]] + set px [file join $p ${major}.${n}] + if {![interp issafe]} { set px [file normalize $px] } + path add $px } - path add [file normalize [file join $p site-tcl]] + set px [file join $p site-tcl] + if {![interp issafe]} { set px [file normalize $px] } + path add $px } return } @@ -362,4 +366,4 @@ proc ::tcl::tm::roots {paths} { # Initialization. Set up the default paths, then insert the new # handler into the chain. -::tcl::tm::Defaults +if {![interp issafe]} { ::tcl::tm::Defaults } diff --git a/tests/safe.test b/tests/safe.test index e1b4a36..fb66f8c 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.22 2006/12/05 18:45:51 andreas_kupries Exp $ +# RCS: @(#) $Id: safe.test,v 1.23 2008/06/25 17:40:05 andreas_kupries Exp $ package require Tcl 8.5 @@ -89,7 +89,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} { set l [lsort [a aliases]] safe::interpDelete a set l -} {clock encoding exit file load source} +} {clock encoding exit file glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} { catch {safe::interpDelete a} safe::interpCreate a @@ -201,7 +201,7 @@ test safe-7.1 {tests that everything works at high level} { safe::interpDelete $i set v } 1.0 -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -213,7 +213,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] -} "{\$p(:0:)} {\$p(:1:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:17:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" # test source control on file name @@ -224,7 +224,7 @@ test safe-8.1 {safe source control on file} { list [catch {$i eval {source}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} test safe-8.2 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -232,7 +232,7 @@ test safe-8.2 {safe source control on file} { list [catch {$i eval {source}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} test safe-8.3 {safe source control on file} { set i "a"; catch {safe::interpDelete $i} @@ -315,7 +315,7 @@ test safe-8.8 {safe source forbids -rsrc} { list [catch {$i eval {source -rsrc Init}} msg] \ $msg \ [safe::interpDelete $i] ; -} {1 {wrong # args: should be "source fileName"} {}} +} {1 {wrong # args: should be "source ?-encoding E? fileName"} {}} test safe-9.1 {safe interps' deleteHook} { set i "a"; @@ -364,7 +364,7 @@ test safe-9.5 {dual specification of nested} { list [catch {safe::interpCreate -nested 0 -nestedload} msg] $msg } {1 {conflicting values given for -nested and -nestedLoadOk}} -test safe-9.6 {interpConfigure widget like behaviour} { +test safe-9.6 {interpConfigure widget like behaviour} -body { # this test shall work, don't try to "fix it" unless # you *really* know what you are doing (ie you are me :p) -- dl list [set i [safe::interpCreate \ @@ -381,7 +381,7 @@ test safe-9.6 {interpConfigure widget like behaviour} { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0; safe::interpConfigure $i] -} {{-accessPath /foo/bar -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath /foo/bar} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath /blah -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath /blah -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} # testing that nested and statics do what is advertised # (we use a static package : Tcltest) |