init.tcl –

Default system startup file for Tcl-based applications. Defines

“unknown” procedure and auto-load facilities.

RCS: @(#) $Id: init.tcl,v 1.55.2.7 2007/07/05 18:03:45 dgp 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.4

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.

Also add the directory ../lib relative to the directory where the

executable is located. This is meant to find binary packages for the

same architecture as the current executable.

tcl_pkgPath, which is set by the platform-specific initialization routines

On UNIX it is compiled in

On Windows, it is not used

On Macintosh it is “Tool Command Language” in the Extensions folder

if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path “”
}
}
namespace eval tcl {
variable Dir
if {[info library] ne “”} {
foreach Dir [list [info library] [file dirname [info library]]] {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
set Dir [file join [file dirname [file dirname
[info nameofexecutable]]] lib]
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} {
foreach Dir $::tcl_pkgPath {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
}

Windows specific end of initialization

if {(![interp issafe]) && $tcl_platform(platform) eq “windows”} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
set x ::env(n2)
set ::env($lo) $x
set ::env([string toupper $lo]) $x
}
proc InitWinEnv {} {
global env tcl_platform
foreach p [array names env] {
set u [string toupper p] if {u ne $p} {
switch – u { COMSPEC - PATH { if {![info exists env(u)]} {
set env($u) env(p)
}
trace add variable env($p) write
[namespace code [list EnvTraceProc p]] trace add variable env(u) write
[namespace code [list EnvTraceProc p]] } } } } if {![info exists env(COMSPEC)]} { if {tcl_platform(os) eq “Windows NT”} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}

Setup the unknown package handler

package unknown tclPkgUnknown

if {![interp issafe]} {
# setup platform specific unknown package handlers
if {$::tcl_platform(platform) eq “unix”
&& ::tcl_platform(os) eq "Darwin"} { package unknown [list tcl::MacOSXPkgUnknown [package unknown]] } if {::tcl_platform(platform) eq “macintosh”} {
package unknown [list tcl::MacPkgUnknown [package unknown]]
}
}

Conditionalize for presence of exec.

if {[namespace which -command exec] eq “”} {

# 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 {[namespace which -command tclLog] eq “”} {
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 !!, !, or ^oldnew. 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 1 ::$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.

# Safety check in case something unsets the variables 
# ::errorInfo or ::errorCode.  [Bug 1063707]
if {![info exists errorCode]} {
set errorCode ""
}
if {![info exists errorInfo]} {
set errorInfo ""
}
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name $cmd
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} {
    append errorInfo "\n    (autoloading \"$name\")"
    return -code $ret -errorcode $errorCode -errorinfo $errorInfo $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} {
	#
	# Compute stack trace contribution from the [uplevel].
	# Note the dependence on how Tcl_AddErrorInfo, etc. 
	# construct the stack trace.
	#
	set cinfo $args
	set ellipsis ""
	while {[string bytelength $cinfo] > 150} {
	    set cinfo [string range $cinfo 0 end-1]
	    set ellipsis "..."
	}
	append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
	append cinfo "\n    invoked from within"
	append cinfo "\n\"uplevel 1 \$args\""
	#
	# Try each possible form of the stack trace
	# and trim the extra contribution from the matching case
	#
	set expect "$msg\n    while executing\n\"$cinfo"
	if {$errorInfo eq $expect} {
	    #
	    # The stack has only the eval from the expanded command
	    # Do not generate any stack trace here.
	    #
	    return -code error -errorcode $errorCode $msg
	}
	#
	# Stack trace is nested, trim off just the contribution
	# from the extra "eval" of $args due to the "catch" above.
	#
	set expect "\n    invoked from within\n\"$cinfo"
	set exlen [string length $expect]
	set eilen [string length $errorInfo]
	set i [expr {$eilen - $exlen - 1}]
	set einfo [string range $errorInfo 0 $i]
	#
	# For now verify that $errorInfo consists of what we are about
	# to return plus what we expected to trim off.
	#
	if {$errorInfo ne "$einfo$expect"} {
	    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
		[list CORE UNKNOWN BADTRACE $expect $errorInfo]
	}
	return -code error -errorcode $errorCode \
		-errorinfo $einfo $msg
    } else {
	return -code $code $msg
    }
}
}

if {([info level] == 1) && [info script] eq "" \
    && [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
    set new [auto_execok $name]
    if {$new ne ""} {
	set errorCode $savedErrorCode
	set errorInfo $savedErrorInfo
	set redir ""
	if {[namespace which -command console] eq ""} {
	    set redir ">&@stdout <@stdin"
	}
	return [uplevel 1 exec $redir $new [lrange $args 1 end]]
    }
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {$name eq "!!"} {
    set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
    set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> 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 1 $newcmd]
}

set ret [catch {set candidates [info commands $name*]} msg]
if {$name eq "::"} {
    set name ""
}
if {$ret != 0} {
    return -code $ret -errorcode $errorCode \
	"error in unknown while checking if \"$name\" is\
	a unique command abbreviation:\n$msg"
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
if {$name eq ""} {
    # Handle empty $name separately due to strangeness
    # in [string first] (See RFE 1243354)
    set cmds $candidates
} else {
    set cmds [list]
    foreach x $candidates {
	if {[string first $name $x] == 0} {
	    lappend cmds $x
	}
    }
}
if {[llength $cmds] == 1} {
    return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
}
if {[llength $cmds]} {
    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 {$namespace eq ""} {
set namespace [uplevel 1 [list ::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)]} {
    namespace eval :: $auto_index($name)
    # There's a couple of ways to look for a command of a given
    # name.  One is to use
    #    info commands $name
    # Unfortunately, if the name has glob-magic chars in it like *
    # or [], it may not match.  For our purposes here, a better
    # route is to use 
    #    namespace which -command $name
    if {[namespace which -command $name] ne ""} {
	return 1
    }
}
}
if {![info exists auto_path]} {
return 0
}

if {![auto_load_index]} {
return 0
}
foreach name $nameList {
if {[info exists auto_index($name)]} {
    namespace eval :: $auto_index($name)
    if {[namespace which -command $name] ne ""} {
	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] && $auto_oldpath eq $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 eq "# Tcl autoload index file, version 2.0"} {
	    eval [read $f]
	} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
	    while {[gets $f line] >= 0} {
		if {[string index $line 0] eq "#" 
			|| ([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 ne ""} {
	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 {[string match ::* $cmd]} {
if {$n > 1} {
    # ( ::foo::bar , * ) -> ::foo::bar
    return [list $cmd]
} else {
    # ( ::global , * ) -> global
    return [list [string range $cmd 2 end]]
}
}

# Potentially returning 2 elements to try  :
# (if the current namespace is not the global one)

if {$n == 0} {
if {$namespace eq "::"} {
    # ( nocolons , :: ) -> nocolons
    return [list $cmd]
} else {
    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
    return [list ${namespace}::$cmd $cmd]
}
} elseif {$namespace eq "::"} {
#  ( 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

# If no namespace is specified, this will be an error case

if {![string match *::* $pattern]} {
return
}

set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]

auto_load_index

foreach pattern $patternList {
    foreach name [array names auto_index $pattern] {
        if {([namespace which -command $name] eq "")
	    && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
            namespace eval :: $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 {$tcl_platform(platform) eq “windows”} {

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) ""

set shellBuiltins [list cls copy date del erase dir echo mkdir \
    md rename ren rmdir rd time type ver vol]
if {$tcl_platform(os) eq "Windows NT"} {
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
if {[info exists env(PATHEXT)]} {
# Add an initial ; to have the {} extension check first.
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
set execExtensions [list {} .com .exe .bat]
}

if {[lsearch -exact $shellBuiltins $name] != -1} {
# When this is command.com for some reason on Win2K, Tcl won't
# exec it unless the case is right, which this corrects.  COMSPEC
# may not point to a real file, so do the check.
set cmd $env(COMSPEC)
if {[file exists $cmd]} {
    set cmd [file attributes $cmd -shortname]
}
return [set auto_execs($name) [list $cmd /c $name]]
}

if {[llength [file split $name]] != 1} {
foreach ext $execExtensions {
    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) eq "Windows NT"} {
    append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}

foreach var {PATH Path path} {
if {[info exists env($var)]} {
    append path ";$env($var)"
}
}

foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || $dir eq {}} { continue }
set checked($dir) {}
foreach ext $execExtensions {
    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 eq ""} {
    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 ""

}

::tcl::CopyDirectory –

This procedure is called by Tcl’s core when attempts to call the

filesystem’s copydirectory function fail. The semantics of the call

are that ‘dest’ does not yet exist, i.e. dest should become the exact

image of src. If dest does exist, we throw an error.

Note that making changes to this procedure can change the results

of running Tcl’s tests.

Arguments:

action - “renaming” or “copying”

src - source directory

dest - destination directory

proc tcl::CopyDirectory {action src dest} {
set nsrc [file normalize $src]
set ndest [file normalize dest] if {action eq “renaming”} {
# Can’t rename volumes. We could give a more precise
# error message here, but that would break the test suite.
if {[lsearch -exact [file volumes] $nsrc] != -1} {
return -code error “error action \"src" to
"$dest": trying to rename a volume or move a directory
into itself”
}
}
if {[file exists dest]} { if {nsrc eq $ndest} {
return -code error “error action \"src" to
"dest\": trying to rename a volume or move a directory\ into itself" } if {action eq “copying”} {
return -code error “error action \"src" to
"$dest": file already exists”
} else {
# Depending on the platform, and on the current
# working directory, the directories ‘.’, ‘..’
# can be returned in various combinations. Anyway,
# if any other file is returned, we must signal an error.
set existing [glob -nocomplain -directory $dest * .]
eval [linsert
[glob -nocomplain -directory $dest -type hidden * .] 0
lappend existing]
foreach s $existing {
if {([file tail $s] ne “.”) && ([file tail $s] ne “..”)} {
return -code error “error action \"src" to
"$dest": file already exists”
}
}
}
} else {
if {[string first $nsrc $ndest] != -1} {
set srclen [expr {[llength [file split $nsrc]] -1}]
set ndest [lindex [file split $ndest] srclen] if {ndest eq [file tail $nsrc]} {
return -code error “error action \"src" to
"$dest": trying to rename a volume or move a directory
into itself”
}
}
file mkdir $dest
}
# Have to be careful to capture both visible and hidden files.
# We will also be more generous to the file system and not
# assume the hidden and non-hidden lists are non-overlapping.
#
# On Unix ‘hidden’ files begin with ‘.’. On other platforms
# or filesystems hidden files may have other interpretations.
set filelist [concat [glob -nocomplain -directory $src *]
[glob -nocomplain -directory $src -types hidden *]]

foreach s [lsort -unique $filelist] {
if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
    file copy $s [file join $dest [file tail $s]]
}
}
return

}

init.tcl –

Default system startup file for Tcl-based applications. Defines

“unknown” procedure and auto-load facilities.

RCS: @(#) $Id: init.tcl,v 1.55.2.7 2007/07/05 18:03:45 dgp 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.

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.

Also add the directory ../lib relative to the directory where the

executable is located. This is meant to find binary packages for the

same architecture as the current executable.

tcl_pkgPath, which is set by the platform-specific initialization routines

On UNIX it is compiled in

On Windows, it is not used

On Macintosh it is “Tool Command Language” in the Extensions folder

Windows specific end of initialization

Setup the unknown package handler

Conditionalize for presence of exec.

Define a log command (which can be overwitten to log errors

differently, specially when stderr is not available)

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 !!, !, or oldnew. 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.

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.

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.

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.

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

in one of the common forms !!, !, or ^oldnew. If