os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/init.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/init.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,750 @@
1.4 +# init.tcl --
1.5 +#
1.6 +# Default system startup file for Tcl-based applications. Defines
1.7 +# "unknown" procedure and auto-load facilities.
1.8 +#
1.9 +# RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $
1.10 +#
1.11 +# Copyright (c) 1991-1993 The Regents of the University of California.
1.12 +# Copyright (c) 1994-1996 Sun Microsystems, Inc.
1.13 +# Copyright (c) 1998-1999 Scriptics Corporation.
1.14 +# Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.15 +#
1.16 +# See the file "license.terms" for information on usage and redistribution
1.17 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.18 +#
1.19 +
1.20 +if {[info commands package] == ""} {
1.21 + error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
1.22 +}
1.23 +package require -exact Tcl 8.4
1.24 +
1.25 +# Compute the auto path to use in this interpreter.
1.26 +# The values on the path come from several locations:
1.27 +#
1.28 +# The environment variable TCLLIBPATH
1.29 +#
1.30 +# tcl_library, which is the directory containing this init.tcl script.
1.31 +# tclInitScript.h searches around for the directory containing this
1.32 +# init.tcl and defines tcl_library to that location before sourcing it.
1.33 +#
1.34 +# The parent directory of tcl_library. Adding the parent
1.35 +# means that packages in peer directories will be found automatically.
1.36 +#
1.37 +# Also add the directory ../lib relative to the directory where the
1.38 +# executable is located. This is meant to find binary packages for the
1.39 +# same architecture as the current executable.
1.40 +#
1.41 +# tcl_pkgPath, which is set by the platform-specific initialization routines
1.42 +# On UNIX it is compiled in
1.43 +# On Windows, it is not used
1.44 +# On Macintosh it is "Tool Command Language" in the Extensions folder
1.45 +
1.46 +if {![info exists auto_path]} {
1.47 + if {[info exists env(TCLLIBPATH)]} {
1.48 + set auto_path $env(TCLLIBPATH)
1.49 + } else {
1.50 + set auto_path ""
1.51 + }
1.52 +}
1.53 +namespace eval tcl {
1.54 + variable Dir
1.55 + if {[info library] ne ""} {
1.56 + foreach Dir [list [info library] [file dirname [info library]]] {
1.57 + if {[lsearch -exact $::auto_path $Dir] < 0} {
1.58 + lappend ::auto_path $Dir
1.59 + }
1.60 + }
1.61 + }
1.62 + if {![string equal $tcl_platform(osSystemName) "Symbian"]} {
1.63 + set Dir [file join [file dirname [file dirname \
1.64 + [info nameofexecutable]]] lib]
1.65 + }
1.66 + if {[lsearch -exact $::auto_path $Dir] < 0} {
1.67 + lappend ::auto_path $Dir
1.68 + }
1.69 + if {[info exists ::tcl_pkgPath]} {
1.70 + foreach Dir $::tcl_pkgPath {
1.71 + if {[lsearch -exact $::auto_path $Dir] < 0} {
1.72 + lappend ::auto_path $Dir
1.73 + }
1.74 + }
1.75 + }
1.76 +}
1.77 +
1.78 +# Windows specific end of initialization
1.79 +
1.80 +if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
1.81 + namespace eval tcl {
1.82 + proc EnvTraceProc {lo n1 n2 op} {
1.83 + set x $::env($n2)
1.84 + set ::env($lo) $x
1.85 + set ::env([string toupper $lo]) $x
1.86 + }
1.87 + proc InitWinEnv {} {
1.88 + global env tcl_platform
1.89 + foreach p [array names env] {
1.90 + set u [string toupper $p]
1.91 + if {$u ne $p} {
1.92 + switch -- $u {
1.93 + COMSPEC -
1.94 + PATH {
1.95 + if {![info exists env($u)]} {
1.96 + set env($u) $env($p)
1.97 + }
1.98 + trace add variable env($p) write \
1.99 + [namespace code [list EnvTraceProc $p]]
1.100 + trace add variable env($u) write \
1.101 + [namespace code [list EnvTraceProc $p]]
1.102 + }
1.103 + }
1.104 + }
1.105 + }
1.106 + if {![info exists env(COMSPEC)]} {
1.107 + if {$tcl_platform(os) eq "Windows NT"} {
1.108 + set env(COMSPEC) cmd.exe
1.109 + } else {
1.110 + set env(COMSPEC) command.com
1.111 + }
1.112 + }
1.113 + }
1.114 + InitWinEnv
1.115 + }
1.116 +}
1.117 +
1.118 +# Setup the unknown package handler
1.119 +
1.120 +package unknown tclPkgUnknown
1.121 +
1.122 +if {![interp issafe]} {
1.123 + # setup platform specific unknown package handlers
1.124 + if {$::tcl_platform(platform) eq "unix"
1.125 + && $::tcl_platform(os) eq "Darwin"} {
1.126 + package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
1.127 + }
1.128 + if {$::tcl_platform(platform) eq "macintosh"} {
1.129 + package unknown [list tcl::MacPkgUnknown [package unknown]]
1.130 + }
1.131 +}
1.132 +
1.133 +# Conditionalize for presence of exec.
1.134 +
1.135 +if {[namespace which -command exec] eq ""} {
1.136 +
1.137 + # Some machines, such as the Macintosh, do not have exec. Also, on all
1.138 + # platforms, safe interpreters do not have exec.
1.139 +
1.140 + set auto_noexec 1
1.141 +}
1.142 +set errorCode ""
1.143 +set errorInfo ""
1.144 +
1.145 +# Define a log command (which can be overwitten to log errors
1.146 +# differently, specially when stderr is not available)
1.147 +
1.148 +if {[namespace which -command tclLog] eq ""} {
1.149 + proc tclLog {string} {
1.150 + catch {puts stderr $string}
1.151 + }
1.152 +}
1.153 +
1.154 +# unknown --
1.155 +# This procedure is called when a Tcl command is invoked that doesn't
1.156 +# exist in the interpreter. It takes the following steps to make the
1.157 +# command available:
1.158 +#
1.159 +# 1. See if the command has the form "namespace inscope ns cmd" and
1.160 +# if so, concatenate its arguments onto the end and evaluate it.
1.161 +# 2. See if the autoload facility can locate the command in a
1.162 +# Tcl script file. If so, load it and execute it.
1.163 +# 3. If the command was invoked interactively at top-level:
1.164 +# (a) see if the command exists as an executable UNIX program.
1.165 +# If so, "exec" the command.
1.166 +# (b) see if the command requests csh-like history substitution
1.167 +# in one of the common forms !!, !<number>, or ^old^new. If
1.168 +# so, emulate csh's history substitution.
1.169 +# (c) see if the command is a unique abbreviation for another
1.170 +# command. If so, invoke the command.
1.171 +#
1.172 +# Arguments:
1.173 +# args - A list whose elements are the words of the original
1.174 +# command, including the command name.
1.175 +
1.176 +proc unknown args {
1.177 + global auto_noexec auto_noload env unknown_pending tcl_interactive
1.178 + global errorCode errorInfo
1.179 +
1.180 + # If the command word has the form "namespace inscope ns cmd"
1.181 + # then concatenate its arguments onto the end and evaluate it.
1.182 +
1.183 + set cmd [lindex $args 0]
1.184 + if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
1.185 + set arglist [lrange $args 1 end]
1.186 + set ret [catch {uplevel 1 ::$cmd $arglist} result]
1.187 + if {$ret == 0} {
1.188 + return $result
1.189 + } else {
1.190 + return -code $ret -errorcode $errorCode $result
1.191 + }
1.192 + }
1.193 +
1.194 + # Save the values of errorCode and errorInfo variables, since they
1.195 + # may get modified if caught errors occur below. The variables will
1.196 + # be restored just before re-executing the missing command.
1.197 +
1.198 + # Safety check in case something unsets the variables
1.199 + # ::errorInfo or ::errorCode. [Bug 1063707]
1.200 + if {![info exists errorCode]} {
1.201 + set errorCode ""
1.202 + }
1.203 + if {![info exists errorInfo]} {
1.204 + set errorInfo ""
1.205 + }
1.206 + set savedErrorCode $errorCode
1.207 + set savedErrorInfo $errorInfo
1.208 + set name $cmd
1.209 + if {![info exists auto_noload]} {
1.210 + #
1.211 + # Make sure we're not trying to load the same proc twice.
1.212 + #
1.213 + if {[info exists unknown_pending($name)]} {
1.214 + return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
1.215 + }
1.216 + set unknown_pending($name) pending;
1.217 + set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
1.218 + unset unknown_pending($name);
1.219 + if {$ret != 0} {
1.220 + append errorInfo "\n (autoloading \"$name\")"
1.221 + return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
1.222 + }
1.223 + if {![array size unknown_pending]} {
1.224 + unset unknown_pending
1.225 + }
1.226 + if {$msg} {
1.227 + set errorCode $savedErrorCode
1.228 + set errorInfo $savedErrorInfo
1.229 + set code [catch {uplevel 1 $args} msg]
1.230 + if {$code == 1} {
1.231 + #
1.232 + # Compute stack trace contribution from the [uplevel].
1.233 + # Note the dependence on how Tcl_AddErrorInfo, etc.
1.234 + # construct the stack trace.
1.235 + #
1.236 + set cinfo $args
1.237 + set ellipsis ""
1.238 + while {[string bytelength $cinfo] > 150} {
1.239 + set cinfo [string range $cinfo 0 end-1]
1.240 + set ellipsis "..."
1.241 + }
1.242 + append cinfo $ellipsis "\"\n (\"uplevel\" body line 1)"
1.243 + append cinfo "\n invoked from within"
1.244 + append cinfo "\n\"uplevel 1 \$args\""
1.245 + #
1.246 + # Try each possible form of the stack trace
1.247 + # and trim the extra contribution from the matching case
1.248 + #
1.249 + set expect "$msg\n while executing\n\"$cinfo"
1.250 + if {$errorInfo eq $expect} {
1.251 + #
1.252 + # The stack has only the eval from the expanded command
1.253 + # Do not generate any stack trace here.
1.254 + #
1.255 + return -code error -errorcode $errorCode $msg
1.256 + }
1.257 + #
1.258 + # Stack trace is nested, trim off just the contribution
1.259 + # from the extra "eval" of $args due to the "catch" above.
1.260 + #
1.261 + set expect "\n invoked from within\n\"$cinfo"
1.262 + set exlen [string length $expect]
1.263 + set eilen [string length $errorInfo]
1.264 + set i [expr {$eilen - $exlen - 1}]
1.265 + set einfo [string range $errorInfo 0 $i]
1.266 + #
1.267 + # For now verify that $errorInfo consists of what we are about
1.268 + # to return plus what we expected to trim off.
1.269 + #
1.270 + if {$errorInfo ne "$einfo$expect"} {
1.271 + error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
1.272 + [list CORE UNKNOWN BADTRACE $expect $errorInfo]
1.273 + }
1.274 + return -code error -errorcode $errorCode \
1.275 + -errorinfo $einfo $msg
1.276 + } else {
1.277 + return -code $code $msg
1.278 + }
1.279 + }
1.280 + }
1.281 +
1.282 + if {([info level] == 1) && [info script] eq "" \
1.283 + && [info exists tcl_interactive] && $tcl_interactive} {
1.284 + if {![info exists auto_noexec]} {
1.285 + set new [auto_execok $name]
1.286 + if {$new ne ""} {
1.287 + set errorCode $savedErrorCode
1.288 + set errorInfo $savedErrorInfo
1.289 + set redir ""
1.290 + if {[namespace which -command console] eq ""} {
1.291 + set redir ">&@stdout <@stdin"
1.292 + }
1.293 + return [uplevel 1 exec $redir $new [lrange $args 1 end]]
1.294 + }
1.295 + }
1.296 + set errorCode $savedErrorCode
1.297 + set errorInfo $savedErrorInfo
1.298 + if {$name eq "!!"} {
1.299 + set newcmd [history event]
1.300 + } elseif {[regexp {^!(.+)$} $name -> event]} {
1.301 + set newcmd [history event $event]
1.302 + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
1.303 + set newcmd [history event -1]
1.304 + catch {regsub -all -- $old $newcmd $new newcmd}
1.305 + }
1.306 + if {[info exists newcmd]} {
1.307 + tclLog $newcmd
1.308 + history change $newcmd 0
1.309 + return [uplevel 1 $newcmd]
1.310 + }
1.311 +
1.312 + set ret [catch {set candidates [info commands $name*]} msg]
1.313 + if {$name eq "::"} {
1.314 + set name ""
1.315 + }
1.316 + if {$ret != 0} {
1.317 + return -code $ret -errorcode $errorCode \
1.318 + "error in unknown while checking if \"$name\" is\
1.319 + a unique command abbreviation:\n$msg"
1.320 + }
1.321 + # Handle empty $name separately due to strangeness in [string first]
1.322 + if {$name eq ""} {
1.323 + if {[llength $candidates] != 1} {
1.324 + return -code error "empty command name \"\""
1.325 + }
1.326 + return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
1.327 + }
1.328 + # Filter out bogus matches when $name contained
1.329 + # a glob-special char [Bug 946952]
1.330 + set cmds [list]
1.331 + foreach x $candidates {
1.332 + if {[string first $name $x] == 0} {
1.333 + lappend cmds $x
1.334 + }
1.335 + }
1.336 + if {[llength $cmds] == 1} {
1.337 + return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
1.338 + }
1.339 + if {[llength $cmds]} {
1.340 + return -code error "ambiguous command name \"$name\": [lsort $cmds]"
1.341 + }
1.342 + }
1.343 + return -code error "invalid command name \"$name\""
1.344 +}
1.345 +
1.346 +# auto_load --
1.347 +# Checks a collection of library directories to see if a procedure
1.348 +# is defined in one of them. If so, it sources the appropriate
1.349 +# library file to create the procedure. Returns 1 if it successfully
1.350 +# loaded the procedure, 0 otherwise.
1.351 +#
1.352 +# Arguments:
1.353 +# cmd - Name of the command to find and load.
1.354 +# namespace (optional) The namespace where the command is being used - must be
1.355 +# a canonical namespace as returned [namespace current]
1.356 +# for instance. If not given, namespace current is used.
1.357 +
1.358 +proc auto_load {cmd {namespace {}}} {
1.359 + global auto_index auto_oldpath auto_path
1.360 +
1.361 + if {$namespace eq ""} {
1.362 + set namespace [uplevel 1 [list ::namespace current]]
1.363 + }
1.364 + set nameList [auto_qualify $cmd $namespace]
1.365 + # workaround non canonical auto_index entries that might be around
1.366 + # from older auto_mkindex versions
1.367 + lappend nameList $cmd
1.368 + foreach name $nameList {
1.369 + if {[info exists auto_index($name)]} {
1.370 + namespace eval :: $auto_index($name)
1.371 + # There's a couple of ways to look for a command of a given
1.372 + # name. One is to use
1.373 + # info commands $name
1.374 + # Unfortunately, if the name has glob-magic chars in it like *
1.375 + # or [], it may not match. For our purposes here, a better
1.376 + # route is to use
1.377 + # namespace which -command $name
1.378 + if {[namespace which -command $name] ne ""} {
1.379 + return 1
1.380 + }
1.381 + }
1.382 + }
1.383 + if {![info exists auto_path]} {
1.384 + return 0
1.385 + }
1.386 +
1.387 + if {![auto_load_index]} {
1.388 + return 0
1.389 + }
1.390 + foreach name $nameList {
1.391 + if {[info exists auto_index($name)]} {
1.392 + namespace eval :: $auto_index($name)
1.393 + if {[namespace which -command $name] ne ""} {
1.394 + return 1
1.395 + }
1.396 + }
1.397 + }
1.398 + return 0
1.399 +}
1.400 +
1.401 +# auto_load_index --
1.402 +# Loads the contents of tclIndex files on the auto_path directory
1.403 +# list. This is usually invoked within auto_load to load the index
1.404 +# of available commands. Returns 1 if the index is loaded, and 0 if
1.405 +# the index is already loaded and up to date.
1.406 +#
1.407 +# Arguments:
1.408 +# None.
1.409 +
1.410 +proc auto_load_index {} {
1.411 + global auto_index auto_oldpath auto_path errorInfo errorCode
1.412 +
1.413 + if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
1.414 + return 0
1.415 + }
1.416 + set auto_oldpath $auto_path
1.417 +
1.418 + # Check if we are a safe interpreter. In that case, we support only
1.419 + # newer format tclIndex files.
1.420 +
1.421 + set issafe [interp issafe]
1.422 + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
1.423 + set dir [lindex $auto_path $i]
1.424 + set f ""
1.425 + if {$issafe} {
1.426 + catch {source [file join $dir tclIndex]}
1.427 + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
1.428 + continue
1.429 + } else {
1.430 + set error [catch {
1.431 + set id [gets $f]
1.432 + if {$id eq "# Tcl autoload index file, version 2.0"} {
1.433 + eval [read $f]
1.434 + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
1.435 + while {[gets $f line] >= 0} {
1.436 + if {[string index $line 0] eq "#"
1.437 + || ([llength $line] != 2)} {
1.438 + continue
1.439 + }
1.440 + set name [lindex $line 0]
1.441 + set auto_index($name) \
1.442 + "source [file join $dir [lindex $line 1]]"
1.443 + }
1.444 + } else {
1.445 + error "[file join $dir tclIndex] isn't a proper Tcl index file"
1.446 + }
1.447 + } msg]
1.448 + if {$f ne ""} {
1.449 + close $f
1.450 + }
1.451 + if {$error} {
1.452 + error $msg $errorInfo $errorCode
1.453 + }
1.454 + }
1.455 + }
1.456 + return 1
1.457 +}
1.458 +
1.459 +# auto_qualify --
1.460 +#
1.461 +# Compute a fully qualified names list for use in the auto_index array.
1.462 +# For historical reasons, commands in the global namespace do not have leading
1.463 +# :: in the index key. The list has two elements when the command name is
1.464 +# relative (no leading ::) and the namespace is not the global one. Otherwise
1.465 +# only one name is returned (and searched in the auto_index).
1.466 +#
1.467 +# Arguments -
1.468 +# cmd The command name. Can be any name accepted for command
1.469 +# invocations (Like "foo::::bar").
1.470 +# namespace The namespace where the command is being used - must be
1.471 +# a canonical namespace as returned by [namespace current]
1.472 +# for instance.
1.473 +
1.474 +proc auto_qualify {cmd namespace} {
1.475 +
1.476 + # count separators and clean them up
1.477 + # (making sure that foo:::::bar will be treated as foo::bar)
1.478 + set n [regsub -all {::+} $cmd :: cmd]
1.479 +
1.480 + # Ignore namespace if the name starts with ::
1.481 + # Handle special case of only leading ::
1.482 +
1.483 + # Before each return case we give an example of which category it is
1.484 + # with the following form :
1.485 + # ( inputCmd, inputNameSpace) -> output
1.486 +
1.487 + if {[string match ::* $cmd]} {
1.488 + if {$n > 1} {
1.489 + # ( ::foo::bar , * ) -> ::foo::bar
1.490 + return [list $cmd]
1.491 + } else {
1.492 + # ( ::global , * ) -> global
1.493 + return [list [string range $cmd 2 end]]
1.494 + }
1.495 + }
1.496 +
1.497 + # Potentially returning 2 elements to try :
1.498 + # (if the current namespace is not the global one)
1.499 +
1.500 + if {$n == 0} {
1.501 + if {$namespace eq "::"} {
1.502 + # ( nocolons , :: ) -> nocolons
1.503 + return [list $cmd]
1.504 + } else {
1.505 + # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
1.506 + return [list ${namespace}::$cmd $cmd]
1.507 + }
1.508 + } elseif {$namespace eq "::"} {
1.509 + # ( foo::bar , :: ) -> ::foo::bar
1.510 + return [list ::$cmd]
1.511 + } else {
1.512 + # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
1.513 + return [list ${namespace}::$cmd ::$cmd]
1.514 + }
1.515 +}
1.516 +
1.517 +# auto_import --
1.518 +#
1.519 +# Invoked during "namespace import" to make see if the imported commands
1.520 +# reside in an autoloaded library. If so, the commands are loaded so
1.521 +# that they will be available for the import links. If not, then this
1.522 +# procedure does nothing.
1.523 +#
1.524 +# Arguments -
1.525 +# pattern The pattern of commands being imported (like "foo::*")
1.526 +# a canonical namespace as returned by [namespace current]
1.527 +
1.528 +proc auto_import {pattern} {
1.529 + global auto_index
1.530 +
1.531 + # If no namespace is specified, this will be an error case
1.532 +
1.533 + if {![string match *::* $pattern]} {
1.534 + return
1.535 + }
1.536 +
1.537 + set ns [uplevel 1 [list ::namespace current]]
1.538 + set patternList [auto_qualify $pattern $ns]
1.539 +
1.540 + auto_load_index
1.541 +
1.542 + foreach pattern $patternList {
1.543 + foreach name [array names auto_index $pattern] {
1.544 + if {([namespace which -command $name] eq "")
1.545 + && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
1.546 + namespace eval :: $auto_index($name)
1.547 + }
1.548 + }
1.549 + }
1.550 +}
1.551 +
1.552 +# auto_execok --
1.553 +#
1.554 +# Returns string that indicates name of program to execute if
1.555 +# name corresponds to a shell builtin or an executable in the
1.556 +# Windows search path, or "" otherwise. Builds an associative
1.557 +# array auto_execs that caches information about previous checks,
1.558 +# for speed.
1.559 +#
1.560 +# Arguments:
1.561 +# name - Name of a command.
1.562 +
1.563 +if {$tcl_platform(platform) eq "windows"} {
1.564 +# Windows version.
1.565 +#
1.566 +# Note that info executable doesn't work under Windows, so we have to
1.567 +# look for files with .exe, .com, or .bat extensions. Also, the path
1.568 +# may be in the Path or PATH environment variables, and path
1.569 +# components are separated with semicolons, not colons as under Unix.
1.570 +#
1.571 +proc auto_execok name {
1.572 + global auto_execs env tcl_platform
1.573 +
1.574 + if {[info exists auto_execs($name)]} {
1.575 + return $auto_execs($name)
1.576 + }
1.577 + set auto_execs($name) ""
1.578 +
1.579 + set shellBuiltins [list cls copy date del erase dir echo mkdir \
1.580 + md rename ren rmdir rd time type ver vol]
1.581 + if {$tcl_platform(os) eq "Windows NT"} {
1.582 + # NT includes the 'start' built-in
1.583 + lappend shellBuiltins "start"
1.584 + }
1.585 + if {[info exists env(PATHEXT)]} {
1.586 + # Add an initial ; to have the {} extension check first.
1.587 + set execExtensions [split ";$env(PATHEXT)" ";"]
1.588 + } else {
1.589 + set execExtensions [list {} .com .exe .bat]
1.590 + }
1.591 +
1.592 + if {[lsearch -exact $shellBuiltins $name] != -1} {
1.593 + # When this is command.com for some reason on Win2K, Tcl won't
1.594 + # exec it unless the case is right, which this corrects. COMSPEC
1.595 + # may not point to a real file, so do the check.
1.596 + set cmd $env(COMSPEC)
1.597 + if {[file exists $cmd]} {
1.598 + set cmd [file attributes $cmd -shortname]
1.599 + }
1.600 + return [set auto_execs($name) [list $cmd /c $name]]
1.601 + }
1.602 +
1.603 + if {[llength [file split $name]] != 1} {
1.604 + foreach ext $execExtensions {
1.605 + set file ${name}${ext}
1.606 + if {[file exists $file] && ![file isdirectory $file]} {
1.607 + return [set auto_execs($name) [list $file]]
1.608 + }
1.609 + }
1.610 + return ""
1.611 + }
1.612 +
1.613 + set path "[file dirname [info nameof]];.;"
1.614 + if {[info exists env(WINDIR)]} {
1.615 + set windir $env(WINDIR)
1.616 + }
1.617 + if {[info exists windir]} {
1.618 + if {$tcl_platform(os) eq "Windows NT"} {
1.619 + append path "$windir/system32;"
1.620 + }
1.621 + append path "$windir/system;$windir;"
1.622 + }
1.623 +
1.624 + foreach var {PATH Path path} {
1.625 + if {[info exists env($var)]} {
1.626 + append path ";$env($var)"
1.627 + }
1.628 + }
1.629 +
1.630 + foreach dir [split $path {;}] {
1.631 + # Skip already checked directories
1.632 + if {[info exists checked($dir)] || $dir eq {}} { continue }
1.633 + set checked($dir) {}
1.634 + foreach ext $execExtensions {
1.635 + set file [file join $dir ${name}${ext}]
1.636 + if {[file exists $file] && ![file isdirectory $file]} {
1.637 + return [set auto_execs($name) [list $file]]
1.638 + }
1.639 + }
1.640 + }
1.641 + return ""
1.642 +}
1.643 +
1.644 +} else {
1.645 +# Unix version.
1.646 +#
1.647 +proc auto_execok name {
1.648 + global auto_execs env
1.649 +
1.650 + if {[info exists auto_execs($name)]} {
1.651 + return $auto_execs($name)
1.652 + }
1.653 + set auto_execs($name) ""
1.654 + if {[llength [file split $name]] != 1} {
1.655 + if {[file executable $name] && ![file isdirectory $name]} {
1.656 + set auto_execs($name) [list $name]
1.657 + }
1.658 + return $auto_execs($name)
1.659 + }
1.660 + foreach dir [split $env(PATH) :] {
1.661 + if {$dir eq ""} {
1.662 + set dir .
1.663 + }
1.664 + set file [file join $dir $name]
1.665 + if {[file executable $file] && ![file isdirectory $file]} {
1.666 + set auto_execs($name) [list $file]
1.667 + return $auto_execs($name)
1.668 + }
1.669 + }
1.670 + return ""
1.671 +}
1.672 +
1.673 +}
1.674 +
1.675 +# ::tcl::CopyDirectory --
1.676 +#
1.677 +# This procedure is called by Tcl's core when attempts to call the
1.678 +# filesystem's copydirectory function fail. The semantics of the call
1.679 +# are that 'dest' does not yet exist, i.e. dest should become the exact
1.680 +# image of src. If dest does exist, we throw an error.
1.681 +#
1.682 +# Note that making changes to this procedure can change the results
1.683 +# of running Tcl's tests.
1.684 +#
1.685 +# Arguments:
1.686 +# action - "renaming" or "copying"
1.687 +# src - source directory
1.688 +# dest - destination directory
1.689 +proc tcl::CopyDirectory {action src dest} {
1.690 + set nsrc [file normalize $src]
1.691 + set ndest [file normalize $dest]
1.692 + if {$action eq "renaming"} {
1.693 + # Can't rename volumes. We could give a more precise
1.694 + # error message here, but that would break the test suite.
1.695 + if {[lsearch -exact [file volumes] $nsrc] != -1} {
1.696 + return -code error "error $action \"$src\" to\
1.697 + \"$dest\": trying to rename a volume or move a directory\
1.698 + into itself"
1.699 + }
1.700 + }
1.701 + if {[file exists $dest]} {
1.702 + if {$nsrc eq $ndest} {
1.703 + return -code error "error $action \"$src\" to\
1.704 + \"$dest\": trying to rename a volume or move a directory\
1.705 + into itself"
1.706 + }
1.707 + if {$action eq "copying"} {
1.708 + return -code error "error $action \"$src\" to\
1.709 + \"$dest\": file already exists"
1.710 + } else {
1.711 + # Depending on the platform, and on the current
1.712 + # working directory, the directories '.', '..'
1.713 + # can be returned in various combinations. Anyway,
1.714 + # if any other file is returned, we must signal an error.
1.715 + set existing [glob -nocomplain -directory $dest * .*]
1.716 + eval [linsert \
1.717 + [glob -nocomplain -directory $dest -type hidden * .*] 0 \
1.718 + lappend existing]
1.719 + foreach s $existing {
1.720 + if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
1.721 + return -code error "error $action \"$src\" to\
1.722 + \"$dest\": file already exists"
1.723 + }
1.724 + }
1.725 + }
1.726 + } else {
1.727 + if {[string first $nsrc $ndest] != -1} {
1.728 + set srclen [expr {[llength [file split $nsrc]] -1}]
1.729 + set ndest [lindex [file split $ndest] $srclen]
1.730 + if {$ndest eq [file tail $nsrc]} {
1.731 + return -code error "error $action \"$src\" to\
1.732 + \"$dest\": trying to rename a volume or move a directory\
1.733 + into itself"
1.734 + }
1.735 + }
1.736 + file mkdir $dest
1.737 + }
1.738 + # Have to be careful to capture both visible and hidden files.
1.739 + # We will also be more generous to the file system and not
1.740 + # assume the hidden and non-hidden lists are non-overlapping.
1.741 + #
1.742 + # On Unix 'hidden' files begin with '.'. On other platforms
1.743 + # or filesystems hidden files may have other interpretations.
1.744 + set filelist [concat [glob -nocomplain -directory $src *] \
1.745 + [glob -nocomplain -directory $src -types hidden *]]
1.746 +
1.747 + foreach s [lsort -unique $filelist] {
1.748 + if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
1.749 + file copy $s [file join $dest [file tail $s]]
1.750 + }
1.751 + }
1.752 + return
1.753 +}