diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 550 |
1 files changed, 77 insertions, 473 deletions
diff --git a/library/init.tcl b/library/init.tcl index ebf1913..8a89774 100644 --- a/library/init.tcl +++ b/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.95 97/11/19 17:16:34 +# SCCS: @(#) init.tcl 1.104 98/01/09 17:52:21 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -15,28 +15,79 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.0 +package require -exact Tcl 8.1 # Compute the auto path to use in this interpreter. -# (auto_path could be already set, in safe interps for instance) +# (auto_path could be already set, in safe interps for instance +# and some variables are usually exist might not be there, proceed +# with caution) if {![info exists auto_path]} { - if [catch {set auto_path $env(TCLLIBPATH)}] { + if {[catch {set auto_path $env(TCLLIBPATH)}]} { set auto_path "" } -} -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 + + if {[lsearch -exact $auto_path $tcl_library] < 0} { + lappend auto_path $tcl_library + } + + set __dir [file dirname $tcl_library] + + if {[lsearch -exact $auto_path $__dir] < 0} { + lappend auto_path $__dir + } + + # Add directories from the tcl_pkgPath + # (we might want to check the potential candidates in tcl_libPath too, + # and check that those dirs refer to compatible tcl versions + # (ie if they end with tcl7.6 we should prbably not add them)) + + if {[info exist tcl_pkgPath]} { + foreach __dir $tcl_pkgPath { + if {[lsearch -exact $auto_path $__dir] < 0} { + lappend auto_path $__dir + } } } + unset __dir } +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} { + namespace eval tcl { + proc envTraceProc {lo n1 n2 op} { + set x $::env($n2) + set ::env($lo) $x + set ::env([string toupper $lo]) $x + } + } + foreach p [array names env] { + set u [string toupper $p] + if {$u != $p} { + switch -- $u { + COMSPEC - + PATH { + if {![info exists env($u)]} { + set env($u) $env($p) + } + trace variable env($p) w [list tcl::envTraceProc $p] + trace variable env($u) w [list tcl::envTraceProc $p] + } + } + } + } + if {![info exists env(COMSPEC)]} { + if {$tcl_platform(os) == {Windows NT}} { + set env(COMSPEC) cmd.exe + } else { + set env(COMSPEC) command.com + } + } +} + + # Setup the unknown package handler package unknown tclPkgUnknown @@ -98,11 +149,11 @@ if {[info commands tclLog] == ""} { set savedErrorCode $errorCode set savedErrorInfo $errorInfo set name [lindex $args 0] - if ![info exists auto_noload] { + if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # - if [info exists unknown_pending($name)] { + if {[info exists unknown_pending($name)]} { return -code error "self-referential recursion in \"unknown\" for command \"$name\""; } set unknown_pending($name) pending; @@ -112,10 +163,10 @@ if {[info commands tclLog] == ""} { return -code $ret -errorcode $errorCode \ "error while autoloading \"$name\": $msg" } - if ![array size unknown_pending] { + if {![array size unknown_pending]} { unset unknown_pending } - if $msg { + if {$msg} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set code [catch {uplevel 1 $args} msg] @@ -126,7 +177,7 @@ if {[info commands tclLog] == ""} { # set new [split $errorInfo \n] - set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n] return -code error -errorcode $errorCode \ -errorinfo $new $msg } else { @@ -137,7 +188,7 @@ if {[info commands tclLog] == ""} { if {([info level] == 1) && ([info script] == "") \ && [info exists tcl_interactive] && $tcl_interactive} { - if ![info exists auto_noexec] { + if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new != ""} { set errorCode $savedErrorCode @@ -159,7 +210,7 @@ if {[info commands tclLog] == ""} { set newcmd [history event -1] catch {regsub -all -- $old $newcmd $new newcmd} } - if [info exists newcmd] { + if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 return [uplevel $newcmd] @@ -211,15 +262,15 @@ if {[info commands tclLog] == ""} { # from older auto_mkindex versions lappend nameList $cmd foreach name $nameList { - if [info exists auto_index($name)] { + if {[info exists auto_index($name)]} { uplevel #0 $auto_index($name) return [expr {[info commands $name] != ""}] } } - if ![info exists auto_path] { + if {![info exists auto_path]} { return 0 } - if [info exists auto_oldpath] { + if {[info exists auto_oldpath]} { if {$auto_oldpath == $auto_path} { return 0 } @@ -230,12 +281,12 @@ if {[info commands tclLog] == ""} { # newer format tclIndex files. set issafe [interp issafe] - for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { set dir [lindex $auto_path $i] set f "" if {$issafe} { catch {source [file join $dir tclIndex]} - } elseif [catch {set f [open [file join $dir tclIndex]]}] { + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { @@ -261,13 +312,13 @@ if {[info commands tclLog] == ""} { if {$f != ""} { close $f } - if $error { + if {$error} { error $msg $errorInfo $errorCode } } } foreach name $nameList { - if [info exists auto_index($name)] { + if {[info exists auto_index($name)]} { uplevel #0 $auto_index($name) if {[info commands $name] != ""} { return 1 @@ -336,450 +387,3 @@ if {[info commands tclLog] == ""} { } } -if {[string compare $tcl_platform(platform) windows] == 0} { - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - -# Windows version. -# -# Note that info executable doesn't work under Windows, so we have to -# look for files with .exe, .com, or .bat extensions. Also, the path -# may be in the Path or PATH environment variables, and path -# components are separated with semicolons, not colons as under Unix. -# -proc auto_execok name { - global auto_execs env tcl_platform - - if [info exists auto_execs($name)] { - return $auto_execs($name) - } - set auto_execs($name) "" - - if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename - ren rmdir rd time type ver vol} $name] != -1} { - return [set auto_execs($name) [list $env(COMSPEC) /c $name]] - } - - if {[llength [file split $name]] != 1} { - foreach ext {{} .com .exe .bat} { - set file ${name}${ext} - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - return "" - } - - set path "[file dirname [info nameof]];.;" - if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) - } - if {[info exists windir]} { - if {$tcl_platform(os) == "Windows NT"} { - append path "$windir/system32;" - } - append path "$windir/system;$windir;" - } - - if {[info exists env(PATH)]} { - append path $env(PATH) - } - - foreach dir [split $path {;}] { - if {$dir == ""} { - set dir . - } - foreach ext {{} .com .exe .bat} { - set file [file join $dir ${name}${ext}] - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - } - return "" -} - -} else { - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to an executable in the path. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - -# Unix version. -# -proc auto_execok name { - global auto_execs env - - if [info exists auto_execs($name)] { - return $auto_execs($name) - } - set auto_execs($name) "" - if {[llength [file split $name]] != 1} { - if {[file executable $name] && ![file isdirectory $name]} { - set auto_execs($name) [list $name] - } - return $auto_execs($name) - } - foreach dir [split $env(PATH) :] { - if {$dir == ""} { - set dir . - } - set file [file join $dir $name] - if {[file executable $file] && ![file isdirectory $file]} { - set auto_execs($name) [list $file] - return $auto_execs($name) - } - } - return "" -} - -} -# auto_reset -- -# Destroy all cached information for auto-loading and auto-execution, -# so that the information gets recomputed the next time it's needed. -# Also delete any procedures that are listed in the auto-load index -# except those defined in this file. -# -# Arguments: -# None. - -proc auto_reset {} { - global auto_execs auto_index auto_oldpath - foreach p [info procs] { - if {[info exists auto_index($p)] && ![string match auto_* $p] - && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup - tclMacPkgSearch tclPkgUnknown} $p] < 0)} { - rename $p {} - } - } - catch {unset auto_execs} - catch {unset auto_index} - catch {unset auto_oldpath} -} - -# auto_mkindex -- -# 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. 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. -# args - Any number of additional arguments giving the -# names of files within dir. If no additional -# are given auto_mkindex will look for *.tcl. - -proc auto_mkindex {dir args} { - global errorCode errorInfo - set oldDir [pwd] - cd $dir - set dir [pwd] - append index "# Tcl autoload index file, version 2.0\n" - append index "# This file is generated by the \"auto_mkindex\" command\n" - append index "# and sourced to set up indexing information for one or\n" - append index "# more commands. Typically each line is a command that\n" - append index "# sets an element in the auto_index array, where the\n" - append index "# element name is the name of a command and the value is\n" - append index "# a script that loads the command.\n\n" - if {$args == ""} { - set args *.tcl - } - foreach file [eval glob $args] { - set f "" - set error [catch { - 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" - } - } - close $f - } msg] - if $error { - set code $errorCode - set info $errorInfo - catch {close $f} - cd $oldDir - error $msg $info $code - } - } - set f "" - set error [catch { - set f [open tclIndex w] - puts $f $index nonewline - close $f - cd $oldDir - } msg] - if $error { - set code $errorCode - set info $errorInfo - catch {close $f} - cd $oldDir - error $msg $info $code - } -} - -# pkg_mkIndex -- -# This procedure creates a package index in a given directory. The -# package index consists of a "pkgIndex.tcl" file whose contents are -# a Tcl script that sets up package information with "package require" -# commands. The commands describe all of the packages defined by the -# files given as arguments. -# -# Arguments: -# dir - Name of the directory in which to create the index. -# args - Any number of additional arguments, each giving -# a glob pattern that matches the names of one or -# more shared libraries or Tcl script files in -# dir. - -proc pkg_mkIndex {dir args} { - global errorCode errorInfo - if {[llength $args] == 0} { - return -code error "wrong # args: should be\ - \"pkg_mkIndex dir pattern ?pattern ...?\""; - } - append index "# Tcl package index file, version 1.0\n" - append index "# This file is generated by the \"pkg_mkIndex\" command\n" - append index "# and sourced either when an application starts up or\n" - append index "# by a \"package unknown\" script. It invokes the\n" - append index "# \"package ifneeded\" command to set up package-related\n" - append index "# information so that packages will be loaded automatically\n" - append index "# in response to \"package require\" commands. When this\n" - append index "# script is sourced, the variable \$dir must contain the\n" - append index "# full path name of this file's directory.\n" - set oldDir [pwd] - cd $dir - foreach file [eval glob $args] { - # For each file, figure out what commands and packages it provides. - # To do this, create a child interpreter, load the file into the - # interpreter, and get a list of the new commands and packages - # that are defined. Define an empty "package unknown" script so - # that there are no recursive package inclusions. - - set c [interp create] - - # If Tk is loaded in the parent interpreter, load it into the - # child also, in case the extension depends on it. - - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - $c eval {set argv {-geometry +0+0}} - load [lindex $pkg 0] Tk $c - break - } - } - $c eval [list set file $file] - if [catch { - $c eval { - proc dummy args {} - rename package package-orig - proc package {what args} { - switch -- $what { - require { return ; # ignore transitive requires } - 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 - set pkgs "" - - # Try to load the file if it has the shared library extension, - # otherwise source it. It's important not to try to load - # files that aren't shared libraries, because on some systems - # (like SunOS) the loader will abort the whole application - # when it gets an error. - - if {[string compare [file extension $file] \ - [info sharedlibextension]] == 0} { - - # The "file join ." command below is necessary. Without - # it, if the file name has no \'s and we're on UNIX, the - # load command will invoke the LD_LIBRARY_PATH search - # mechanism, which could cause the wrong file to be used. - - load [file join . $file] - set type load - } else { - source $file - set type source - } - foreach ns [pkgGetAllNamespaces] { - namespace import ${ns}::* - } - foreach i [info commands] { - set cmds($i) 1 - } - foreach i $origCmds { - catch {unset cmds($i)} - - } - foreach i [array names cmds] { - # reverse engineer which namespace a command comes from - set absolute [namespace origin $i] - if {[string compare ::$i $absolute] != 0} { - set cmds($absolute) 1 - unset cmds($i) - } - } - foreach i [package names] { - if {([string compare [package provide $i] ""] != 0) - && ([string compare $i Tcl] != 0) - && ([string compare $i Tk] != 0)} { - lappend pkgs [list $i [package provide $i]] - } - } - } - } msg] { - tclLog "error while loading or sourcing $file: $msg" - } - foreach pkg [$c eval set pkgs] { - lappend files($pkg) [list $file [$c eval set type] \ - [lsort [$c eval array names cmds]]] - } - interp delete $c - } - foreach pkg [lsort [array names files]] { - append index "\npackage ifneeded $pkg\ - \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ - [list $files($pkg)]\]" - } - set f [open pkgIndex.tcl w] - puts $f $index - close $f - cd $oldDir -} - -# tclPkgSetup -- -# This is a utility procedure use by pkgIndex.tcl files. It is invoked -# as part of a "package ifneeded" script. It calls "package provide" -# to indicate that a package is available, then sets entries in the -# auto_index array so that the package's files will be auto-loaded when -# the commands are used. -# -# Arguments: -# dir - Directory containing all the files for this package. -# pkg - Name of the package (no version number). -# version - Version number for the package, such as 2.1.3. -# files - List of files that constitute the package. Each -# element is a sub-list with three elements. The first -# is the name of a file relative to $dir, the second is -# "load" or "source", indicating whether the file is a -# loadable binary or a script to source, and the third -# is a list of commands defined by this file. - -proc tclPkgSetup {dir pkg version files} { - global auto_index - - package provide $pkg $version - foreach fileInfo $files { - set f [lindex $fileInfo 0] - set type [lindex $fileInfo 1] - foreach cmd [lindex $fileInfo 2] { - if {$type == "load"} { - set auto_index($cmd) [list load [file join $dir $f] $pkg] - } else { - set auto_index($cmd) [list source [file join $dir $f]] - } - } - } -} - -# tclMacPkgSearch -- -# The procedure is used on the Macintosh to search a given directory for files -# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the -# interpreter to setup the package database. - -proc tclMacPkgSearch {dir} { - foreach x [glob -nocomplain [file join $dir *.shlb]] { - if [file isfile $x] { - set res [resource open $x] - foreach y [resource list TEXT $res] { - if {$y == "pkgIndex"} {source -rsrc pkgIndex} - } - catch {resource close $res} - } - } -} - -# tclPkgUnknown -- -# This procedure provides the default for the "package unknown" function. -# It is invoked when a package that's needed can't be found. It scans -# the auto_path directories and their immediate children looking for -# pkgIndex.tcl files and sources any such files that are found to setup -# the package database. (On the Macintosh we also search for pkgIndex -# TEXT resources in all files.) -# -# Arguments: -# name - Name of desired package. Not used. -# version - Version of desired package. Not used. -# exact - Either "-exact" or omitted. Not used. - -proc tclPkgUnknown {name version {exact {}}} { - global auto_path tcl_platform env - - if ![info exists auto_path] { - return - } - 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 - catch { - foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ - * pkgIndex.tcl]] { - set dir [file dirname $file] - if [catch {source $file} msg] { - tclLog "error reading package index file $file: $msg" - } - } - } - set dir [lindex $auto_path $i] - set file [file join $dir pkgIndex.tcl] - # safe interps usually don't have "file readable", nor stderr channel - if {[interp issafe] || [file readable $file]} { - if {[catch {source $file} msg] && ![interp issafe]} { - tclLog "error reading package index file $file: $msg" - } - } - # On the Macintosh we also look in the resource fork - # of shared libraries - # We can't use tclMacPkgSearch in safe interps because it uses glob - 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 - } - } - } - } -} |