diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | library/init.tcl | 4 | ||||
| -rw-r--r-- | library/safe.tcl | 150 | ||||
| -rw-r--r-- | library/tm.tcl | 14 |
4 files changed, 157 insertions, 19 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 + interpreters. Fixes [Bug 1999119]. + 2008-06-25 Don Porter <dgp@users.sourceforge.net> * changes: Update for 8.5.3 release. @@ -13,6 +20,7 @@ Tcl_ObjType for the empty string value. Problem led to a crash in the command [glob -dir {} a]. [Bug 1999176]. +>>>>>>> 1.3975.2.48 2008-06-23 Don Porter <dgp@users.sourceforge.net> * generic/tclPathObj.c: Fixed bug in Tcl_GetTranslatedPath() when diff --git a/library/init.tcl b/library/init.tcl index 306d7d9..63f36ff 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.104.2.1 2008/04/11 18:12:29 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.104.2.2 2008/06/25 16:42:04 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..501a552 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.16.4.1 2008/06/25 16:42:05 andreas_kupries Exp $ # # The implementation is based on namespaces. These naming conventions @@ -369,12 +369,24 @@ 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 [TmPathListName $slave] $slave_tm_path Set $nname $i - Set [PathListName $slave] $access_path + Set [PathListName $slave] $access_path Set [VirtualPathListName $slave] $slave_auto_path - Set [StaticsOkName $slave] $staticsok - Set [NestedOkName $slave] $nestedok + Set [StaticsOkName $slave] $staticsok + Set [NestedOkName $slave] $nestedok Set [DeleteHookName $slave] $deletehook SyncAccessPath $slave @@ -439,7 +451,7 @@ proc ::safe::interpAddToAccessPath {slave path} { # NB we need to add [namespace current], aliases are always # absolute paths. ::interp alias $slave source {} [namespace current]::AliasSource $slave - ::interp alias $slave load {} [namespace current]::AliasLoad $slave + ::interp alias $slave load {} [namespace current]::AliasLoad $slave # This alias lets the slave use the encoding names, convertfrom, # convertto, and system, but not "encoding system <name>" to set @@ -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,15 +479,25 @@ 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\ + if {[catch {::interp eval $slave \ {source [file join $tcl_library init.tcl]}} msg]} { Log $slave "can't source init.tcl ($msg)" 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..4f58d12 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 } |