aboutsummaryrefslogtreecommitdiff
path: root/contrib/tcl/library
diff options
context:
space:
mode:
authorPaul Traina <pst@FreeBSD.org>1997-11-27 19:49:05 +0000
committerPaul Traina <pst@FreeBSD.org>1997-11-27 19:49:05 +0000
commitf25b19db8d50748d4f75272ae324cad27788d9b3 (patch)
treecef0bba69f1833802f43364a0cde6945601e665a /contrib/tcl/library
parent539e1e66ff6f99c987c8e03872ddaea5260db8f7 (diff)
Import TCL v8.0 PL2.vendor/tcl
Notes
Notes: svn path=/vendor/tcl/dist/; revision=31434
Diffstat (limited to 'contrib/tcl/library')
-rw-r--r--contrib/tcl/library/http1.0/http.tcl8
-rw-r--r--contrib/tcl/library/http2.0/http.tcl8
-rw-r--r--contrib/tcl/library/init.tcl147
-rw-r--r--contrib/tcl/library/opt0.1/optparse.tcl43
-rw-r--r--contrib/tcl/library/opt0.1/pkgIndex.tcl2
-rw-r--r--contrib/tcl/library/safe.tcl285
-rw-r--r--contrib/tcl/library/tclIndex5
7 files changed, 396 insertions, 102 deletions
diff --git a/contrib/tcl/library/http1.0/http.tcl b/contrib/tcl/library/http1.0/http.tcl
index 450d6430cf5d..f6dd35131259 100644
--- a/contrib/tcl/library/http1.0/http.tcl
+++ b/contrib/tcl/library/http1.0/http.tcl
@@ -5,7 +5,7 @@
# These procedures use a callback interface to avoid using vwait,
# which is not defined in the safe base.
#
-# SCCS: @(#) http.tcl 1.8 97/07/22 13:37:20
+# SCCS: @(#) http.tcl 1.10 97/10/29 16:12:55
#
# See the http.n man page for documentation
@@ -279,14 +279,16 @@ proc http_size {token} {
httpFinish $token $err
}
}
- proc httpCopyDone {token count} {
+ proc httpCopyDone {token count {error {}}} {
upvar #0 $token state
set s $state(sock)
incr state(currentsize) $count
if [info exists state(-progress)] {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
- if [eof $s] {
+ if {([string length $error] != 0)} {
+ httpFinish $token $error
+ } elseif {[eof $s]} {
httpEof $token
} else {
httpCopyStart $s $token
diff --git a/contrib/tcl/library/http2.0/http.tcl b/contrib/tcl/library/http2.0/http.tcl
index 80fbfc672412..79c83c3885b3 100644
--- a/contrib/tcl/library/http2.0/http.tcl
+++ b/contrib/tcl/library/http2.0/http.tcl
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) http.tcl 1.6 97/08/07 16:48:32
+# SCCS: @(#) http.tcl 1.8 97/10/28 16:23:30
package provide http 2.0 ;# This uses Tcl namespaces
@@ -352,7 +352,7 @@ proc http::size {token} {
Finish $token $err
}
}
- proc http::CopyDone {token count} {
+ proc http::CopyDone {token count {error {}}} {
variable $token
upvar 0 $token state
set s $state(sock)
@@ -360,7 +360,9 @@ proc http::size {token} {
if [info exists state(-progress)] {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
- if [::eof $s] {
+ if {([string length $error] != 0)} {
+ Finish $token $error
+ } elseif {[::eof $s]} {
Eof $token
} else {
CopyStart $s $token
diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl
index 19852248363d..ebf1913a79af 100644
--- a/contrib/tcl/library/init.tcl
+++ b/contrib/tcl/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
+# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -19,6 +19,7 @@ package require -exact Tcl 8.0
# Compute the auto path to use in this interpreter.
# (auto_path could be already set, in safe interps for instance)
+
if {![info exists auto_path]} {
if [catch {set auto_path $env(TCLLIBPATH)}] {
set auto_path ""
@@ -28,17 +29,20 @@ if {[lsearch -exact $auto_path [info library]] < 0} {
lappend auto_path [info library]
}
catch {
- foreach dir $tcl_pkgPath {
- if {[lsearch -exact $auto_path $dir] < 0} {
- lappend auto_path $dir
+ foreach __dir $tcl_pkgPath {
+ if {[lsearch -exact $auto_path $__dir] < 0} {
+ lappend auto_path $__dir
}
}
- unset dir
+ unset __dir
}
-# Conditionalize for presence of exec.
+# Setup the unknown package handler
package unknown tclPkgUnknown
+
+# Conditionalize for presence of exec.
+
if {[info commands exec] == ""} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
@@ -58,6 +62,11 @@ if {[info commands tclLog] == ""} {
}
}
+# The procs defined in this file that have a leading space
+# are 'hidden' from auto_mkindex because they are not
+# auto-loadable.
+
+
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
@@ -78,7 +87,7 @@ if {[info commands tclLog] == ""} {
# args - A list whose elements are the words of the original
# command, including the command name.
-proc unknown args {
+ proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
@@ -97,7 +106,7 @@ proc unknown args {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
- set ret [catch {auto_load $name} msg]
+ set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
@@ -125,6 +134,7 @@ proc unknown args {
}
}
}
+
if {([info level] == 1) && ([info script] == "") \
&& [info exists tcl_interactive] && $tcl_interactive} {
if ![info exists auto_noexec] {
@@ -186,11 +196,21 @@ proc unknown args {
#
# Arguments:
# cmd - Name of the command to find and load.
+# namespace (optional) The namespace where the command is being used - must be
+# a canonical namespace as returned [namespace current]
+# for instance. If not given, namespace current is used.
-proc auto_load cmd {
+ proc auto_load {cmd {namespace {}}} {
global auto_index auto_oldpath auto_path env errorInfo errorCode
- foreach name [list $cmd ::$cmd] {
+ if {[string length $namespace] == 0} {
+ set namespace [uplevel {namespace current}]
+ }
+ set nameList [auto_qualify $cmd $namespace]
+ # workaround non canonical auto_index entries that might be around
+ # from older auto_mkindex versions
+ lappend nameList $cmd
+ foreach name $nameList {
if [info exists auto_index($name)] {
uplevel #0 $auto_index($name)
return [expr {[info commands $name] != ""}]
@@ -246,15 +266,76 @@ proc auto_load cmd {
}
}
}
- if [info exists auto_index($cmd)] {
- uplevel #0 $auto_index($cmd)
- if {[info commands $cmd] != ""} {
- return 1
+ foreach name $nameList {
+ if [info exists auto_index($name)] {
+ uplevel #0 $auto_index($name)
+ if {[info commands $name] != ""} {
+ return 1
+ }
}
}
return 0
}
+# auto_qualify --
+# compute a fully qualified names list for use in the auto_index array.
+# For historical reasons, commands in the global namespace do not have leading
+# :: in the index key. The list has two elements when the command name is
+# relative (no leading ::) and the namespace is not the global one. Otherwise
+# only one name is returned (and searched in the auto_index).
+#
+# Arguments -
+# cmd The command name. Can be any name accepted for command
+# invocations (Like "foo::::bar").
+# namespace The namespace where the command is being used - must be
+# a canonical namespace as returned by [namespace current]
+# for instance.
+
+ proc auto_qualify {cmd namespace} {
+
+ # count separators and clean them up
+ # (making sure that foo:::::bar will be treated as foo::bar)
+ set n [regsub -all {::+} $cmd :: cmd]
+
+ # Ignore namespace if the name starts with ::
+ # Handle special case of only leading ::
+
+ # Before each return case we give an example of which category it is
+ # with the following form :
+ # ( inputCmd, inputNameSpace) -> output
+
+ if {[regexp {^::(.*)$} $cmd x tail]} {
+ if {$n > 1} {
+ # ( ::foo::bar , * ) -> ::foo::bar
+ return [list $cmd]
+ } else {
+ # ( ::global , * ) -> global
+ return [list $tail]
+ }
+ }
+
+ # Potentially returning 2 elements to try :
+ # (if the current namespace is not the global one)
+
+ if {$n == 0} {
+ if {[string compare $namespace ::] == 0} {
+ # ( nocolons , :: ) -> nocolons
+ return [list $cmd]
+ } else {
+ # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
+ return [list ${namespace}::$cmd $cmd]
+ }
+ } else {
+ if {[string compare $namespace ::] == 0} {
+ # ( foo::bar , :: ) -> ::foo::bar
+ return [list ::$cmd]
+ } else {
+ # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
+ return [list ${namespace}::$cmd ::$cmd]
+ }
+ }
+}
+
if {[string compare $tcl_platform(platform) windows] == 0} {
# auto_execok --
@@ -382,7 +463,7 @@ proc auto_reset {} {
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
- tclPkgUnknown} $p] < 0)} {
+ tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
@@ -395,7 +476,9 @@ proc auto_reset {} {
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files.
+# locate all of the relevant files. It does not parse or source the file
+# so the generated index will not contain the appropriate namespace qualifiers
+# if you don't explicitly specify it.
#
# Arguments:
# dir - Name of the directory in which to create an index.
@@ -424,6 +507,7 @@ proc auto_mkindex {dir args} {
set f [open $file]
while {[gets $f line] >= 0} {
if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
+ set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
@@ -515,6 +599,13 @@ proc pkg_mkIndex {dir args} {
default { eval package-orig {$what} $args }
}
}
+ proc pkgGetAllNamespaces {{root {}}} {
+ set list $root
+ foreach ns [namespace children $root] {
+ eval lappend list [pkgGetAllNamespaces $ns]
+ }
+ return $list
+ }
package unknown dummy
set origCmds [info commands]
set dir "" ;# in case file is pkgIndex.tcl
@@ -540,7 +631,7 @@ proc pkg_mkIndex {dir args} {
source $file
set type source
}
- foreach ns [namespace children] {
+ foreach ns [pkgGetAllNamespaces] {
namespace import ${ns}::*
}
foreach i [info commands] {
@@ -633,7 +724,7 @@ proc tclMacPkgSearch {dir} {
foreach y [resource list TEXT $res] {
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
}
- resource close $res
+ catch {resource close $res}
}
}
}
@@ -652,14 +743,11 @@ proc tclMacPkgSearch {dir} {
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
- global auto_path tcl_platform env dir
+ global auto_path tcl_platform env
if ![info exists auto_path] {
return
}
- if {[info exists dir]} {
- set save_dir $dir
- }
for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
# we can't use glob in safe interps, so enclose the following
# in a catch statement
@@ -686,17 +774,12 @@ proc tclPkgUnknown {name version {exact {}}} {
if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
- foreach x [glob -nocomplain [file join $dir *]] {
- if [file isdirectory $x] {
- set dir $x
- tclMacPkgSearch $dir
- }
+ foreach x [glob -nocomplain [file join $dir *]] {
+ if [file isdirectory $x] {
+ set dir $x
+ tclMacPkgSearch $dir
}
+ }
}
}
- if {[info exists save_dir]} {
- set dir $save_dir
- } else {
- unset dir
- }
}
diff --git a/contrib/tcl/library/opt0.1/optparse.tcl b/contrib/tcl/library/opt0.1/optparse.tcl
index ee5b399ee6eb..12135da0ff60 100644
--- a/contrib/tcl/library/opt0.1/optparse.tcl
+++ b/contrib/tcl/library/opt0.1/optparse.tcl
@@ -13,9 +13,9 @@
# written initially with Brent Welch, itself initially
# based on work with Steve Uhler. Thanks them !
#
-# SCCS: @(#) optparse.tcl 1.11 97/08/11 16:39:15
+# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42
-package provide opt 0.1
+package provide opt 0.2
namespace eval ::tcl {
@@ -166,8 +166,12 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
# are we processing flags (which makes a single program step)
set inflags 0;
+
set state {};
+ # flag used to detect that we just have a single (flags set) subprogram.
+ set empty 1;
+
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
@@ -187,6 +191,7 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
# put the other regular stuff
lappend program $res;
set inflags 0;
+ set empty 0;
}
} else {
if {$state == "flags"} {
@@ -195,11 +200,18 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
set flagsprg [list [list "P" 1] $res];
} else {
lappend program $res;
+ set empty 0;
}
}
}
if {$inflags} {
- lappend program $flagsprg;
+ if {$empty} {
+ # We just have the subprogram, optimize and remove
+ # unneeded level:
+ set program $flagsprg;
+ } else {
+ lappend program $flagsprg;
+ }
}
set OptDesc($key) $program;
@@ -629,12 +641,27 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
set hits 0
set hitems {}
set i 1;
+
+ set larg [string tolower $arg];
+ set len [string length $larg];
+ set last [expr $len-1];
+
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
- if {[string match [string tolower $arg*] [string tolower $flag]]} {
- lappend hitems $i;
- incr hits;
+ # (string length ought to be cheap)
+ set lflag [string tolower $flag];
+ if {$len == [string length $lflag]} {
+ if {[string compare $larg $lflag]==0} {
+ # Exact match case
+ OptSetPrgCounter desc $i;
+ return 1;
+ }
+ } else {
+ if {[string compare $larg [string range $lflag 0 $last]]==0} {
+ lappend hitems $i;
+ incr hits;
+ }
}
incr i;
}
@@ -845,8 +872,8 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
[list $item]
}
-proc ::tcl::OptKeyError {prefix descKey} {
- OptError $prefix [OptKeyGetDesc $descKey];
+proc ::tcl::OptKeyError {prefix descKey {header 0}} {
+ OptError $prefix [OptKeyGetDesc $descKey] $header;
}
# determine string length for nice tabulated output
diff --git a/contrib/tcl/library/opt0.1/pkgIndex.tcl b/contrib/tcl/library/opt0.1/pkgIndex.tcl
index 4e660cd69872..7a7ad90cc054 100644
--- a/contrib/tcl/library/opt0.1/pkgIndex.tcl
+++ b/contrib/tcl/library/opt0.1/pkgIndex.tcl
@@ -4,4 +4,4 @@
# the package now, so they can readily use it
# and even "namespace import tcl::*" ...
# (tclPkgSetup just makes things slow and do not work so well with namespaces)
-package ifneeded opt 0.1 [list source [file join $dir optparse.tcl]]
+package ifneeded opt 0.2 [list source [file join $dir optparse.tcl]]
diff --git a/contrib/tcl/library/safe.tcl b/contrib/tcl/library/safe.tcl
index e923cc630d04..9b9352370092 100644
--- a/contrib/tcl/library/safe.tcl
+++ b/contrib/tcl/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.
#
-# SCCS: @(#) safe.tcl 1.21 97/08/13 15:37:22
+# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20
#
# The implementation is based on namespaces. These naming conventions
@@ -22,13 +22,13 @@
#
# Needed utilities package
-package require opt 0.1;
+package require opt 0.2;
# Create the safe namespace
namespace eval ::safe {
# Exported API:
- namespace export interp \
+ namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath \
setLogCmd ;
@@ -36,67 +36,245 @@ namespace eval ::safe {
proc ::safe::interpCreate {} {}
proc ::safe::interpInit {} {}
proc ::safe::interpConfigure {} {}
-proc ::safe::interpDelete {} {}
- # Interface/entry point function and front end for "Create"
- ::tcl::OptProc interpCreate {
- {?slave? -name {} "name of the slave (optional)"}
+ ####
+ #
+ # Setup the arguments parsing
+ #
+ ####
+
+ # Share the descriptions
+ set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
+ {-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
+ {-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
- } {
+ }]
+
+ # create case (slave is optional)
+ ::tcl::OptKeyRegister {
+ {?slave? -name {} "name of the slave (optional)"}
+ } ::safe::interpCreate ;
+ # adding the flags sub programs to the command program
+ # (relying on Opt's internal implementation details)
+ lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp);
+
+ # init and configure (slave is needed)
+ ::tcl::OptKeyRegister {
+ {slave -name {} "name of the slave"}
+ } ::safe::interpIC;
+ # adding the flags sub programs to the command program
+ # (relying on Opt's internal implementation details)
+ lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp);
+ # temp not needed anymore
+ ::tcl::OptKeyDelete $temp;
+
+
+ # Helper function to resolve the dual way of specifying staticsok
+ # (either by -noStatics or -statics 0)
+ proc InterpStatics {} {
+ foreach v {Args statics noStatics} {
+ upvar $v $v
+ }
+ set flag [::tcl::OptProcArgGiven -noStatics];
+ if {$flag && ($noStatics == $statics)
+ && ([::tcl::OptProcArgGiven -statics])} {
+ return -code error\
+ "conflicting values given for -statics and -noStatics";
+ }
+ if {$flag} {
+ return [expr {!$noStatics}];
+ } else {
+ return $statics
+ }
+ }
+
+ # Helper function to resolve the dual way of specifying nested loading
+ # (either by -nestedLoadOk or -nested 1)
+ proc InterpNested {} {
+ foreach v {Args nested nestedLoadOk} {
+ upvar $v $v
+ }
+ set flag [::tcl::OptProcArgGiven -nestedLoadOk];
+ # note that the test here is the opposite of the "InterpStatics"
+ # one (it is not -noNested... because of the wanted default value)
+ if {$flag && ($nestedLoadOk != $nested)
+ && ([::tcl::OptProcArgGiven -nested])} {
+ return -code error\
+ "conflicting values given for -nested and -nestedLoadOk";
+ }
+ if {$flag} {
+ # another difference with "InterpStatics"
+ return $nestedLoadOk
+ } else {
+ return $nested
+ }
+ }
+
+ ####
+ #
+ # API entry points that needs argument parsing :
+ #
+ ####
+
+
+ # Interface/entry point function and front end for "Create"
+ proc interpCreate {args} {
+ set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
InterpCreate $slave $accessPath \
- [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook;
}
- # Interface/entry point function and front end for "Init"
- ::tcl::OptProc interpInit {
- {slave -name {} "name of the slave"}
- {-accessPath -list {} "access path for the slave"}
- {-noStatics "prevent loading of statically linked pkgs"}
- {-nestedLoadOk "allow nested loading"}
- {-deleteHook -script {} "delete hook"}
- } {
+ proc interpInit {args} {
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args]
+ if {![::interp exists $slave]} {
+ return -code error \
+ "\"$slave\" is not an interpreter";
+ }
InterpInit $slave $accessPath \
- [expr {!$noStatics}] $nestedLoadOk $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook;
+ }
+
+ proc CheckInterp {slave} {
+ if {![IsInterp $slave]} {
+ return -code error \
+ "\"$slave\" is not an interpreter managed by ::safe::" ;
+ }
}
# Interface/entry point function and front end for "Configure"
- ::tcl::OptProc interpConfigure {
- {slave -name {} "name of the slave"}
- {-accessPath -list {} "access path for the slave"}
- {-noStatics "prevent loading of statically linked pkgs"}
- {-nestedLoadOk "allow nested loading"}
- {-deleteHook -script {} "delete hook"}
- } {
- # Check that at least one flag was given:
- if {[string match "*-*" $Args]} {
- # reconfigure everything (because otherwise you can't
- # change -noStatics for instance)
- InterpConfigure $slave $accessPath \
- [expr {!$noStatics}] $nestedLoadOk $deleteHook;
- # auto_reset the slave (to completly synch the new access_path)
- if {[catch {::interp eval $slave {auto_reset}} msg]} {
- Log $slave "auto_reset failed: $msg";
+ # This code is awfully pedestrian because it would need
+ # more coupling and support between the way we store the
+ # configuration values in safe::interp's and the Opt package
+ # Obviously we would like an OptConfigure
+ # to avoid duplicating all this code everywhere. -> TODO
+ # (the app should share or access easily the program/value
+ # stored by opt)
+ # This is even more complicated by the boolean flags with no values
+ # that we had the bad idea to support for the sake of user simplicity
+ # in create/init but which makes life hard in configure...
+ # So this will be hopefully written and some integrated with opt1.0
+ # (hopefully for tcl8.1 ?)
+ proc interpConfigure {args} {
+ switch [llength $args] {
+ 1 {
+ # If we have exactly 1 argument
+ # the semantic is to return all the current configuration
+ # We still call OptKeyParse though we know that "slave"
+ # is our given argument because it also checks
+ # for the "-help" option.
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args];
+ CheckInterp $slave;
+ set res {}
+ lappend res [list -accessPath [Set [PathListName $slave]]]
+ lappend res [list -statics [Set [StaticsOkName $slave]]]
+ lappend res [list -nested [Set [NestedOkName $slave]]]
+ lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
+ join $res
}
- } else {
- # none was given, lets return current values instead
- set res {}
- lappend res [list -accessPath [Set [PathListName $slave]]]
- if {![Set [StaticsOkName $slave]]} {
- lappend res "-noStatics"
+ 2 {
+ # If we have exactly 2 arguments
+ # the semantic is a "configure get"
+ ::tcl::Lassign $args slave arg;
+ # get the flag sub program (we 'know' about Opt's internal
+ # representation of data)
+ set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
+ set hits [::tcl::OptHits desc $arg];
+ if {$hits > 1} {
+ return -code error [::tcl::OptAmbigous $desc $arg]
+ } elseif {$hits == 0} {
+ return -code error [::tcl::OptFlagUsage $desc $arg]
+ }
+ CheckInterp $slave;
+ set item [::tcl::OptCurDesc $desc];
+ set name [::tcl::OptName $item];
+ switch -exact -- $name {
+ -accessPath {
+ return [list -accessPath [Set [PathListName $slave]]]
+ }
+ -statics {
+ return [list -statics [Set [StaticsOkName $slave]]]
+ }
+ -nested {
+ return [list -nested [Set [NestedOkName $slave]]]
+ }
+ -deleteHook {
+ return [list -deleteHook [Set [DeleteHookName $slave]]]
+ }
+ -noStatics {
+ # it is most probably a set in fact
+ # but we would need then to jump to the set part
+ # and it is not *sure* that it is a set action
+ # that the user want, so force it to use the
+ # unambigous -statics ?value? instead:
+ return -code error\
+ "ambigous query (get or set -noStatics ?)\
+ use -statics instead";
+ }
+ -nestedLoadOk {
+ return -code error\
+ "ambigous query (get or set -nestedLoadOk ?)\
+ use -nested instead";
+ }
+ default {
+ return -code error "unknown flag $name (bug)";
+ }
+ }
}
- if {[Set [NestedOkName $slave]]} {
- lappend res "-nestedLoadOk"
+ default {
+ # Otherwise we want to parse the arguments like init and create
+ # did
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args];
+ CheckInterp $slave;
+ # Get the current (and not the default) values of
+ # whatever has not been given:
+ if {![::tcl::OptProcArgGiven -accessPath]} {
+ set doreset 1
+ set accessPath [Set [PathListName $slave]]
+ } else {
+ set doreset 0
+ }
+ if { (![::tcl::OptProcArgGiven -statics])
+ && (![::tcl::OptProcArgGiven -noStatics]) } {
+ set statics [Set [StaticsOkName $slave]]
+ } else {
+ set statics [InterpStatics]
+ }
+ if { ([::tcl::OptProcArgGiven -nested])
+ || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
+ set nested [InterpNested]
+ } else {
+ set nested [Set [NestedOkName $slave]]
+ }
+ if {![::tcl::OptProcArgGiven -deleteHook]} {
+ set deleteHook [Set [DeleteHookName $slave]]
+ }
+ # we can now reconfigure :
+ InterpSetConfig $slave $accessPath \
+ $statics $nested $deleteHook;
+ # auto_reset the slave (to completly synch the new access_path)
+ if {$doreset} {
+ if {[catch {::interp eval $slave {auto_reset}} msg]} {
+ Log $slave "auto_reset failed: $msg";
+ } else {
+ Log $slave "successful auto_reset" NOTICE;
+ }
+ }
}
- lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
- join $res
}
}
+ ####
+ #
+ # Functions that actually implements the exported APIs
+ #
+ ####
+
+
#
# safe::InterpCreate : doing the real job
#
@@ -139,7 +317,7 @@ proc ::safe::interpDelete {} {}
#
- # InterpConfigure (was setAccessPath) :
+ # InterpSetConfig (was setAccessPath) :
# Sets up slave virtual auto_path and corresponding structure
# within the master. Also sets the tcl_library in the slave
# to be the first directory in the path.
@@ -147,7 +325,7 @@ proc ::safe::interpDelete {} {}
# you probably need to call "auto_reset" in the slave in order that it
# gets the right auto_index() array values.
- proc ::safe::InterpConfigure {slave access_path staticsok\
+ proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
@@ -259,7 +437,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# Configure will generate an access_path when access_path is
# empty.
- InterpConfigure $slave $access_path $staticsok $nestedok $deletehook;
+ InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook;
# These aliases let the slave load files to define new commands
@@ -336,7 +514,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# This procedure deletes a safe slave managed by Safe Tcl and
# cleans up associated state:
- proc ::safe::interpDelete {slave} {
+proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE;
@@ -395,7 +573,6 @@ proc ::safe::setLogCmd {args} {
# ------------------- END OF PUBLIC METHODS ------------
-
#
# sets the slave auto_path to the master recorded value.
# also sets tcl_library to the first token of the virtual path.
@@ -413,12 +590,18 @@ proc ::safe::setLogCmd {args} {
# 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.
+ # We add the S prefix to avoid that a slave interp called "Log"
+ # would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave";
}
+ # Check that the given slave is "one of us"
+ proc IsInterp {slave} {
+ expr { ([Exists [InterpStateName $slave]])
+ && ([::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
diff --git a/contrib/tcl/library/tclIndex b/contrib/tcl/library/tclIndex
index 7ef95630ceb5..e923ec9aa995 100644
--- a/contrib/tcl/library/tclIndex
+++ b/contrib/tcl/library/tclIndex
@@ -6,9 +6,6 @@
# element name is the name of a command and the value is
# a script that loads the command.
-set auto_index(unknown) [list source [file join $dir init.tcl]]
-set auto_index(auto_load) [list source [file join $dir init.tcl]]
-set auto_index(auto_execok) [list source [file join $dir init.tcl]]
set auto_index(auto_execok) [list source [file join $dir init.tcl]]
set auto_index(auto_reset) [list source [file join $dir init.tcl]]
set auto_index(auto_mkindex) [list source [file join $dir init.tcl]]
@@ -26,8 +23,8 @@ set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
+set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
set auto_index(history) [list source [file join $dir history.tcl]]
generated by cgit v1.2.3 (git 2.25.1) at 2025-06-08 01:12:43 +0000