diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | library/safe.tcl | 102 | ||||
| -rw-r--r-- | tests/safe.test | 37 |
3 files changed, 117 insertions, 26 deletions
@@ -1,5 +1,9 @@ 2009-12-16 Donal K. Fellows <dkf@users.sf.net> + * library/safe.tcl (::safe::AliasGlob): Upgrade to correctly support a + larger fraction of [glob] functionality, while being stricter about + directory management. + * doc/tm.n: [Bug 1911342]: Formatting rewrite to avoid bogus crosslink to the list manpage when generating HTML. diff --git a/library/safe.tcl b/library/safe.tcl index 52b539b..3b9ee19 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.4.3 2009/12/09 22:34:20 andreas_kupries Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.16.4.4 2009/12/16 23:31:31 dkf Exp $ # # The implementation is based on namespaces. These naming conventions are @@ -655,30 +655,43 @@ 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 } - -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" + -types - -type { + lappend cmd -types [lindex $args [incr at]] + incr at + } + -directory { + 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,22 +705,58 @@ 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" - } - } - lappend cmd $opt - incr at + 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)} { + if {[catch { + set dir [TranslatePath $slave $virtualdir] + DirInAccessPath $slave $dir + } msg]} { + Log $slave $msg + if {!$got(-nocomplain)} { + return -code error "permission denied" + } else { + return } } } + # 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] && [catch { + set thedir [file join $virtualdir $thedir] + DirInAccessPath $slave [TranslatePath $slave $thedir] + } msg]} { + Log $slave $msg + if {$got(-nocomplain)} { + continue + } else { + return -code error "permission denied" + } + } + lappend cmd $opt + } + Log $slave "GLOB = $cmd" NOTICE + if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + return + } if {[catch { ::interp invokehidden $slave glob {*}$cmd } msg]} { @@ -719,8 +768,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 8c26d20..b7cb611 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.4.3 2009/12/16 14:04:05 dkf Exp $ +# RCS: @(#) $Id: safe.test,v 1.22.4.4 2009/12/16 23:31:31 dkf Exp $ package require Tcl 8.5 @@ -470,6 +470,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 |