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
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 {[string compare [info library] {}]} {
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
}
}
}
}
if {(![interp issafe]) && [string equal $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
}
proc InitWinEnv {} {
global env tcl_platform
foreach p [array names env] {
set u [string toupper $p]
if {[string compare $u $p]} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace variable env($p) w \
[namespace code [list EnvTraceProc $p]]
trace variable env($u) w \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}
package unknown tclPkgUnknown
if {[llength [info commands exec]] == 0} {
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
if {[llength [info commands tclLog]] == 0} {
proc tclLog {string} {
catch {puts stderr $string}
}
}
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
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
}
}
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if {![info exists auto_noload]} {
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} {
set cinfo $args
if {[string length $cinfo] > 150} {
set cinfo "[string range $cinfo 0 149]..."
}
append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
set expect "$msg\n while executing\n\"$cinfo"
if {$errorInfo eq $expect} {
return -code error -errorcode $errorCode $msg
}
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]
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) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {[string compare {} $new]} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {[string equal $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 1 $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
if {[string equal $name "::"]} {
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 1 [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "invalid command name \"$name\""
}
proc auto_load {cmd {namespace {}}} {
global auto_index auto_oldpath auto_path
if {[string length $namespace] == 0} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
lappend nameList $cmd
foreach name $nameList {
if {[info exists auto_index($name)]} {
uplevel 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 if { ![string equal [namespace which -command $name] ""] } {
return 1
}
}
}
return 0
}
proc auto_load_index {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
if {[info exists auto_oldpath] && \
[string equal $auto_oldpath $auto_path]} {
return 0
}
set auto_oldpath $auto_path
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 {[string equal $id \
"# Tcl autoload index file, version 2.0"]} {
eval [read $f]
} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
while {[gets $f line] >= 0} {
if {[string equal [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 {[string compare $f ""]} {
close $f
}
if {$error} {
error $msg $errorInfo $errorCode
}
}
}
return 1
}
proc auto_qualify {cmd namespace} {
set n [regsub -all {::+} $cmd :: cmd]
if {[regexp {^::(.*)$} $cmd x tail]} {
if {$n > 1} {
return [list $cmd]
} else {
return [list $tail]
}
}
if {$n == 0} {
if {[string equal $namespace ::]} {
return [list $cmd]
} else {
return [list ${namespace}::$cmd $cmd]
}
} elseif {[string equal $namespace ::]} {
return [list ::$cmd]
} else {
return [list ${namespace}::$cmd ::$cmd]
}
}
proc auto_import {pattern} {
global auto_index
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 {[string equal "" [info commands $name]]
&& [string equal [namespace qualifiers $pattern] \
[namespace qualifiers $name]]} {
uplevel }
}
}
}
if {[string equal windows $tcl_platform(platform)]} {
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 {[string equal $tcl_platform(os) "Windows NT"]} {
lappend shellBuiltins "start"
}
if {[info exists env(PATHEXT)]} {
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
set execExtensions [list {} .com .exe .bat]
}
if {[lsearch -exact $shellBuiltins $name] != -1} {
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 {[string equal $tcl_platform(os) "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 {;}] {
if {[info exists checked($dir)] || [string equal {} $dir]} { 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 {
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 {[string equal $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 ""
}
}
proc tcl::CopyDirectory {action src dest} {
set nsrc [file normalize $src]
set ndest [file normalize $dest]
if {[string equal $action "renaming"]} {
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 == $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
if {[string equal $action "copying"]} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
} else {
set existing [glob -nocomplain -directory $dest * .*]
eval [list lappend existing] \
[glob -nocomplain -directory $dest -type hidden * .*]
foreach s $existing {
if {([file tail $s] != ".") && ([file tail $s] != "..")} {
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 == [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
}
set filelist [concat [glob -nocomplain -directory $src *] \
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
if {([file tail $s] != ".") && ([file tail $s] != "..")} {
file copy $s [file join $dest [file tail $s]]
}
}
return
}