diff options
Diffstat (limited to 'contrib/tcl/library/init.tcl')
| -rw-r--r-- | contrib/tcl/library/init.tcl | 147 |
1 files changed, 115 insertions, 32 deletions
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 - } } |