diff options
Diffstat (limited to 'library')
-rw-r--r-- | library/auto.tcl | 527 | ||||
-rw-r--r-- | library/history.tcl | 2 | ||||
-rw-r--r-- | library/http/http.tcl | 2 | ||||
-rw-r--r-- | library/http1.0/http.tcl | 2 | ||||
-rw-r--r-- | library/http2.0/http.tcl | 2 | ||||
-rw-r--r-- | library/http2.1/http.tcl | 2 | ||||
-rw-r--r-- | library/http2.3/http.tcl | 2 | ||||
-rw-r--r-- | library/init.tcl | 207 | ||||
-rw-r--r-- | library/ldAout.tcl | 2 | ||||
-rw-r--r-- | library/package.tcl | 418 | ||||
-rw-r--r-- | library/parray.tcl | 2 | ||||
-rw-r--r-- | library/safe.tcl | 2 | ||||
-rw-r--r-- | library/word.tcl | 7 |
13 files changed, 945 insertions, 232 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index c2050e5..dfb9b6c 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -12,107 +12,6 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# 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. - -if {[string compare $tcl_platform(platform) windows] == 0} { -# 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 { -# 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. @@ -126,7 +25,7 @@ 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 + && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup tcl_findLibrary tclMacPkgSearch tclPkgUnknown} $p] < 0)} { rename $p {} } @@ -136,21 +35,169 @@ proc auto_reset {} { catch {unset auto_oldpath} } + +# tcl_findLibrary +# This is a utility for extensions that searches for a library directory +# using a canonical searching algorithm. A side effect is to source +# the initialization script and set a global library variable. +# Arguments: +# basename Prefix of the directory name, (e.g., "tk") +# version Version number of the package, (e.g., "8.0") +# patch Patchlevel of the package, (e.g., "8.0.3") +# initScript Initialization script to source (e.g., tk.tcl) +# enVarName environment variable to honor (e.g., TK_LIBRARY) +# varName Global variable to set when done (e.g., tk_library) + +proc tcl_findLibrary {basename version patch initScript enVarName varName} { + upvar #0 $varName the_library + global env + + set dirs {} + set errors {} + + # The C application may have hardwired a path, which we honor + + if {[info exist the_library]} { + lappend dirs $the_library + } else { + + # Do the canonical search + + # 1. From an environment variable, if it exists + + if {[info exists env($enVarName)]} { + lappend dirs $env($enVarName) + } + + # 2. Relative to the Tcl library + + lappend dirs [file join [file dirname [info library]] $basename$version] + + # 3. Various locations relative to the executable + # ../lib/foo1.0 (From bin directory in install hierarchy) + # ../../lib/foo1.0 (From bin/arch directory in install hierarchy) + # ../library (From unix directory in build hierarchy) + # ../../library (From unix/arch directory in build hierarchy) + # ../../foo1.0b1/library (From unix directory in parallel build hierarchy) + # ../../../foo1.0b1/library (From unix/arch directory in parallel build hierarchy) + + set parentDir [file dirname [file dirname [info nameofexecutable]]] + set grandParentDir [file dirname $parentDir] + lappend dirs [file join $parentDir lib $basename$version] + lappend dirs [file join $grandParentDir lib $basename$version] + lappend dirs [file join $parentDir library] + lappend dirs [file join $grandParentDir library] + if [string match {*[ab]*} $patch] { + set ver $patch + } else { + set ver $version + } + lappend dirs [file join $grandParentDir] $basename$ver library] + lappend dirs [file join [file dirname $grandParentDir] $basename$ver library] + } + foreach i $dirs { + set the_library $i + set file [file join $i $initScript] + + # source everything when in a safe interpreter because + # we have a source command, but no file exists command + + if {[interp issafe] || [file exists $file]} { + if {![catch {uplevel #0 [list source $file]} msg]} { + return + } else { + append errors "$file: $msg\n$errorInfo\n" + } + } + } + set msg "Can't find a usable $initScript in the following directories: \n" + append msg " $dirs\n\n" + append msg "$errors\n\n" + append msg "This probably means that $basename wasn't installed properly.\n" + error $msg +} + + +# OPTIONAL SUPPORT PROCEDURES +# In Tcl 8.1 all the code below here has been moved to other files to +# reduce the size of init.tcl + +# ---------------------------------------------------------------------- +# auto_mkindex +# ---------------------------------------------------------------------- +# The following procedures are used to generate the tclIndex file +# from Tcl source files. They use a special safe interpreter to +# parse Tcl source files, writing out index entries as "proc" +# commands are encountered. This implementation won't work in a +# safe interpreter, since a safe interpreter can't create the +# special parser and mess with its commands. If this is a safe +# interpreter, we simply clip these procs out. + +if {[interp issafe]} { + proc auto_mkindex {dir args} { + error "can't generate index within safe interpreter" + } + proc tcl_nonsafe {args} {} +} else { + proc tcl_nonsafe {args} {eval $args} +} + # 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. +# locate all of the relevant files. # # 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. +# 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. + +tcl_nonsafe proc auto_mkindex {dir args} { + global errorCode errorInfo + + if {[interp issafe]} { + error "can't generate index within safe interpreter" + } + + 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 + } + auto_mkindex_parser::init + foreach file [eval glob $args] { + if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { + append index $msg + } else { + set code $errorCode + set info $errorInfo + cd $oldDir + error $msg $info $code + } + } + auto_mkindex_parser::cleanup -proc auto_mkindex {dir args} { + set fid [open "tclIndex" w] + puts $fid $index nonewline + close $fid + cd $oldDir +} + +# Original version of auto_mkindex that just searches the source +# code for "proc" at the beginning of the line. + +proc auto_mkindex_old {dir args} { global errorCode errorInfo set oldDir [pwd] cd $dir @@ -201,3 +248,263 @@ proc auto_mkindex {dir args} { error $msg $info $code } } + +# Create a safe interpreter that can be used to parse Tcl source files +# generate a tclIndex file for autoloading. This interp contains +# commands for things that need index entries. Each time a command +# is executed, it writes an entry out to the index file. + +namespace eval auto_mkindex_parser { + variable parser "" ;# parser used to build index + variable index "" ;# maintains index as it is built + variable scriptFile "" ;# name of file being processed + variable contextStack "" ;# stack of namespace scopes + variable imports "" ;# keeps track of all imported cmds + variable initCommands "" ;# list of commands that create aliases + proc init {} { + variable parser + variable initCommands + if {![interp issafe]} { + set parser [interp create -safe] + $parser hide info + $parser hide rename + $parser hide proc + $parser hide namespace + $parser hide eval + $parser hide puts + $parser invokehidden namespace delete :: + $parser invokehidden proc unknown {args} {} + + # + # We'll need access to the "namespace" command within the + # interp. Put it back, but move it out of the way. + # + $parser expose namespace + $parser invokehidden rename namespace _%@namespace + $parser expose eval + $parser invokehidden rename eval _%@eval + + # Install all the registered psuedo-command implementations + + foreach cmd $initCommands { + eval $cmd + } + } + } + proc cleanup {} { + variable parser + interp delete $parser + unset parser + } +} + +# auto_mkindex_parser::mkindex -- +# Used by the "auto_mkindex" command to create a "tclIndex" file for +# the given Tcl source file. Executes the commands in the file, and +# handles things like the "proc" command by adding an entry for the +# index file. Returns a string that represents the index file. +# +# Arguments: +# file - Name of Tcl source file to be indexed. + +tcl_nonsafe proc auto_mkindex_parser::mkindex {file} { + variable parser + variable index + variable scriptFile + variable contextStack + variable imports + + set scriptFile $file + + set fid [open $file] + set contents [read $fid] + close $fid + + # There is one problem with sourcing files into the safe + # interpreter: references like "$x" will fail since code is not + # really being executed and variables do not really exist. + # Be careful to escape all naked "$" before evaluating. + + regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents + + set index "" + set contextStack "" + set imports "" + + $parser eval $contents + + foreach name $imports { + catch {$parser eval [list _%@namespace forget $name]} + } + return $index +} + +# auto_mkindex_parser::hook command +# Registers a Tcl command to evaluate when initializing the +# slave interpreter used by the mkindex parser. +# The command is evaluated in the master interpreter, and can +# use the variable auto_mkindex_parser::parser to get to the slave + +tcl_nonsafe proc auto_mkindex_parser::hook {cmd} { + variable initCommands + + lappend initCommands $cmd +} + +# auto_mkindex_parser::slavehook command +# Registers a Tcl command to evaluate when initializing the +# slave interpreter used by the mkindex parser. +# The command is evaluated in the slave interpreter. + +tcl_nonsafe proc auto_mkindex_parser::slavehook {cmd} { + variable initCommands + + lappend initCommands "\$parser eval [list $cmd]" +} + +# auto_mkindex_parser::command -- +# Registers a new command with the "auto_mkindex_parser" interpreter +# that parses Tcl files. These commands are fake versions of things +# like the "proc" command. When you execute them, they simply write +# out an entry to a "tclIndex" file for auto-loading. +# +# This procedure allows extensions to register their own commands +# with the auto_mkindex facility. For example, a package like +# [incr Tcl] might register a "class" command so that class definitions +# could be added to a "tclIndex" file for auto-loading. +# +# Arguments: +# name - Name of command recognized in Tcl files. +# arglist - Argument list for command. +# body - Implementation of command to handle indexing. + +tcl_nonsafe proc auto_mkindex_parser::command {name arglist body} { + hook [list auto_mkindex_parser::commandInit $name $arglist $body] +} + +# auto_mkindex_parser::commandInit -- +# This does the actual work set up by auto_mkindex_parser::command +# This is called when the interpreter used by the parser is created. + +tcl_nonsafe proc auto_mkindex_parser::commandInit {name arglist body} { + variable parser + + set ns [namespace qualifiers $name] + set tail [namespace tail $name] + if {$ns == ""} { + set fakeName "[namespace current]::_%@fake_$tail" + } else { + set fakeName "_%@fake_$name" + regsub -all {::} $fakeName "_" fakeName + set fakeName "[namespace current]::$fakeName" + } + proc $fakeName $arglist $body + + # + # YUK! Tcl won't let us alias fully qualified command names, + # so we can't handle names like "::itcl::class". Instead, + # we have to build procs with the fully qualified names, and + # have the procs point to the aliases. + # + if {[regexp {::} $name]} { + set exportCmd [list _%@namespace export [namespace tail $name]] + $parser eval [list _%@namespace eval $ns $exportCmd] + set alias [namespace tail $fakeName] + $parser invokehidden proc $name {args} "_%@eval $alias \$args" + $parser alias $alias $fakeName + } else { + $parser alias $name $fakeName + } + return +} + +# auto_mkindex_parser::fullname -- +# Used by commands like "proc" within the auto_mkindex parser. +# Returns the qualified namespace name for the "name" argument. +# If the "name" does not start with "::", elements are added from +# the current namespace stack to produce a qualified name. Then, +# the name is examined to see whether or not it should really be +# qualified. If the name has more than the leading "::", it is +# returned as a fully qualified name. Otherwise, it is returned +# as a simple name. That way, the Tcl autoloader will recognize +# it properly. +# +# Arguments: +# name - Name that is being added to index. + +tcl_nonsafe proc auto_mkindex_parser::fullname {name} { + variable contextStack + + if {![string match ::* $name]} { + foreach ns $contextStack { + set name "${ns}::$name" + if {[string match ::* $name]} { + break + } + } + } + + if {[namespace qualifiers $name] == ""} { + return [namespace tail $name] + } elseif {![string match ::* $name]} { + return "::$name" + } + return $name +} + +# Register all of the procedures for the auto_mkindex parser that +# will build the "tclIndex" file. + +# AUTO MKINDEX: proc name arglist body +# Adds an entry to the auto index list for the given procedure name. + +tcl_nonsafe auto_mkindex_parser::command proc {name args} { + variable index + variable scriptFile + append index "set [list auto_index([fullname $name])]" + append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" +} + +# AUTO MKINDEX: namespace eval name command ?arg arg...? +# Adds the namespace name onto the context stack and evaluates the +# associated body of commands. +# +# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...? +# Performs the "import" action in the parser interpreter. This is +# important for any commands contained in a namespace that affect +# the index. For example, a script may say "itcl::class ...", +# or it may import "itcl::*" and then say "class ...". This +# procedure does the import operation, but keeps track of imported +# patterns so we can remove the imports later. + +tcl_nonsafe auto_mkindex_parser::command namespace {op args} { + switch -- $op { + eval { + variable parser + variable contextStack + + set name [lindex $args 0] + set args [lrange $args 1 end] + + set contextStack [linsert $contextStack 0 $name] + if {[llength $args] == 1} { + $parser eval [lindex $args 0] + } else { + eval $parser eval $args + } + set contextStack [lrange $contextStack 1 end] + } + import { + variable parser + variable imports + foreach pattern $args { + if {$pattern != "-force"} { + lappend imports $pattern + } + } + catch {$parser eval "_%@namespace import $args"} + } + } +} + +rename tcl_nonsafe "" diff --git a/library/history.tcl b/library/history.tcl index c347ac0..79b3eb6 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -2,7 +2,7 @@ # # Implementation of the history command. # -# SCCS: @(#) history.tcl 1.8 97/12/03 11:57:51 +# RCS: @(#) $Id: history.tcl,v 1.1.2.2 1998/09/24 23:59:05 stanton Exp $ # # Copyright (c) 1997 Sun Microsystems, Inc. # diff --git a/library/http/http.tcl b/library/http/http.tcl index 89f9600..e61c16a 100644 --- a/library/http/http.tcl +++ b/library/http/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.11 98/02/18 18:06:40 +# RCS: @(#) $Id: http.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl index 2311a31..b3ade0b 100644 --- a/library/http1.0/http.tcl +++ b/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.11 97/12/03 13:02:39 +# RCS: @(#) $Id: http.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ # # See the http.n man page for documentation diff --git a/library/http2.0/http.tcl b/library/http2.0/http.tcl index 89f9600..e61c16a 100644 --- a/library/http2.0/http.tcl +++ b/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.11 98/02/18 18:06:40 +# RCS: @(#) $Id: http.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl index 89f9600..e61c16a 100644 --- a/library/http2.1/http.tcl +++ b/library/http2.1/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.11 98/02/18 18:06:40 +# RCS: @(#) $Id: http.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl index 89f9600..e61c16a 100644 --- a/library/http2.3/http.tcl +++ b/library/http2.3/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.11 98/02/18 18:06:40 +# RCS: @(#) $Id: http.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ package provide http 2.0 ;# This uses Tcl namespaces diff --git a/library/init.tcl b/library/init.tcl index 8a89774..fd1d8ad 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.104 98/01/09 17:52:21 +# RCS: @(#) $Id: init.tcl,v 1.1.2.2 1998/09/24 23:59:06 stanton Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -78,6 +78,12 @@ if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} { } } } + if {[info exists p]} { + unset p + } + if {[info exists u]} { + unset u + } if {![info exists env(COMSPEC)]} { if {$tcl_platform(os) == {Windows NT}} { set env(COMSPEC) cmd.exe @@ -113,19 +119,16 @@ 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 # command available: # -# 1. See if the autoload facility can locate the command in a +# 1. See if the command has the form "namespace inscope ns cmd" and +# if so, concatenate its arguments onto the end and evaluate it. +# 2. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. -# 2. If the command was invoked interactively at top-level: +# 3. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution @@ -138,10 +141,24 @@ 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 + # If the command word has the form "namespace inscope ns cmd" + # then concatenate its arguments onto the end and evaluate it. + + set cmd [lindex $args 0] + if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { + set arglist [lrange $args 1 end] + set ret [catch {uplevel $cmd $arglist} result] + if {$ret == 0} { + return $result + } else { + return -code $ret -errorcode $errorCode $result + } + } + # Save the values of errorCode and errorInfo variables, since they # may get modified if caught errors occur below. The variables will # be restored just before re-executing the missing command. @@ -251,8 +268,8 @@ if {[info commands tclLog] == ""} { # a canonical namespace as returned [namespace current] # for instance. If not given, namespace current is used. - proc auto_load {cmd {namespace {}}} { - global auto_index auto_oldpath auto_path env errorInfo errorCode +proc auto_load {cmd {namespace {}}} { + global auto_index auto_oldpath auto_path if {[string length $namespace] == 0} { set namespace [uplevel {namespace current}] @@ -270,6 +287,34 @@ if {[info commands tclLog] == ""} { if {![info exists auto_path]} { return 0 } + + if {![auto_load_index]} { + return 0 + } + + foreach name $nameList { + if {[info exists auto_index($name)]} { + uplevel #0 $auto_index($name) + if {[info commands $name] != ""} { + return 1 + } + } + } + return 0 +} + +# auto_load_index -- +# Loads the contents of tclIndex files on the auto_path directory +# list. This is usually invoked within auto_load to load the index +# of available commands. Returns 1 if the index is loaded, and 0 if +# the index is already loaded and up to date. +# +# Arguments: +# None. + +proc auto_load_index {} { + global auto_index auto_oldpath auto_path errorInfo errorCode + if {[info exists auto_oldpath]} { if {$auto_oldpath == $auto_path} { return 0 @@ -317,15 +362,7 @@ if {[info commands tclLog] == ""} { } } } - foreach name $nameList { - if {[info exists auto_index($name)]} { - uplevel #0 $auto_index($name) - if {[info commands $name] != ""} { - return 1 - } - } - } - return 0 + return 1 } # auto_qualify -- @@ -342,7 +379,7 @@ if {[info commands tclLog] == ""} { # a canonical namespace as returned by [namespace current] # for instance. - proc auto_qualify {cmd namespace} { +proc auto_qualify {cmd namespace} { # count separators and clean them up # (making sure that foo:::::bar will be treated as foo::bar) @@ -387,3 +424,131 @@ if {[info commands tclLog] == ""} { } } +# auto_import -- +# invoked during "namespace import" to make see if the imported commands +# reside in an autoloaded library. If so, the commands are loaded so +# that they will be available for the import links. If not, then this +# procedure does nothing. +# +# Arguments - +# pattern The pattern of commands being imported (like "foo::*") +# a canonical namespace as returned by [namespace current] + +proc auto_import {pattern} { + global auto_index + + set ns [uplevel namespace current] + set patternList [auto_qualify $pattern $ns] + + auto_load_index + + foreach pattern $patternList { + foreach name [array names auto_index] { + if {[string match $pattern $name] && "" == [info commands $name]} { + uplevel #0 $auto_index($name) + } + } + } +} + +# 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. + +if {[string compare $tcl_platform(platform) windows] == 0} { +# 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 { +# 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 "" +} + +} diff --git a/library/ldAout.tcl b/library/ldAout.tcl index 7914508..788f5cf 100644 --- a/library/ldAout.tcl +++ b/library/ldAout.tcl @@ -18,7 +18,7 @@ # its .o file placed before all others in the command; then # "ld" is executed to bind the objects together. # -# SCCS: @(#) ldAout.tcl 1.12 96/11/30 17:11:02 +# RCS: @(#) $Id: ldAout.tcl,v 1.1.2.1 1998/09/24 23:59:06 stanton Exp $ # # Copyright (c) 1995, by General Electric Company. All rights reserved. # diff --git a/library/package.tcl b/library/package.tcl index 68c5053..9ab8231 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -20,6 +20,24 @@ # files given as arguments. # # Arguments: +# -direct (optional) If this flag is present, the generated +# code in pkgMkIndex.tcl will cause the package to be +# loaded when "package require" is executed, rather +# than lazily when the first reference to an exported +# procedure in the package is made. +# -nopkgrequire (optional) If this flag is present, "package require" +# commands are ignored. This flag is useful in some +# situations, for example when there is a circularity +# in package requires (package a requires package b, +# which in turns requires package a). +# -verbose (optional) Verbose output; the name of each file that +# was successfully rocessed is printed out. Additionally, +# if processing of a file failed a message is printed +# out; a file failure may not indicate that the indexing +# has failed, since pkg_mkIndex stores the list of failed +# files and tries again. The second time the processing +# may succeed, for example if a required package has been +# indexed by a previous pass. # 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 @@ -28,22 +46,57 @@ proc pkg_mkIndex {args} { global errorCode errorInfo - set first [lindex $args 0] - set direct [string match "-d*" $first] - set more "" - if {$direct} { - set args [lrange $args 1 end] - set more " -direct" + set usage {"pkg_mkIndex ?-nopkgrequire? ?-direct? ?-verbose? dir ?pattern ...?"}; + + set argCount [llength $args] + if {$argCount < 1} { + return -code error "wrong # args: should be\n$usage" } - if {[llength $args] == 0} { - return -code error "wrong # args: should be\ - \"pkg_mkIndex ?-direct? dir ?pattern ...?\""; + + set more "" + set direct 0 + set noPkgRequire 0 + set doVerbose 0 + for {set idx 0} {$idx < $argCount} {incr idx} { + set flag [lindex $args $idx] + switch -glob -- $flag { + -- { + # done with the flags + incr idx + break + } + + -verbose { + set doVerbose 1 + } + + -direct { + set direct 1 + append more " -direct" + } + + -nopkgrequire { + set noPkgRequire 1 + append more " -nopkgrequire" + } + + -* { + return -code error "unknown flag $flag: should be\n$usage" + } + + default { + # done with the flags + break + } + } } - set dir [lindex $args 0] - set patternList [lrange $args 1 end] + + set dir [lindex $args $idx] + set patternList [lrange $args [expr $idx + 1] end] if {[llength $patternList] == 0} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } + append index "# Tcl package index file, version 1.1\n" append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" append index "# and sourced either when an application starts up or\n" @@ -55,121 +108,312 @@ proc pkg_mkIndex {args} { append index "# full path name of this file's directory.\n" set oldDir [pwd] cd $dir + + # In order to support building of index files from scratch, we make + # repeated passes on the files to index, until either all have been + # indexed, or we can no longer make any headway. + foreach file [eval glob $patternList] { - # 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 toProcess($file) 1 + } - set c [interp create] + while {[array size toProcess] > 0} { + set processed 0 - # If Tk is loaded in the parent interpreter, load it into the - # child also, in case the extension depends on it. + foreach file [array names toProcess] { + # 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. The interpeter uses a special version of + # tclPkgSetup to force loading of required packages at require + # time rather than lazily, so that we can keep track of commands + # and packages that are defined indirectly rather than from the + # file itself. - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - $c eval {set argv {-geometry +0+0}} - load [lindex $pkg 0] Tk $c - break + set c [interp create] + + # Load into the child all packages currently loaded in the parent + # interpreter, in case the extension depends on some of them. + + foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + $c eval {set argv {-geometry +0+0}} + } + load [lindex $pkg 0] [lindex $pkg 1] $c } - } - $c eval [list set __file $file] - $c eval [list set __direct $direct] - 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 [list $what] $args } + + # We also call package ifneeded for all packages that have been + # identified so far. This way, each pass will have loaded the + # equivalent of the pkgIndex.tcl file that we are constructing, + # and packages whose processing failed in previous passes may + # be processed successfully now + + foreach pkg [array names files] { + $c eval "package ifneeded $pkg\ + \[list tclPkgSetup $dir \ + [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\]" + } + if {$noPkgRequire == 1} { + $c eval { + rename package __package_orig + proc package {what args} { + switch -- $what { + require { return ; # ignore transitive requires } + default { eval __package_orig {$what} $args } + } } + proc __dummy args {} + package unknown __dummy } - if {!$__direct} { - proc __pkgGetAllNamespaces {{root {}}} { - set list $root - foreach ns [namespace children $root] { - eval lappend list [__pkgGetAllNamespaces $ns] + } else { + $c eval { + rename package __package_orig + proc package {what args} { + switch -- $what { + require { + eval __package_orig require $args + + # a package that was required needs to be + # placed in the list of packages to ignore. + # tclPkgSetup is unable to do it, so do it + # here. + + set ::__ignorePkgs([lindex $args 0]) 1 + } + + provide { + # if package provide is called at level 1 and + # with two arguments, then this package is + # being provided by one of the files we are + # indexing, and therefore we need to add it + # to the list of packages to write out. + # We need to do this check because otherwise + # packages that are spread over multiple + # files are indexed only by their first file + # loaded. + # Note that packages that this cannot catch + # packages that are implemented by a + # combination of TCL files and DLLs + + if {([info level] == 1) \ + && ([llength $args] == 2)} { + lappend ::__providedPkgs [lindex $args 0] + } + + eval __package_orig provide $args + } + + default { eval __package_orig {$what} $args } } - return $list } - set __origCmds [info commands] } - package unknown __dummy + } - set dir "" ;# in case file is pkgIndex.tcl + $c eval [list set __file $file] + $c eval [list set __direct $direct] + if {[catch { + $c eval { + set __doingWhat "loading or sourcing" - # 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. + # override the tclPkgSetup procedure (which is called by + # package ifneeded statements from pkgIndex.tcl) to force + # loads of packages, and also keep track of + # packages/namespaces/commands that the load generated - if {[string compare [file extension $__file] \ - [info sharedlibextension]] == 0} { + proc tclPkgSetup {dir pkg version files} { + # remember the current set of packages and commands, + # so that we can add any that were defined by the + # package files to the list of packages and commands + # to ignore - # 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. + foreach __p [package names] { + set __localIgnorePkgs($__p) 1 + } + foreach __ns [__pkgGetAllNamespaces] { + set __localIgnoreNs($__ns) 1 + + # if the namespace is already in the __ignoreNs + # array, its commands have already been imported + + if {[info exists ::__ignoreNs($__ns)] == 0} { + namespace import ${__ns}::* + } + } + foreach __cmd [info commands] { + set __localIgnoreCmds($__cmd) 1 + } + + # load the files that make up the package - if {[catch {load [file join . $__file]} __msg]} { - tclLog "warning: error while loading $__file: $__msg" + package provide $pkg $version + foreach __fileInfo $files { + set __f [lindex $__fileInfo 0] + set __type [lindex $__fileInfo 1] + if {$__type == "load"} { + load [file join $dir $__f] $pkg + } else { + source [file join $dir $__f] + } + } + + # packages and commands that were defined by these + # files are to be ignored. + + foreach __p [package names] { + if {[info exists __localIgnorePkgs($__p)] == 0} { + set ::__ignorePkgs($__p) 1 + } + } + foreach __ns [__pkgGetAllNamespaces] { + if {([info exists __localIgnoreNs($__ns)] == 0) \ + && ([info exists ::__ignoreNs($__ns)] == 0)} { + namespace import ${__ns}::* + set ::__ignoreNs($__ns) 1 + } + } + foreach __cmd [info commands] { + if {[info exists __localIgnoreCmds($__cmd)] == 0} { + lappend ::__ignoreCmds $__cmd + } + } } - set __type load - } else { - if {[catch {source $__file} __msg]} { - tclLog "warning: error while sourcing $__file: $__msg" + + # we need to track command defined by each package even in + # the -direct case, because they are needed internally by + # the "partial pkgIndex.tcl" step above. + + proc __pkgGetAllNamespaces {{root {}}} { + set __list $root + foreach __ns [namespace children $root] { + eval lappend __list [__pkgGetAllNamespaces $__ns] + } + return $__list } - set __type source - } - # Using __ variable names to avoid potential namespaces - # clash, even here in post processing because the - # loaded package could have set up traces,... - if {!$__direct} { + + # initialize the list of packages to ignore; these are + # packages that are present before the script/dll is loaded + + set ::__ignorePkgs(Tcl) 1 + set ::__ignorePkgs(Tk) 1 + foreach __pkg [package names] { + set ::__ignorePkgs($__pkg) 1 + } + + # before marking the original commands, import all the + # namespaces that may have been loaded from the parent; + # these namespaces and their commands are to be ignored + foreach __ns [__pkgGetAllNamespaces] { + set ::__ignoreNs($__ns) 1 namespace import ${__ns}::* } + + set ::__ignoreCmds [info commands] + + set dir "" ;# in case file is pkgIndex.tcl + + # 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. + + set __pkgs {} + set __providedPkgs {} + 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. + + set __doingWhat loading + load [file join . $__file] + set __type load + } else { + set __doingWhat sourcing + source $__file + set __type source + } + + # Using __ variable names to avoid potential namespaces + # clash, even here in post processing because the + # loaded package could have set up traces,... + + foreach __ns [__pkgGetAllNamespaces] { + if {[info exists ::__ignoreNs($__ns)] == 0} { + namespace import ${__ns}::* + } + } foreach __i [info commands] { set __cmds($__i) 1 } - foreach __i $__origCmds { + foreach __i $::__ignoreCmds { 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} { + + # special case so that global names have no leading + # ::, this is required by the unknown command + + set __absolute [auto_qualify $__absolute ::] + + if {[string compare $__i $__absolute] != 0} { set __cmds($__absolute) 1 unset __cmds($__i) } } - } - set __pkgs {} - foreach __i [package names] { - if {([string compare [package provide $__i] ""] != 0) - && ([string compare $__i Tcl] != 0) - && ([string compare $__i Tk] != 0)} { + + foreach __i $::__providedPkgs { lappend __pkgs [list $__i [package provide $__i]] + set __ignorePkgs($__i) 1 + } + foreach __i [package names] { + if {([string compare [package provide $__i] ""] != 0) \ + && ([info exists ::__ignorePkgs($__i)] == 0)} { + lappend __pkgs [list $__i [package provide $__i]] + } } } + } msg] == 1} { + set what [$c eval set __doingWhat] + if {$doVerbose} { + tclLog "warning: error while $what $file: $msg\nthis file will be retried in the next pass" + } + } else { + set type [$c eval set __type] + set cmds [lsort [$c eval array names __cmds]] + set pkgs [$c eval set __pkgs] + if {[llength $pkgs] > 1} { + tclLog "warning: \"$file\" provides more than one package ($pkgs)" + } + foreach pkg $pkgs { + # cmds is empty/not used in the direct case + lappend files($pkg) [list $file $type $cmds] + } + + incr processed + unset toProcess($file) + + if {$doVerbose} { + tclLog "processed $file" + } } - } msg]} { - tclLog "error while loading or sourcing $file: $msg" - } - set type [$c eval set __type] - set cmds [lsort [$c eval array names __cmds]] - set pkgs [$c eval set __pkgs] - if {[llength $pkgs] > 1} { - tclLog "warning: \"$file\" provides more than one package ($pkgs)" + interp delete $c } - foreach pkg $pkgs { - # cmds is empty/not used in the direct case - lappend files($pkg) [list $file $type $cmds] + + if {$processed == 0} { + tclLog "this iteration could not process any files: giving up here" + break } - interp delete $c } + foreach pkg [lsort [array names files]] { append index "\npackage ifneeded $pkg " if {$direct} { diff --git a/library/parray.tcl b/library/parray.tcl index 1a88b92..3b766d6 100644 --- a/library/parray.tcl +++ b/library/parray.tcl @@ -1,7 +1,7 @@ # parray: # Print the contents of a global array on stdout. # -# SCCS: @(#) parray.tcl 1.10 97/12/03 11:50:31 +# RCS: @(#) $Id: parray.tcl,v 1.1.2.2 1998/09/24 23:59:06 stanton Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. diff --git a/library/safe.tcl b/library/safe.tcl index 5e84267..0ee3a92 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. # -# SCCS: @(#) safe.tcl 1.30 98/01/07 17:05:25 +# RCS: @(#) $Id: safe.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ # # The implementation is based on namespaces. These naming conventions diff --git a/library/word.tcl b/library/word.tcl index 0bf2dce..72b1714 100644 --- a/library/word.tcl +++ b/library/word.tcl @@ -5,15 +5,12 @@ # widgets behave properly for different platforms. # # Copyright (c) 1996 by Sun Microsystems, Inc. +# Copyright (c) 1998 by Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) word.tcl 1.4 97/12/03 11:57:11 -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# RCS: @(#) $Id: word.tcl,v 1.1.2.2 1998/09/24 23:59:07 stanton Exp $ # The following variables are used to determine which characters are # interpreted as white space. |