os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/library/init.tcl
author sl
Tue, 10 Jun 2014 14:32:02 +0200
changeset 1 260cb5ec6c19
permissions -rw-r--r--
Update contrib.
     1 # init.tcl --
     2 #
     3 # Default system startup file for Tcl-based applications.  Defines
     4 # "unknown" procedure and auto-load facilities.
     5 #
     6 # RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $
     7 #
     8 # Copyright (c) 1991-1993 The Regents of the University of California.
     9 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
    10 # Copyright (c) 1998-1999 Scriptics Corporation.
    11 # Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.  
    12 #
    13 # See the file "license.terms" for information on usage and redistribution
    14 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    15 #
    16 
    17 if {[info commands package] == ""} {
    18     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
    19 }
    20 package require -exact Tcl 8.4
    21 
    22 # Compute the auto path to use in this interpreter.
    23 # The values on the path come from several locations:
    24 #
    25 # The environment variable TCLLIBPATH
    26 #
    27 # tcl_library, which is the directory containing this init.tcl script.
    28 # tclInitScript.h searches around for the directory containing this
    29 # init.tcl and defines tcl_library to that location before sourcing it.
    30 #
    31 # The parent directory of tcl_library. Adding the parent
    32 # means that packages in peer directories will be found automatically.
    33 #
    34 # Also add the directory ../lib relative to the directory where the
    35 # executable is located.  This is meant to find binary packages for the
    36 # same architecture as the current executable.
    37 #
    38 # tcl_pkgPath, which is set by the platform-specific initialization routines
    39 #	On UNIX it is compiled in
    40 #       On Windows, it is not used
    41 #	On Macintosh it is "Tool Command Language" in the Extensions folder
    42 
    43 if {![info exists auto_path]} {
    44     if {[info exists env(TCLLIBPATH)]} {
    45 	set auto_path $env(TCLLIBPATH)
    46     } else {
    47 	set auto_path ""
    48     }
    49 }
    50 namespace eval tcl {
    51     variable Dir
    52     if {[info library] ne ""} {
    53 	foreach Dir [list [info library] [file dirname [info library]]] {
    54 	    if {[lsearch -exact $::auto_path $Dir] < 0} {
    55 		lappend ::auto_path $Dir
    56 	    }
    57 	}
    58     }
    59     if {![string equal $tcl_platform(osSystemName) "Symbian"]} {
    60        set Dir [file join [file dirname [file dirname \
    61 	 [info nameofexecutable]]] lib]
    62     }
    63     if {[lsearch -exact $::auto_path $Dir] < 0} {
    64 	lappend ::auto_path $Dir
    65     }
    66     if {[info exists ::tcl_pkgPath]} {
    67 	foreach Dir $::tcl_pkgPath {
    68 	    if {[lsearch -exact $::auto_path $Dir] < 0} {
    69 		lappend ::auto_path $Dir
    70 	    }
    71 	}
    72     }
    73 }
    74   
    75 # Windows specific end of initialization
    76 
    77 if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
    78     namespace eval tcl {
    79 	proc EnvTraceProc {lo n1 n2 op} {
    80 	    set x $::env($n2)
    81 	    set ::env($lo) $x
    82 	    set ::env([string toupper $lo]) $x
    83 	}
    84 	proc InitWinEnv {} {
    85 	    global env tcl_platform
    86 	    foreach p [array names env] {
    87 		set u [string toupper $p]
    88 		if {$u ne $p} {
    89 		    switch -- $u {
    90 			COMSPEC -
    91 			PATH {
    92 			    if {![info exists env($u)]} {
    93 				set env($u) $env($p)
    94 			    }
    95 			    trace add variable env($p) write \
    96 				    [namespace code [list EnvTraceProc $p]]
    97 			    trace add variable env($u) write \
    98 				    [namespace code [list EnvTraceProc $p]]
    99 			}
   100 		    }
   101 		}
   102 	    }
   103 	    if {![info exists env(COMSPEC)]} {
   104 		if {$tcl_platform(os) eq "Windows NT"} {
   105 		    set env(COMSPEC) cmd.exe
   106 		} else {
   107 		    set env(COMSPEC) command.com
   108 		}
   109 	    }
   110 	}
   111 	InitWinEnv
   112     }
   113 }
   114 
   115 # Setup the unknown package handler
   116 
   117 package unknown tclPkgUnknown
   118 
   119 if {![interp issafe]} {
   120     # setup platform specific unknown package handlers
   121     if {$::tcl_platform(platform) eq "unix"
   122 	    && $::tcl_platform(os) eq "Darwin"} {
   123 	package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
   124     }
   125     if {$::tcl_platform(platform) eq "macintosh"} {
   126 	package unknown [list tcl::MacPkgUnknown [package unknown]]
   127     }
   128 }
   129 
   130 # Conditionalize for presence of exec.
   131 
   132 if {[namespace which -command exec] eq ""} {
   133 
   134     # Some machines, such as the Macintosh, do not have exec. Also, on all
   135     # platforms, safe interpreters do not have exec.
   136 
   137     set auto_noexec 1
   138 }
   139 set errorCode ""
   140 set errorInfo ""
   141 
   142 # Define a log command (which can be overwitten to log errors
   143 # differently, specially when stderr is not available)
   144 
   145 if {[namespace which -command tclLog] eq ""} {
   146     proc tclLog {string} {
   147 	catch {puts stderr $string}
   148     }
   149 }
   150 
   151 # unknown --
   152 # This procedure is called when a Tcl command is invoked that doesn't
   153 # exist in the interpreter.  It takes the following steps to make the
   154 # command available:
   155 #
   156 #	1. See if the command has the form "namespace inscope ns cmd" and
   157 #	   if so, concatenate its arguments onto the end and evaluate it.
   158 #	2. See if the autoload facility can locate the command in a
   159 #	   Tcl script file.  If so, load it and execute it.
   160 #	3. If the command was invoked interactively at top-level:
   161 #	    (a) see if the command exists as an executable UNIX program.
   162 #		If so, "exec" the command.
   163 #	    (b) see if the command requests csh-like history substitution
   164 #		in one of the common forms !!, !<number>, or ^old^new.  If
   165 #		so, emulate csh's history substitution.
   166 #	    (c) see if the command is a unique abbreviation for another
   167 #		command.  If so, invoke the command.
   168 #
   169 # Arguments:
   170 # args -	A list whose elements are the words of the original
   171 #		command, including the command name.
   172 
   173 proc unknown args {
   174     global auto_noexec auto_noload env unknown_pending tcl_interactive
   175     global errorCode errorInfo
   176 
   177     # If the command word has the form "namespace inscope ns cmd"
   178     # then concatenate its arguments onto the end and evaluate it.
   179 
   180     set cmd [lindex $args 0]
   181     if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
   182         set arglist [lrange $args 1 end]
   183 	set ret [catch {uplevel 1 ::$cmd $arglist} result]
   184         if {$ret == 0} {
   185             return $result
   186         } else {
   187 	    return -code $ret -errorcode $errorCode $result
   188         }
   189     }
   190 
   191     # Save the values of errorCode and errorInfo variables, since they
   192     # may get modified if caught errors occur below.  The variables will
   193     # be restored just before re-executing the missing command.
   194 
   195     # Safety check in case something unsets the variables 
   196     # ::errorInfo or ::errorCode.  [Bug 1063707]
   197     if {![info exists errorCode]} {
   198 	set errorCode ""
   199     }
   200     if {![info exists errorInfo]} {
   201 	set errorInfo ""
   202     }
   203     set savedErrorCode $errorCode
   204     set savedErrorInfo $errorInfo
   205     set name $cmd
   206     if {![info exists auto_noload]} {
   207 	#
   208 	# Make sure we're not trying to load the same proc twice.
   209 	#
   210 	if {[info exists unknown_pending($name)]} {
   211 	    return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
   212 	}
   213 	set unknown_pending($name) pending;
   214 	set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
   215 	unset unknown_pending($name);
   216 	if {$ret != 0} {
   217 	    append errorInfo "\n    (autoloading \"$name\")"
   218 	    return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
   219 	}
   220 	if {![array size unknown_pending]} {
   221 	    unset unknown_pending
   222 	}
   223 	if {$msg} {
   224 	    set errorCode $savedErrorCode
   225 	    set errorInfo $savedErrorInfo
   226 	    set code [catch {uplevel 1 $args} msg]
   227 	    if {$code ==  1} {
   228 		#
   229 		# Compute stack trace contribution from the [uplevel].
   230 		# Note the dependence on how Tcl_AddErrorInfo, etc. 
   231 		# construct the stack trace.
   232 		#
   233 		set cinfo $args
   234 		set ellipsis ""
   235 		while {[string bytelength $cinfo] > 150} {
   236 		    set cinfo [string range $cinfo 0 end-1]
   237 		    set ellipsis "..."
   238 		}
   239 		append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
   240 		append cinfo "\n    invoked from within"
   241 		append cinfo "\n\"uplevel 1 \$args\""
   242 		#
   243 		# Try each possible form of the stack trace
   244 		# and trim the extra contribution from the matching case
   245 		#
   246 		set expect "$msg\n    while executing\n\"$cinfo"
   247 		if {$errorInfo eq $expect} {
   248 		    #
   249 		    # The stack has only the eval from the expanded command
   250 		    # Do not generate any stack trace here.
   251 		    #
   252 		    return -code error -errorcode $errorCode $msg
   253 		}
   254 		#
   255 		# Stack trace is nested, trim off just the contribution
   256 		# from the extra "eval" of $args due to the "catch" above.
   257 		#
   258 		set expect "\n    invoked from within\n\"$cinfo"
   259 		set exlen [string length $expect]
   260 		set eilen [string length $errorInfo]
   261 		set i [expr {$eilen - $exlen - 1}]
   262 		set einfo [string range $errorInfo 0 $i]
   263 		#
   264 		# For now verify that $errorInfo consists of what we are about
   265 		# to return plus what we expected to trim off.
   266 		#
   267 		if {$errorInfo ne "$einfo$expect"} {
   268 		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
   269 			[list CORE UNKNOWN BADTRACE $expect $errorInfo]
   270 		}
   271 		return -code error -errorcode $errorCode \
   272 			-errorinfo $einfo $msg
   273 	    } else {
   274 		return -code $code $msg
   275 	    }
   276 	}
   277     }
   278 
   279     if {([info level] == 1) && [info script] eq "" \
   280 	    && [info exists tcl_interactive] && $tcl_interactive} {
   281 	if {![info exists auto_noexec]} {
   282 	    set new [auto_execok $name]
   283 	    if {$new ne ""} {
   284 		set errorCode $savedErrorCode
   285 		set errorInfo $savedErrorInfo
   286 		set redir ""
   287 		if {[namespace which -command console] eq ""} {
   288 		    set redir ">&@stdout <@stdin"
   289 		}
   290 		return [uplevel 1 exec $redir $new [lrange $args 1 end]]
   291 	    }
   292 	}
   293 	set errorCode $savedErrorCode
   294 	set errorInfo $savedErrorInfo
   295 	if {$name eq "!!"} {
   296 	    set newcmd [history event]
   297 	} elseif {[regexp {^!(.+)$} $name -> event]} {
   298 	    set newcmd [history event $event]
   299 	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
   300 	    set newcmd [history event -1]
   301 	    catch {regsub -all -- $old $newcmd $new newcmd}
   302 	}
   303 	if {[info exists newcmd]} {
   304 	    tclLog $newcmd
   305 	    history change $newcmd 0
   306 	    return [uplevel 1 $newcmd]
   307 	}
   308 
   309 	set ret [catch {set candidates [info commands $name*]} msg]
   310 	if {$name eq "::"} {
   311 	    set name ""
   312 	}
   313 	if {$ret != 0} {
   314 	    return -code $ret -errorcode $errorCode \
   315 		"error in unknown while checking if \"$name\" is\
   316 		a unique command abbreviation:\n$msg"
   317 	}
   318 	# Handle empty $name separately due to strangeness in [string first]
   319 	if {$name eq ""} {
   320 	    if {[llength $candidates] != 1} {
   321 		return -code error "empty command name \"\""
   322 	    }
   323 	    return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
   324 	}
   325 	# Filter out bogus matches when $name contained
   326 	# a glob-special char [Bug 946952]
   327 	set cmds [list]
   328 	foreach x $candidates {
   329 	    if {[string first $name $x] == 0} {
   330 		lappend cmds $x
   331 	    }
   332 	}
   333 	if {[llength $cmds] == 1} {
   334 	    return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
   335 	}
   336 	if {[llength $cmds]} {
   337 	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
   338 	}
   339     }
   340     return -code error "invalid command name \"$name\""
   341 }
   342 
   343 # auto_load --
   344 # Checks a collection of library directories to see if a procedure
   345 # is defined in one of them.  If so, it sources the appropriate
   346 # library file to create the procedure.  Returns 1 if it successfully
   347 # loaded the procedure, 0 otherwise.
   348 #
   349 # Arguments: 
   350 # cmd -			Name of the command to find and load.
   351 # namespace (optional)  The namespace where the command is being used - must be
   352 #                       a canonical namespace as returned [namespace current]
   353 #                       for instance. If not given, namespace current is used.
   354 
   355 proc auto_load {cmd {namespace {}}} {
   356     global auto_index auto_oldpath auto_path
   357 
   358     if {$namespace eq ""} {
   359 	set namespace [uplevel 1 [list ::namespace current]]
   360     }
   361     set nameList [auto_qualify $cmd $namespace]
   362     # workaround non canonical auto_index entries that might be around
   363     # from older auto_mkindex versions
   364     lappend nameList $cmd
   365     foreach name $nameList {
   366 	if {[info exists auto_index($name)]} {
   367 	    namespace eval :: $auto_index($name)
   368 	    # There's a couple of ways to look for a command of a given
   369 	    # name.  One is to use
   370 	    #    info commands $name
   371 	    # Unfortunately, if the name has glob-magic chars in it like *
   372 	    # or [], it may not match.  For our purposes here, a better
   373 	    # route is to use 
   374 	    #    namespace which -command $name
   375 	    if {[namespace which -command $name] ne ""} {
   376 		return 1
   377 	    }
   378 	}
   379     }
   380     if {![info exists auto_path]} {
   381 	return 0
   382     }
   383 
   384     if {![auto_load_index]} {
   385 	return 0
   386     }
   387     foreach name $nameList {
   388 	if {[info exists auto_index($name)]} {
   389 	    namespace eval :: $auto_index($name)
   390 	    if {[namespace which -command $name] ne ""} {
   391 		return 1
   392 	    }
   393 	}
   394     }
   395     return 0
   396 }
   397 
   398 # auto_load_index --
   399 # Loads the contents of tclIndex files on the auto_path directory
   400 # list.  This is usually invoked within auto_load to load the index
   401 # of available commands.  Returns 1 if the index is loaded, and 0 if
   402 # the index is already loaded and up to date.
   403 #
   404 # Arguments: 
   405 # None.
   406 
   407 proc auto_load_index {} {
   408     global auto_index auto_oldpath auto_path errorInfo errorCode
   409 
   410     if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
   411 	return 0
   412     }
   413     set auto_oldpath $auto_path
   414 
   415     # Check if we are a safe interpreter. In that case, we support only
   416     # newer format tclIndex files.
   417 
   418     set issafe [interp issafe]
   419     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
   420 	set dir [lindex $auto_path $i]
   421 	set f ""
   422 	if {$issafe} {
   423 	    catch {source [file join $dir tclIndex]}
   424 	} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
   425 	    continue
   426 	} else {
   427 	    set error [catch {
   428 		set id [gets $f]
   429 		if {$id eq "# Tcl autoload index file, version 2.0"} {
   430 		    eval [read $f]
   431 		} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
   432 		    while {[gets $f line] >= 0} {
   433 			if {[string index $line 0] eq "#" 
   434 				|| ([llength $line] != 2)} {
   435 			    continue
   436 			}
   437 			set name [lindex $line 0]
   438 			set auto_index($name) \
   439 				"source [file join $dir [lindex $line 1]]"
   440 		    }
   441 		} else {
   442 		    error "[file join $dir tclIndex] isn't a proper Tcl index file"
   443 		}
   444 	    } msg]
   445 	    if {$f ne ""} {
   446 		close $f
   447 	    }
   448 	    if {$error} {
   449 		error $msg $errorInfo $errorCode
   450 	    }
   451 	}
   452     }
   453     return 1
   454 }
   455 
   456 # auto_qualify --
   457 #
   458 # Compute a fully qualified names list for use in the auto_index array.
   459 # For historical reasons, commands in the global namespace do not have leading
   460 # :: in the index key. The list has two elements when the command name is
   461 # relative (no leading ::) and the namespace is not the global one. Otherwise
   462 # only one name is returned (and searched in the auto_index).
   463 #
   464 # Arguments -
   465 # cmd		The command name. Can be any name accepted for command
   466 #               invocations (Like "foo::::bar").
   467 # namespace	The namespace where the command is being used - must be
   468 #               a canonical namespace as returned by [namespace current]
   469 #               for instance.
   470 
   471 proc auto_qualify {cmd namespace} {
   472 
   473     # count separators and clean them up
   474     # (making sure that foo:::::bar will be treated as foo::bar)
   475     set n [regsub -all {::+} $cmd :: cmd]
   476 
   477     # Ignore namespace if the name starts with ::
   478     # Handle special case of only leading ::
   479 
   480     # Before each return case we give an example of which category it is
   481     # with the following form :
   482     # ( inputCmd, inputNameSpace) -> output
   483 
   484     if {[string match ::* $cmd]} {
   485 	if {$n > 1} {
   486 	    # ( ::foo::bar , * ) -> ::foo::bar
   487 	    return [list $cmd]
   488 	} else {
   489 	    # ( ::global , * ) -> global
   490 	    return [list [string range $cmd 2 end]]
   491 	}
   492     }
   493     
   494     # Potentially returning 2 elements to try  :
   495     # (if the current namespace is not the global one)
   496 
   497     if {$n == 0} {
   498 	if {$namespace eq "::"} {
   499 	    # ( nocolons , :: ) -> nocolons
   500 	    return [list $cmd]
   501 	} else {
   502 	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
   503 	    return [list ${namespace}::$cmd $cmd]
   504 	}
   505     } elseif {$namespace eq "::"} {
   506 	#  ( foo::bar , :: ) -> ::foo::bar
   507 	return [list ::$cmd]
   508     } else {
   509 	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
   510 	return [list ${namespace}::$cmd ::$cmd]
   511     }
   512 }
   513 
   514 # auto_import --
   515 #
   516 # Invoked during "namespace import" to make see if the imported commands
   517 # reside in an autoloaded library.  If so, the commands are loaded so
   518 # that they will be available for the import links.  If not, then this
   519 # procedure does nothing.
   520 #
   521 # Arguments -
   522 # pattern	The pattern of commands being imported (like "foo::*")
   523 #               a canonical namespace as returned by [namespace current]
   524 
   525 proc auto_import {pattern} {
   526     global auto_index
   527 
   528     # If no namespace is specified, this will be an error case
   529 
   530     if {![string match *::* $pattern]} {
   531 	return
   532     }
   533 
   534     set ns [uplevel 1 [list ::namespace current]]
   535     set patternList [auto_qualify $pattern $ns]
   536 
   537     auto_load_index
   538 
   539     foreach pattern $patternList {
   540         foreach name [array names auto_index $pattern] {
   541             if {([namespace which -command $name] eq "")
   542 		    && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
   543                 namespace eval :: $auto_index($name)
   544             }
   545         }
   546     }
   547 }
   548 
   549 # auto_execok --
   550 #
   551 # Returns string that indicates name of program to execute if 
   552 # name corresponds to a shell builtin or an executable in the
   553 # Windows search path, or "" otherwise.  Builds an associative 
   554 # array auto_execs that caches information about previous checks, 
   555 # for speed.
   556 #
   557 # Arguments: 
   558 # name -			Name of a command.
   559 
   560 if {$tcl_platform(platform) eq "windows"} {
   561 # Windows version.
   562 #
   563 # Note that info executable doesn't work under Windows, so we have to
   564 # look for files with .exe, .com, or .bat extensions.  Also, the path
   565 # may be in the Path or PATH environment variables, and path
   566 # components are separated with semicolons, not colons as under Unix.
   567 #
   568 proc auto_execok name {
   569     global auto_execs env tcl_platform
   570 
   571     if {[info exists auto_execs($name)]} {
   572 	return $auto_execs($name)
   573     }
   574     set auto_execs($name) ""
   575 
   576     set shellBuiltins [list cls copy date del erase dir echo mkdir \
   577 	    md rename ren rmdir rd time type ver vol]
   578     if {$tcl_platform(os) eq "Windows NT"} {
   579 	# NT includes the 'start' built-in
   580 	lappend shellBuiltins "start"
   581     }
   582     if {[info exists env(PATHEXT)]} {
   583 	# Add an initial ; to have the {} extension check first.
   584 	set execExtensions [split ";$env(PATHEXT)" ";"]
   585     } else {
   586 	set execExtensions [list {} .com .exe .bat]
   587     }
   588 
   589     if {[lsearch -exact $shellBuiltins $name] != -1} {
   590 	# When this is command.com for some reason on Win2K, Tcl won't
   591 	# exec it unless the case is right, which this corrects.  COMSPEC
   592 	# may not point to a real file, so do the check.
   593 	set cmd $env(COMSPEC)
   594 	if {[file exists $cmd]} {
   595 	    set cmd [file attributes $cmd -shortname]
   596 	}
   597 	return [set auto_execs($name) [list $cmd /c $name]]
   598     }
   599 
   600     if {[llength [file split $name]] != 1} {
   601 	foreach ext $execExtensions {
   602 	    set file ${name}${ext}
   603 	    if {[file exists $file] && ![file isdirectory $file]} {
   604 		return [set auto_execs($name) [list $file]]
   605 	    }
   606 	}
   607 	return ""
   608     }
   609 
   610     set path "[file dirname [info nameof]];.;"
   611     if {[info exists env(WINDIR)]} {
   612 	set windir $env(WINDIR) 
   613     }
   614     if {[info exists windir]} {
   615 	if {$tcl_platform(os) eq "Windows NT"} {
   616 	    append path "$windir/system32;"
   617 	}
   618 	append path "$windir/system;$windir;"
   619     }
   620 
   621     foreach var {PATH Path path} {
   622 	if {[info exists env($var)]} {
   623 	    append path ";$env($var)"
   624 	}
   625     }
   626 
   627     foreach dir [split $path {;}] {
   628 	# Skip already checked directories
   629 	if {[info exists checked($dir)] || $dir eq {}} { continue }
   630 	set checked($dir) {}
   631 	foreach ext $execExtensions {
   632 	    set file [file join $dir ${name}${ext}]
   633 	    if {[file exists $file] && ![file isdirectory $file]} {
   634 		return [set auto_execs($name) [list $file]]
   635 	    }
   636 	}
   637     }
   638     return ""
   639 }
   640 
   641 } else {
   642 # Unix version.
   643 #
   644 proc auto_execok name {
   645     global auto_execs env
   646 
   647     if {[info exists auto_execs($name)]} {
   648 	return $auto_execs($name)
   649     }
   650     set auto_execs($name) ""
   651     if {[llength [file split $name]] != 1} {
   652 	if {[file executable $name] && ![file isdirectory $name]} {
   653 	    set auto_execs($name) [list $name]
   654 	}
   655 	return $auto_execs($name)
   656     }
   657     foreach dir [split $env(PATH) :] {
   658 	if {$dir eq ""} {
   659 	    set dir .
   660 	}
   661 	set file [file join $dir $name]
   662 	if {[file executable $file] && ![file isdirectory $file]} {
   663 	    set auto_execs($name) [list $file]
   664 	    return $auto_execs($name)
   665 	}
   666     }
   667     return ""
   668 }
   669 
   670 }
   671 
   672 # ::tcl::CopyDirectory --
   673 #
   674 # This procedure is called by Tcl's core when attempts to call the
   675 # filesystem's copydirectory function fail.  The semantics of the call
   676 # are that 'dest' does not yet exist, i.e. dest should become the exact
   677 # image of src.  If dest does exist, we throw an error.  
   678 # 
   679 # Note that making changes to this procedure can change the results
   680 # of running Tcl's tests.
   681 #
   682 # Arguments: 
   683 # action -              "renaming" or "copying" 
   684 # src -			source directory
   685 # dest -		destination directory
   686 proc tcl::CopyDirectory {action src dest} {
   687     set nsrc [file normalize $src]
   688     set ndest [file normalize $dest]
   689     if {$action eq "renaming"} {
   690 	# Can't rename volumes.  We could give a more precise
   691 	# error message here, but that would break the test suite.
   692 	if {[lsearch -exact [file volumes] $nsrc] != -1} {
   693 	    return -code error "error $action \"$src\" to\
   694 	      \"$dest\": trying to rename a volume or move a directory\
   695 	      into itself"
   696 	}
   697     }
   698     if {[file exists $dest]} {
   699 	if {$nsrc eq $ndest} {
   700 	    return -code error "error $action \"$src\" to\
   701 	      \"$dest\": trying to rename a volume or move a directory\
   702 	      into itself"
   703 	}
   704 	if {$action eq "copying"} {
   705 	    return -code error "error $action \"$src\" to\
   706 	      \"$dest\": file already exists"
   707 	} else {
   708 	    # Depending on the platform, and on the current
   709 	    # working directory, the directories '.', '..'
   710 	    # can be returned in various combinations.  Anyway,
   711 	    # if any other file is returned, we must signal an error.
   712 	    set existing [glob -nocomplain -directory $dest * .*]
   713 	    eval [linsert \
   714 		    [glob -nocomplain -directory $dest -type hidden * .*] 0 \
   715 		    lappend existing]
   716 	    foreach s $existing {
   717 		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
   718 		    return -code error "error $action \"$src\" to\
   719 		      \"$dest\": file already exists"
   720 		}
   721 	    }
   722 	}
   723     } else {
   724 	if {[string first $nsrc $ndest] != -1} {
   725 	    set srclen [expr {[llength [file split $nsrc]] -1}]
   726 	    set ndest [lindex [file split $ndest] $srclen]
   727 	    if {$ndest eq [file tail $nsrc]} {
   728 		return -code error "error $action \"$src\" to\
   729 		  \"$dest\": trying to rename a volume or move a directory\
   730 		  into itself"
   731 	    }
   732 	}
   733 	file mkdir $dest
   734     }
   735     # Have to be careful to capture both visible and hidden files.
   736     # We will also be more generous to the file system and not
   737     # assume the hidden and non-hidden lists are non-overlapping.
   738     # 
   739     # On Unix 'hidden' files begin with '.'.  On other platforms
   740     # or filesystems hidden files may have other interpretations.
   741     set filelist [concat [glob -nocomplain -directory $src *] \
   742       [glob -nocomplain -directory $src -types hidden *]]
   743     
   744     foreach s [lsort -unique $filelist] {
   745 	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
   746 	    file copy $s [file join $dest [file tail $s]]
   747 	}
   748     }
   749     return
   750 }