summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog4
-rw-r--r--library/safe.tcl166
-rw-r--r--tests/safe.test19
3 files changed, 70 insertions, 119 deletions
diff --git a/ChangeLog b/ChangeLog
index 0ebdfc9..3608d79 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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