diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | library/safe.tcl | 166 | ||||
| -rw-r--r-- | tests/safe.test | 19 |
3 files changed, 70 insertions, 119 deletions
@@ -19,6 +19,10 @@ (7) Replaced the remaining uses of 'Set' and others outside of the path/token handling, and deleted a number of procedures related to state array access which are not used any longer. + (8) Converted the path token system to cache normalized paths and + path <-> token conversions. Removed more procedures not used any + longer. Removed the test cases 4.3 and 4.4 from safe.test. They + were testing the now deleted command "InterpStateName". 2009-11-02 Kevin B. Kenny <kennykb@acm.org> diff --git a/library/safe.tcl b/library/safe.tcl index c139f93..db4a41b 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.26 2009/11/05 20:04:41 andreas_kupries Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.27 2009/11/05 20:15:36 andreas_kupries Exp $ # # The implementation is based on namespaces. These naming conventions are @@ -277,11 +277,13 @@ proc ::safe::InterpCreate { # probably need to call "auto_reset" in the slave in order that it gets # the right auto_index() array values. -proc ::safe::InterpSetConfig {slave access_path staticsok\ - nestedok deletehook} { +proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { + global auto_path + # determine and store the access path if empty if {$access_path eq ""} { - set access_path [uplevel \#0 set auto_path] + set access_path $auto_path + # Make sure that tcl_library is in auto_path and at the first # position (needed by setAccessPath) set where [lsearch -exact $access_path [info library]] @@ -311,39 +313,43 @@ proc ::safe::InterpSetConfig {slave access_path staticsok\ InterpState $slave # clear old autopath if it existed - set nname [PathNumberName $slave] - if {[Exists $nname]} { - set n [Set $nname] - for {set i 0} {$i<$n} {incr i} { - Unset [PathToken $i $slave] - } - } - # build new one - set slave_auto_path {} - set i 0 - foreach dir $access_path { - Set [PathToken $i $slave] $dir - lappend slave_auto_path "\$[PathToken $i]" - incr i - } # Extend the access list with the paths used to look for Tcl Modules. # We save the virtual form separately as well, as syncing it with the # slave has to be defered until the necessary commands are present for # setup. + + set norm_access_path {} + set slave_access_path {} + set map_access_path {} + + set i 0 + foreach dir $access_path { + set token [PathToken $i] + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend norm_access_path [file normalize $dir] + incr i + } + + # NOTE / TODO : Prevent addition of dirs on the tm list if they + # are already on the result list, i.e. known. + 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]" + set token [PathToken $i] + lappend access_path $dir + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend norm_access_path [file normalize $dir] + lappend slave_tm_path $token incr i } - Set $nname $i set state(access_path) $access_path - set state(access_path_slave) $slave_auto_path + set state(access_path,map) $map_access_path + set state(access_path,norm) $norm_access_path + set state(access_path,slave) $slave_access_path set state(tm_path_slave) $slave_tm_path - set state(staticsok) $staticsok set state(nestedok) $nestedok set state(cleanupHook) $deletehook @@ -358,13 +364,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok\ # "$") proc ::safe::interpFindInAccessPath {slave path} { InterpState $slave - set access_path $state(access_path) - set where [lsearch -exact $access_path $path] - if {$where == -1} { + set where [lsearch -exact $state(access_path) $path] + if {$where < 0} { return -code error "$path not found in access path $access_path" } - return "\$[PathToken $where]" + return [PathToken $where] } # @@ -373,27 +378,24 @@ proc ::safe::interpFindInAccessPath {slave path} { # virtual token (including the "$"). proc ::safe::interpAddToAccessPath {slave path} { # first check if the directory is already in there - try { - # inline interpFindInAccessPath, avoid try/error - return [interpFindInAccessPath $slave $path] - } on error {} { - # new one, add it: - set nname [PathNumberName $slave] - set n [Set $nname] - Set [PathToken $n $slave] $path - - set token "\$[PathToken $n]" + # (inlined interpFindInAccessPath). + InterpState $slave - InterpState $slave - lappend state(access_path_slave) $token - lappend state(access_path) $path + set where [lsearch -exact $state(access_path) $path] + if {$where >= 0} { + return [PathToken $where] + } - Set $nname [expr {$n+1}] + # new one, add it: + set token [PathToken [llength $state(access_path)]] - SyncAccessPath $slave + lappend state(access_path) $path + lappend state(access_path,slave) $token + lappend state(access_path,map) $token $path + lappend state(access_path,norm) [file normalize $path] - return $token - } + SyncAccessPath $slave + return $token } # This procedure applies the initializations to an already existing @@ -558,7 +560,7 @@ proc ::safe::setLogCmd {args} { proc ::safe::SyncAccessPath {slave} { InterpState $slave - set slave_access_path $state(access_path_slave) + set slave_access_path $state(access_path,slave) ::interp eval $slave [list set auto_path $slave_access_path] Log $slave "auto_path in $slave has been set to $slave_access_path"\ @@ -572,14 +574,6 @@ proc ::safe::SyncAccessPath {slave} { set tcl_library [lindex $slave_access_path 0]] } -# Base name for storing all the slave states. The array variable name for -# slave foo is thus "Sfoo" and for sub slave {foo bar} "Sfoo bar" (spaces -# are handled ok everywhere (or should)). We add the S prefix to avoid -# that a slave interp called "Log" would smash our "Log" variable. -proc ::safe::InterpStateName {slave} { - return "S$slave" -} - # base name for storing all the slave states # the array variable name for slave foo is thus "Sfoo" # and for sub slave {foo bar} "Sfoo bar" (spaces are handled @@ -599,54 +593,28 @@ proc ::safe::IsInterp {slave} { return [expr {[info exists state] && [::interp exists $slave]}] } -# Returns the virtual token for directory number N. If the slave argument -# is given, it will return the corresponding master global variable name -proc ::safe::PathToken {n {slave ""}} { - if {$slave ne ""} { - return "[InterpStateName $slave](access_path,$n)" - } else { - # We need to have a ":" in the token string so [file join] on the - # mac won't turn it into a relative path. - return "p(:$n:)" - } -} -# returns the variable name of the number of items -proc ::safe::PathNumberName {slave} { - return "[InterpStateName $slave](access_path,n)" -} -# Run some code at the namespace toplevel -proc ::safe::Toplevel {args} { - namespace eval [namespace current] $args -} -# set/get values -proc ::safe::Set {args} { - Toplevel set {*}$args -} -# unset a var/token (currently just an global level eval) -proc ::safe::Unset {args} { - Toplevel unset {*}$args -} -# test existance -proc ::safe::Exists {varname} { - Toplevel info exists $varname +# Returns the virtual token for directory number N. +proc ::safe::PathToken {n} { + # We need to have a ":" in the token string so [file join] on the + # mac won't turn it into a relative path. + return "\$p(:$n:)" ;# Form tested by case 7.2 } # # translate virtual path into real path # proc ::safe::TranslatePath {slave path} { + InterpState $slave + # somehow strip the namespaces 'functionality' out (the danger is that # we would strip valid macintosh "../" queries... : if {[string match "*::*" $path] || [string match "*..*" $path]} { error "invalid characters in path $path" } - set n [expr {[Set [PathNumberName $slave]]-1}] - for {} {$n>=0} {incr n -1} { - # fill the token virtual names with their real value - set [PathToken $n] [Set [PathToken $n $slave]] - } - # replaces the token by their value - subst -nobackslashes -nocommands $path + + # Use a cached map instead of computed local vars and subst. + + return [string map $state(access_path,map) $path] } @@ -904,11 +872,9 @@ proc ::safe::FileInAccessPath {slave file} { # Normalize paths for comparison since lsearch knows nothing of # potential pathname anomalies. set norm_parent [file normalize $parent] - foreach path $access_path { - lappend norm_access_path [file normalize $path] - } - if {$norm_parent ni $norm_access_path} { + InterpState $slave + if {$norm_parent ni $state(access_path,norm)} { error "\"$file\": not in access_path" } } @@ -924,11 +890,9 @@ proc ::safe::DirInAccessPath {slave dir} { # 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 {$norm_dir ni $norm_access_path} { + InterpState $slave + if {$norm_dir ni $state(access_path,norm)} { error "\"$dir\": not in access_path" } } diff --git a/tests/safe.test b/tests/safe.test index 6368b83..22ef475 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.25 2008/10/14 17:17:46 dgp Exp $ +# RCS: @(#) $Id: safe.test,v 1.26 2009/11/05 20:15:36 andreas_kupries Exp $ package require Tcl 8.5 @@ -117,23 +117,6 @@ test safe-4.2 {safe::interpDelete, indirectly} { a alias exit safe::interpDelete a a eval exit } "" -test safe-4.3 {safe::interpDelete, state array (not a public api)} { - catch {safe::interpDelete a} - namespace eval safe {set [InterpStateName a](foo) 33} - # not an error anymore to call it if interp is already - # deleted, to make trhings smooth if it's called twice... - catch {safe::interpDelete a} m1 - catch {namespace eval safe {set [InterpStateName a](foo)}} m2 - list $m1 $m2 -} "{}\ - {can't read \"[safe::InterpStateName a](foo)\": no such variable}" -test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { - catch {safe::interpDelete a} - safe::interpCreate a - namespace eval safe {set [InterpStateName a](foo) 33} - a eval exit - catch {namespace eval safe {set [InterpStateName a](foo)}} msg -} 1 test safe-4.5 {safe::interpDelete} { catch {safe::interpDelete a} safe::interpCreate a |