From 1ccff541fe927c0214548f5717ad58bede0d22eb Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 16 Dec 2009 23:44:15 +0000 Subject: Upgrade to Safe Base's handling of [glob] to be more permissive with the feature set supported, but stricter with path management. It also now has an error pattern more like the standard [glob] command. --- ChangeLog | 22 +++++++----- library/safe.tcl | 101 +++++++++++++++++++++++++++++++++++++++++-------------- tests/safe.test | 37 +++++++++++++++++++- 3 files changed, 126 insertions(+), 34 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2940341..c62b2ac 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,13 +1,19 @@ +2009-12-16 Donal K. Fellows + + * library/safe.tcl (::safe::AliasGlob): Upgrade to correctly support a + larger fraction of [glob] functionality, while being stricter about + directory management. + 2009-12-11 Jan Nijtmans - * generic/tclTest.c: Fix gcc warning: ignoring return value of ‘write’, - * unix/tclUnixNotify.c declared with attribute warn_unused_result - * unix/tclUnixPipe.c - * generic/tclInt.decls CONSTify functions TclpGetUserHome and - * generic/tclIntDecls.h TclSetPreInitScript (TIP #27) - * generic/tclInterp.c - * win/tclWinFile.c - * unix/tclUnixFile.c + * generic/tclTest.c: Fix gcc warning: ignoring return value of + * unix/tclUnixNotify.c: ‘write’, declared with attribute + * unix/tclUnixPipe.c: warn_unused_result. + * generic/tclInt.decls: CONSTify functions TclpGetUserHome and + * generic/tclIntDecls.h:TclSetPreInitScript (TIP #27) + * generic/tclInterp.c: + * win/tclWinFile.c: + * unix/tclUnixFile.c: 2009-12-16 Donal K. Fellows diff --git a/library/safe.tcl b/library/safe.tcl index 8bc26f9..6d896ea 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.34 2009/12/03 15:49:22 dkf Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.35 2009/12/16 23:44:15 dkf Exp $ # # The implementation is based on namespaces. These naming conventions are @@ -651,34 +651,48 @@ 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 {} set at 0 + array set got { + -directory 0 + -nocomplain 0 + -join 0 + -tails 0 + -- 0 + } + + if {$::tcl_platform(platform) eq "windows"} { + set dirPartRE {^(.*)[\\/]} + } else { + set dirPartRE {^(.*)/} + } set dir {} set virtualdir {} while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - - -join { + -nocomplain - -- - -join - -tails { lappend cmd $opt + set got($opt) 1 + incr at + } + -types - -type { + lappend cmd -types [lindex $args [incr at]] incr at } -directory { - set virtualdir [lindex $args [incr at]] - # Get the real path from the virtual one and check that the - # path is in the access path of that slave. - try { - set dir [TranslatePath $slave $virtualdir] - DirInAccessPath $slave $dir - } on error msg { - Log $slave $msg - return -code error "permission denied" + if {$got($opt)} { + return -code error \ + {"-directory" cannot be used with "-path"} } - lappend cmd -directory $dir + set got($opt) 1 + set virtualdir [lindex $args [incr at]] incr at + lappend cmd -directory $dir } pkgIndex.tcl { # Oops, this is globbing a subdirectory in regular package @@ -692,26 +706,60 @@ proc ::safe::AliasGlob {slave args} { return -code error "Safe base rejecting glob option '$opt'" } default { - if {[regexp {(.*)[\\/]} $opt -> thedir]} { - try { - DirInAccessPath $slave [TranslatePath $slave $thedir] - } on error msg { - Log $slave $msg - return -code error "permission denied" - } + break + } + } + if {$got(--) || $got(-join)} break + } + + # Get the real path from the virtual one and check that the path is in the + # access path of that slave. Done after basic argument processing so that + # we know if -nocomplain is set. + if {$got(-directory)} { + try { + set dir [TranslatePath $slave $virtualdir] + DirInAccessPath $slave $dir + } on error msg { + Log $slave $msg + if {$got(-nocomplain)} { + return + } + return -code error "permission denied" + } + } + + # Apply the -join semantics ourselves + if {$got(-join)} { + set args [lreplace $args $at end [join [lrange $args $at end] "/"]] + } + + # 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 } - lappend cmd $opt - incr at + return -code error "permission denied" } } + lappend cmd $opt } Log $slave "GLOB = $cmd" NOTICE + if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + return + } try { ::interp invokehidden $slave glob {*}$cmd - } on ok msg { - # Nothing to be done, just capture the 'msg' for later. } on error msg { Log $slave $msg return -code error "script error" @@ -721,8 +769,11 @@ proc ::safe::AliasGlob {slave args} { # Translate path back to what the slave should see. set res {} + set l [string length $dir] foreach p $msg { - regsub -- ^$dir $p $virtualdir p + if {[string equal -length $l $dir $p]} { + set p [string replace $p 0 [expr {$l-1}] $virtualdir] + } lappend res $p } diff --git a/tests/safe.test b/tests/safe.test index c8e170f..3e451d4 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.28 2009/12/03 15:49:22 dkf Exp $ +# RCS: @(#) $Id: safe.test,v 1.29 2009/12/16 23:44:15 dkf Exp $ package require Tcl 8.5 @@ -498,6 +498,41 @@ test safe-12.1 {glob is restricted [Bug 2906841]} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result "permission denied" +test safe-12.2 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob -directory .. * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result "permission denied" +test safe-12.3 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob -join .. * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result "permission denied" +test safe-12.4 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob -nocomplain ../* +} -cleanup { + safe::interpDelete $i +} -result {} +test safe-12.5 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob -directory .. -nocomplain * +} -cleanup { + safe::interpDelete $i +} -result {} +test safe-12.6 {glob is restricted [Bug 2906841]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob -nocomplain -join .. * +} -cleanup { + safe::interpDelete $i +} -result {} set ::auto_path $saveAutoPath # cleanup -- cgit v0.12