summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl562
1 files changed, 0 insertions, 562 deletions
diff --git a/library/init.tcl b/library/init.tcl
deleted file mode 100644
index acd403d..0000000
--- a/library/init.tcl
+++ /dev/null
@@ -1,562 +0,0 @@
-# init.tcl --
-#
-# Default system startup file for Tcl-based applications. Defines
-# "unknown" procedure and auto-load facilities.
-#
-# RCS: @(#) $Id: init.tcl,v 1.29 1999/04/16 00:46:56 stanton Exp $
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-
-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.1
-
-# Compute the auto path to use in this interpreter.
-# The values on the path come from several locations:
-#
-# The environment variable TCLLIBPATH
-#
-# tcl_library, which is the directory containing this init.tcl script.
-# tclInitScript.h searches around for the directory containing this
-# init.tcl and defines tcl_library to that location before sourcing it.
-#
-# The parent directory of tcl_library. Adding the parent
-# means that packages in peer directories will be found automatically.
-#
-# tcl_pkgPath, which is set by the platform-specific initialization routines
-# On UNIX it is compiled in
-# On Windows it comes from the registry
-# On Macintosh it is "Tool Command Language" in the Extensions folder
-
-if {![info exists auto_path]} {
- if {[info exist env(TCLLIBPATH)]} {
- set auto_path $env(TCLLIBPATH)
- } else {
- set auto_path ""
- }
-}
-if {[string compare [info library] {}]} {
- foreach __dir [list [info library] [file dirname [info library]]] {
- if {[lsearch -exact $auto_path $__dir] < 0} {
- lappend auto_path $__dir
- }
- }
-}
-if {[info exist tcl_pkgPath]} {
- foreach __dir $tcl_pkgPath {
- if {[lsearch -exact $auto_path $__dir] < 0} {
- lappend auto_path $__dir
- }
- }
-}
-if {[info exists __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 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
- } else {
- set env(COMSPEC) command.com
- }
- }
-}
-
-# 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
- # platforms, safe interpreters do not have exec.
-
- set auto_noexec 1
-}
-set errorCode ""
-set errorInfo ""
-
-# Define a log command (which can be overwitten to log errors
-# differently, specially when stderr is not available)
-
-if {[info commands tclLog] == ""} {
- proc tclLog {string} {
- catch {puts stderr $string}
- }
-}
-
-# 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 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.
-# 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
-# in one of the common forms !!, !<number>, or ^old^new. If
-# so, emulate csh's history substitution.
-# (c) see if the command is a unique abbreviation for another
-# command. If so, invoke the command.
-#
-# Arguments:
-# args - A list whose elements are the words of the original
-# command, including the command name.
-
-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.
-
- set savedErrorCode $errorCode
- set savedErrorInfo $errorInfo
- set name [lindex $args 0]
- if {![info exists auto_noload]} {
- #
- # Make sure we're not trying to load the same proc twice.
- #
- if {[info exists unknown_pending($name)]} {
- return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
- }
- set unknown_pending($name) pending;
- set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
- unset unknown_pending($name);
- if {$ret != 0} {
- return -code $ret -errorcode $errorCode \
- "error while autoloading \"$name\": $msg"
- }
- if {![array size unknown_pending]} {
- unset unknown_pending
- }
- if {$msg} {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- set code [catch {uplevel 1 $args} msg]
- if {$code == 1} {
- #
- # Strip the last five lines off the error stack (they're
- # from the "uplevel" command).
- #
-
- set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
- return -code error -errorcode $errorCode \
- -errorinfo $new $msg
- } else {
- return -code $code $msg
- }
- }
- }
-
- if {([info level] == 1) && ([info script] == "") \
- && [info exists tcl_interactive] && $tcl_interactive} {
- if {![info exists auto_noexec]} {
- set new [auto_execok $name]
- if {$new != ""} {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- set redir ""
- if {[info commands console] == ""} {
- set redir ">&@stdout <@stdin"
- }
- return [uplevel exec $redir $new [lrange $args 1 end]]
- }
- }
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- if {$name == "!!"} {
- set newcmd [history event]
- } elseif {[regexp {^!(.+)$} $name dummy event]} {
- set newcmd [history event $event]
- } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
- set newcmd [history event -1]
- catch {regsub -all -- $old $newcmd $new newcmd}
- }
- if {[info exists newcmd]} {
- tclLog $newcmd
- history change $newcmd 0
- return [uplevel $newcmd]
- }
-
- set ret [catch {set cmds [info commands $name*]} msg]
- if {[string compare $name "::"] == 0} {
- set name ""
- }
- if {$ret != 0} {
- return -code $ret -errorcode $errorCode \
- "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
- }
- if {[llength $cmds] == 1} {
- return [uplevel [lreplace $args 0 0 $cmds]]
- }
- if {[llength $cmds] != 0} {
- if {$name == ""} {
- return -code error "empty command name \"\""
- } else {
- return -code error \
- "ambiguous command name \"$name\": [lsort $cmds]"
- }
- }
- }
- return -code error "invalid command name \"$name\""
-}
-
-# auto_load --
-# Checks a collection of library directories to see if a procedure
-# is defined in one of them. If so, it sources the appropriate
-# library file to create the procedure. Returns 1 if it successfully
-# loaded the procedure, 0 otherwise.
-#
-# 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 {namespace {}}} {
- global auto_index auto_oldpath auto_path
-
- 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] != ""}]
- }
- }
- 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
- }
- }
- set auto_oldpath $auto_path
-
- # Check if we are a safe interpreter. In that case, we support only
- # newer format tclIndex files.
-
- set issafe [interp issafe]
- 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]]}]} {
- continue
- } else {
- set error [catch {
- set id [gets $f]
- if {$id == "# Tcl autoload index file, version 2.0"} {
- eval [read $f]
- } elseif {$id == \
- "# Tcl autoload index file: each line identifies a Tcl"} {
- while {[gets $f line] >= 0} {
- if {([string index $line 0] == "#")
- || ([llength $line] != 2)} {
- continue
- }
- set name [lindex $line 0]
- set auto_index($name) \
- "source [file join $dir [lindex $line 1]]"
- }
- } else {
- error \
- "[file join $dir tclIndex] isn't a proper Tcl index file"
- }
- } msg]
- if {$f != ""} {
- close $f
- }
- if {$error} {
- error $msg $errorInfo $errorCode
- }
- }
- }
- return 1
-}
-
-# 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]
- }
- }
-}
-
-# 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 ""
-}
-
-}
generated by cgit v0.12 at 2024-10-02 14:36:54 (GMT)