sl@0: # init.tcl --
sl@0: #
sl@0: # Default system startup file for Tcl-based applications.  Defines
sl@0: # "unknown" procedure and auto-load facilities.
sl@0: #
sl@0: # RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $
sl@0: #
sl@0: # Copyright (c) 1991-1993 The Regents of the University of California.
sl@0: # Copyright (c) 1994-1996 Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 Scriptics Corporation.
sl@0: # Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.  
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: 
sl@0: if {[info commands package] == ""} {
sl@0:     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
sl@0: }
sl@0: package require -exact Tcl 8.4
sl@0: 
sl@0: # Compute the auto path to use in this interpreter.
sl@0: # The values on the path come from several locations:
sl@0: #
sl@0: # The environment variable TCLLIBPATH
sl@0: #
sl@0: # tcl_library, which is the directory containing this init.tcl script.
sl@0: # tclInitScript.h searches around for the directory containing this
sl@0: # init.tcl and defines tcl_library to that location before sourcing it.
sl@0: #
sl@0: # The parent directory of tcl_library. Adding the parent
sl@0: # means that packages in peer directories will be found automatically.
sl@0: #
sl@0: # Also add the directory ../lib relative to the directory where the
sl@0: # executable is located.  This is meant to find binary packages for the
sl@0: # same architecture as the current executable.
sl@0: #
sl@0: # tcl_pkgPath, which is set by the platform-specific initialization routines
sl@0: #	On UNIX it is compiled in
sl@0: #       On Windows, it is not used
sl@0: #	On Macintosh it is "Tool Command Language" in the Extensions folder
sl@0: 
sl@0: if {![info exists auto_path]} {
sl@0:     if {[info exists env(TCLLIBPATH)]} {
sl@0: 	set auto_path $env(TCLLIBPATH)
sl@0:     } else {
sl@0: 	set auto_path ""
sl@0:     }
sl@0: }
sl@0: namespace eval tcl {
sl@0:     variable Dir
sl@0:     if {[info library] ne ""} {
sl@0: 	foreach Dir [list [info library] [file dirname [info library]]] {
sl@0: 	    if {[lsearch -exact $::auto_path $Dir] < 0} {
sl@0: 		lappend ::auto_path $Dir
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if {![string equal $tcl_platform(osSystemName) "Symbian"]} {
sl@0:        set Dir [file join [file dirname [file dirname \
sl@0: 	 [info nameofexecutable]]] lib]
sl@0:     }
sl@0:     if {[lsearch -exact $::auto_path $Dir] < 0} {
sl@0: 	lappend ::auto_path $Dir
sl@0:     }
sl@0:     if {[info exists ::tcl_pkgPath]} {
sl@0: 	foreach Dir $::tcl_pkgPath {
sl@0: 	    if {[lsearch -exact $::auto_path $Dir] < 0} {
sl@0: 		lappend ::auto_path $Dir
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0: }
sl@0:   
sl@0: # Windows specific end of initialization
sl@0: 
sl@0: if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
sl@0:     namespace eval tcl {
sl@0: 	proc EnvTraceProc {lo n1 n2 op} {
sl@0: 	    set x $::env($n2)
sl@0: 	    set ::env($lo) $x
sl@0: 	    set ::env([string toupper $lo]) $x
sl@0: 	}
sl@0: 	proc InitWinEnv {} {
sl@0: 	    global env tcl_platform
sl@0: 	    foreach p [array names env] {
sl@0: 		set u [string toupper $p]
sl@0: 		if {$u ne $p} {
sl@0: 		    switch -- $u {
sl@0: 			COMSPEC -
sl@0: 			PATH {
sl@0: 			    if {![info exists env($u)]} {
sl@0: 				set env($u) $env($p)
sl@0: 			    }
sl@0: 			    trace add variable env($p) write \
sl@0: 				    [namespace code [list EnvTraceProc $p]]
sl@0: 			    trace add variable env($u) write \
sl@0: 				    [namespace code [list EnvTraceProc $p]]
sl@0: 			}
sl@0: 		    }
sl@0: 		}
sl@0: 	    }
sl@0: 	    if {![info exists env(COMSPEC)]} {
sl@0: 		if {$tcl_platform(os) eq "Windows NT"} {
sl@0: 		    set env(COMSPEC) cmd.exe
sl@0: 		} else {
sl@0: 		    set env(COMSPEC) command.com
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0: 	InitWinEnv
sl@0:     }
sl@0: }
sl@0: 
sl@0: # Setup the unknown package handler
sl@0: 
sl@0: package unknown tclPkgUnknown
sl@0: 
sl@0: if {![interp issafe]} {
sl@0:     # setup platform specific unknown package handlers
sl@0:     if {$::tcl_platform(platform) eq "unix"
sl@0: 	    && $::tcl_platform(os) eq "Darwin"} {
sl@0: 	package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
sl@0:     }
sl@0:     if {$::tcl_platform(platform) eq "macintosh"} {
sl@0: 	package unknown [list tcl::MacPkgUnknown [package unknown]]
sl@0:     }
sl@0: }
sl@0: 
sl@0: # Conditionalize for presence of exec.
sl@0: 
sl@0: if {[namespace which -command exec] eq ""} {
sl@0: 
sl@0:     # Some machines, such as the Macintosh, do not have exec. Also, on all
sl@0:     # platforms, safe interpreters do not have exec.
sl@0: 
sl@0:     set auto_noexec 1
sl@0: }
sl@0: set errorCode ""
sl@0: set errorInfo ""
sl@0: 
sl@0: # Define a log command (which can be overwitten to log errors
sl@0: # differently, specially when stderr is not available)
sl@0: 
sl@0: if {[namespace which -command tclLog] eq ""} {
sl@0:     proc tclLog {string} {
sl@0: 	catch {puts stderr $string}
sl@0:     }
sl@0: }
sl@0: 
sl@0: # unknown --
sl@0: # This procedure is called when a Tcl command is invoked that doesn't
sl@0: # exist in the interpreter.  It takes the following steps to make the
sl@0: # command available:
sl@0: #
sl@0: #	1. See if the command has the form "namespace inscope ns cmd" and
sl@0: #	   if so, concatenate its arguments onto the end and evaluate it.
sl@0: #	2. See if the autoload facility can locate the command in a
sl@0: #	   Tcl script file.  If so, load it and execute it.
sl@0: #	3. If the command was invoked interactively at top-level:
sl@0: #	    (a) see if the command exists as an executable UNIX program.
sl@0: #		If so, "exec" the command.
sl@0: #	    (b) see if the command requests csh-like history substitution
sl@0: #		in one of the common forms !!, !<number>, or ^old^new.  If
sl@0: #		so, emulate csh's history substitution.
sl@0: #	    (c) see if the command is a unique abbreviation for another
sl@0: #		command.  If so, invoke the command.
sl@0: #
sl@0: # Arguments:
sl@0: # args -	A list whose elements are the words of the original
sl@0: #		command, including the command name.
sl@0: 
sl@0: proc unknown args {
sl@0:     global auto_noexec auto_noload env unknown_pending tcl_interactive
sl@0:     global errorCode errorInfo
sl@0: 
sl@0:     # If the command word has the form "namespace inscope ns cmd"
sl@0:     # then concatenate its arguments onto the end and evaluate it.
sl@0: 
sl@0:     set cmd [lindex $args 0]
sl@0:     if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
sl@0:         set arglist [lrange $args 1 end]
sl@0: 	set ret [catch {uplevel 1 ::$cmd $arglist} result]
sl@0:         if {$ret == 0} {
sl@0:             return $result
sl@0:         } else {
sl@0: 	    return -code $ret -errorcode $errorCode $result
sl@0:         }
sl@0:     }
sl@0: 
sl@0:     # Save the values of errorCode and errorInfo variables, since they
sl@0:     # may get modified if caught errors occur below.  The variables will
sl@0:     # be restored just before re-executing the missing command.
sl@0: 
sl@0:     # Safety check in case something unsets the variables 
sl@0:     # ::errorInfo or ::errorCode.  [Bug 1063707]
sl@0:     if {![info exists errorCode]} {
sl@0: 	set errorCode ""
sl@0:     }
sl@0:     if {![info exists errorInfo]} {
sl@0: 	set errorInfo ""
sl@0:     }
sl@0:     set savedErrorCode $errorCode
sl@0:     set savedErrorInfo $errorInfo
sl@0:     set name $cmd
sl@0:     if {![info exists auto_noload]} {
sl@0: 	#
sl@0: 	# Make sure we're not trying to load the same proc twice.
sl@0: 	#
sl@0: 	if {[info exists unknown_pending($name)]} {
sl@0: 	    return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
sl@0: 	}
sl@0: 	set unknown_pending($name) pending;
sl@0: 	set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
sl@0: 	unset unknown_pending($name);
sl@0: 	if {$ret != 0} {
sl@0: 	    append errorInfo "\n    (autoloading \"$name\")"
sl@0: 	    return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
sl@0: 	}
sl@0: 	if {![array size unknown_pending]} {
sl@0: 	    unset unknown_pending
sl@0: 	}
sl@0: 	if {$msg} {
sl@0: 	    set errorCode $savedErrorCode
sl@0: 	    set errorInfo $savedErrorInfo
sl@0: 	    set code [catch {uplevel 1 $args} msg]
sl@0: 	    if {$code ==  1} {
sl@0: 		#
sl@0: 		# Compute stack trace contribution from the [uplevel].
sl@0: 		# Note the dependence on how Tcl_AddErrorInfo, etc. 
sl@0: 		# construct the stack trace.
sl@0: 		#
sl@0: 		set cinfo $args
sl@0: 		set ellipsis ""
sl@0: 		while {[string bytelength $cinfo] > 150} {
sl@0: 		    set cinfo [string range $cinfo 0 end-1]
sl@0: 		    set ellipsis "..."
sl@0: 		}
sl@0: 		append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
sl@0: 		append cinfo "\n    invoked from within"
sl@0: 		append cinfo "\n\"uplevel 1 \$args\""
sl@0: 		#
sl@0: 		# Try each possible form of the stack trace
sl@0: 		# and trim the extra contribution from the matching case
sl@0: 		#
sl@0: 		set expect "$msg\n    while executing\n\"$cinfo"
sl@0: 		if {$errorInfo eq $expect} {
sl@0: 		    #
sl@0: 		    # The stack has only the eval from the expanded command
sl@0: 		    # Do not generate any stack trace here.
sl@0: 		    #
sl@0: 		    return -code error -errorcode $errorCode $msg
sl@0: 		}
sl@0: 		#
sl@0: 		# Stack trace is nested, trim off just the contribution
sl@0: 		# from the extra "eval" of $args due to the "catch" above.
sl@0: 		#
sl@0: 		set expect "\n    invoked from within\n\"$cinfo"
sl@0: 		set exlen [string length $expect]
sl@0: 		set eilen [string length $errorInfo]
sl@0: 		set i [expr {$eilen - $exlen - 1}]
sl@0: 		set einfo [string range $errorInfo 0 $i]
sl@0: 		#
sl@0: 		# For now verify that $errorInfo consists of what we are about
sl@0: 		# to return plus what we expected to trim off.
sl@0: 		#
sl@0: 		if {$errorInfo ne "$einfo$expect"} {
sl@0: 		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
sl@0: 			[list CORE UNKNOWN BADTRACE $expect $errorInfo]
sl@0: 		}
sl@0: 		return -code error -errorcode $errorCode \
sl@0: 			-errorinfo $einfo $msg
sl@0: 	    } else {
sl@0: 		return -code $code $msg
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     if {([info level] == 1) && [info script] eq "" \
sl@0: 	    && [info exists tcl_interactive] && $tcl_interactive} {
sl@0: 	if {![info exists auto_noexec]} {
sl@0: 	    set new [auto_execok $name]
sl@0: 	    if {$new ne ""} {
sl@0: 		set errorCode $savedErrorCode
sl@0: 		set errorInfo $savedErrorInfo
sl@0: 		set redir ""
sl@0: 		if {[namespace which -command console] eq ""} {
sl@0: 		    set redir ">&@stdout <@stdin"
sl@0: 		}
sl@0: 		return [uplevel 1 exec $redir $new [lrange $args 1 end]]
sl@0: 	    }
sl@0: 	}
sl@0: 	set errorCode $savedErrorCode
sl@0: 	set errorInfo $savedErrorInfo
sl@0: 	if {$name eq "!!"} {
sl@0: 	    set newcmd [history event]
sl@0: 	} elseif {[regexp {^!(.+)$} $name -> event]} {
sl@0: 	    set newcmd [history event $event]
sl@0: 	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
sl@0: 	    set newcmd [history event -1]
sl@0: 	    catch {regsub -all -- $old $newcmd $new newcmd}
sl@0: 	}
sl@0: 	if {[info exists newcmd]} {
sl@0: 	    tclLog $newcmd
sl@0: 	    history change $newcmd 0
sl@0: 	    return [uplevel 1 $newcmd]
sl@0: 	}
sl@0: 
sl@0: 	set ret [catch {set candidates [info commands $name*]} msg]
sl@0: 	if {$name eq "::"} {
sl@0: 	    set name ""
sl@0: 	}
sl@0: 	if {$ret != 0} {
sl@0: 	    return -code $ret -errorcode $errorCode \
sl@0: 		"error in unknown while checking if \"$name\" is\
sl@0: 		a unique command abbreviation:\n$msg"
sl@0: 	}
sl@0: 	# Handle empty $name separately due to strangeness in [string first]
sl@0: 	if {$name eq ""} {
sl@0: 	    if {[llength $candidates] != 1} {
sl@0: 		return -code error "empty command name \"\""
sl@0: 	    }
sl@0: 	    return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
sl@0: 	}
sl@0: 	# Filter out bogus matches when $name contained
sl@0: 	# a glob-special char [Bug 946952]
sl@0: 	set cmds [list]
sl@0: 	foreach x $candidates {
sl@0: 	    if {[string first $name $x] == 0} {
sl@0: 		lappend cmds $x
sl@0: 	    }
sl@0: 	}
sl@0: 	if {[llength $cmds] == 1} {
sl@0: 	    return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
sl@0: 	}
sl@0: 	if {[llength $cmds]} {
sl@0: 	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
sl@0: 	}
sl@0:     }
sl@0:     return -code error "invalid command name \"$name\""
sl@0: }
sl@0: 
sl@0: # auto_load --
sl@0: # Checks a collection of library directories to see if a procedure
sl@0: # is defined in one of them.  If so, it sources the appropriate
sl@0: # library file to create the procedure.  Returns 1 if it successfully
sl@0: # loaded the procedure, 0 otherwise.
sl@0: #
sl@0: # Arguments: 
sl@0: # cmd -			Name of the command to find and load.
sl@0: # namespace (optional)  The namespace where the command is being used - must be
sl@0: #                       a canonical namespace as returned [namespace current]
sl@0: #                       for instance. If not given, namespace current is used.
sl@0: 
sl@0: proc auto_load {cmd {namespace {}}} {
sl@0:     global auto_index auto_oldpath auto_path
sl@0: 
sl@0:     if {$namespace eq ""} {
sl@0: 	set namespace [uplevel 1 [list ::namespace current]]
sl@0:     }
sl@0:     set nameList [auto_qualify $cmd $namespace]
sl@0:     # workaround non canonical auto_index entries that might be around
sl@0:     # from older auto_mkindex versions
sl@0:     lappend nameList $cmd
sl@0:     foreach name $nameList {
sl@0: 	if {[info exists auto_index($name)]} {
sl@0: 	    namespace eval :: $auto_index($name)
sl@0: 	    # There's a couple of ways to look for a command of a given
sl@0: 	    # name.  One is to use
sl@0: 	    #    info commands $name
sl@0: 	    # Unfortunately, if the name has glob-magic chars in it like *
sl@0: 	    # or [], it may not match.  For our purposes here, a better
sl@0: 	    # route is to use 
sl@0: 	    #    namespace which -command $name
sl@0: 	    if {[namespace which -command $name] ne ""} {
sl@0: 		return 1
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     if {![info exists auto_path]} {
sl@0: 	return 0
sl@0:     }
sl@0: 
sl@0:     if {![auto_load_index]} {
sl@0: 	return 0
sl@0:     }
sl@0:     foreach name $nameList {
sl@0: 	if {[info exists auto_index($name)]} {
sl@0: 	    namespace eval :: $auto_index($name)
sl@0: 	    if {[namespace which -command $name] ne ""} {
sl@0: 		return 1
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return 0
sl@0: }
sl@0: 
sl@0: # auto_load_index --
sl@0: # Loads the contents of tclIndex files on the auto_path directory
sl@0: # list.  This is usually invoked within auto_load to load the index
sl@0: # of available commands.  Returns 1 if the index is loaded, and 0 if
sl@0: # the index is already loaded and up to date.
sl@0: #
sl@0: # Arguments: 
sl@0: # None.
sl@0: 
sl@0: proc auto_load_index {} {
sl@0:     global auto_index auto_oldpath auto_path errorInfo errorCode
sl@0: 
sl@0:     if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
sl@0: 	return 0
sl@0:     }
sl@0:     set auto_oldpath $auto_path
sl@0: 
sl@0:     # Check if we are a safe interpreter. In that case, we support only
sl@0:     # newer format tclIndex files.
sl@0: 
sl@0:     set issafe [interp issafe]
sl@0:     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
sl@0: 	set dir [lindex $auto_path $i]
sl@0: 	set f ""
sl@0: 	if {$issafe} {
sl@0: 	    catch {source [file join $dir tclIndex]}
sl@0: 	} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
sl@0: 	    continue
sl@0: 	} else {
sl@0: 	    set error [catch {
sl@0: 		set id [gets $f]
sl@0: 		if {$id eq "# Tcl autoload index file, version 2.0"} {
sl@0: 		    eval [read $f]
sl@0: 		} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
sl@0: 		    while {[gets $f line] >= 0} {
sl@0: 			if {[string index $line 0] eq "#" 
sl@0: 				|| ([llength $line] != 2)} {
sl@0: 			    continue
sl@0: 			}
sl@0: 			set name [lindex $line 0]
sl@0: 			set auto_index($name) \
sl@0: 				"source [file join $dir [lindex $line 1]]"
sl@0: 		    }
sl@0: 		} else {
sl@0: 		    error "[file join $dir tclIndex] isn't a proper Tcl index file"
sl@0: 		}
sl@0: 	    } msg]
sl@0: 	    if {$f ne ""} {
sl@0: 		close $f
sl@0: 	    }
sl@0: 	    if {$error} {
sl@0: 		error $msg $errorInfo $errorCode
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return 1
sl@0: }
sl@0: 
sl@0: # auto_qualify --
sl@0: #
sl@0: # Compute a fully qualified names list for use in the auto_index array.
sl@0: # For historical reasons, commands in the global namespace do not have leading
sl@0: # :: in the index key. The list has two elements when the command name is
sl@0: # relative (no leading ::) and the namespace is not the global one. Otherwise
sl@0: # only one name is returned (and searched in the auto_index).
sl@0: #
sl@0: # Arguments -
sl@0: # cmd		The command name. Can be any name accepted for command
sl@0: #               invocations (Like "foo::::bar").
sl@0: # namespace	The namespace where the command is being used - must be
sl@0: #               a canonical namespace as returned by [namespace current]
sl@0: #               for instance.
sl@0: 
sl@0: proc auto_qualify {cmd namespace} {
sl@0: 
sl@0:     # count separators and clean them up
sl@0:     # (making sure that foo:::::bar will be treated as foo::bar)
sl@0:     set n [regsub -all {::+} $cmd :: cmd]
sl@0: 
sl@0:     # Ignore namespace if the name starts with ::
sl@0:     # Handle special case of only leading ::
sl@0: 
sl@0:     # Before each return case we give an example of which category it is
sl@0:     # with the following form :
sl@0:     # ( inputCmd, inputNameSpace) -> output
sl@0: 
sl@0:     if {[string match ::* $cmd]} {
sl@0: 	if {$n > 1} {
sl@0: 	    # ( ::foo::bar , * ) -> ::foo::bar
sl@0: 	    return [list $cmd]
sl@0: 	} else {
sl@0: 	    # ( ::global , * ) -> global
sl@0: 	    return [list [string range $cmd 2 end]]
sl@0: 	}
sl@0:     }
sl@0:     
sl@0:     # Potentially returning 2 elements to try  :
sl@0:     # (if the current namespace is not the global one)
sl@0: 
sl@0:     if {$n == 0} {
sl@0: 	if {$namespace eq "::"} {
sl@0: 	    # ( nocolons , :: ) -> nocolons
sl@0: 	    return [list $cmd]
sl@0: 	} else {
sl@0: 	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
sl@0: 	    return [list ${namespace}::$cmd $cmd]
sl@0: 	}
sl@0:     } elseif {$namespace eq "::"} {
sl@0: 	#  ( foo::bar , :: ) -> ::foo::bar
sl@0: 	return [list ::$cmd]
sl@0:     } else {
sl@0: 	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
sl@0: 	return [list ${namespace}::$cmd ::$cmd]
sl@0:     }
sl@0: }
sl@0: 
sl@0: # auto_import --
sl@0: #
sl@0: # Invoked during "namespace import" to make see if the imported commands
sl@0: # reside in an autoloaded library.  If so, the commands are loaded so
sl@0: # that they will be available for the import links.  If not, then this
sl@0: # procedure does nothing.
sl@0: #
sl@0: # Arguments -
sl@0: # pattern	The pattern of commands being imported (like "foo::*")
sl@0: #               a canonical namespace as returned by [namespace current]
sl@0: 
sl@0: proc auto_import {pattern} {
sl@0:     global auto_index
sl@0: 
sl@0:     # If no namespace is specified, this will be an error case
sl@0: 
sl@0:     if {![string match *::* $pattern]} {
sl@0: 	return
sl@0:     }
sl@0: 
sl@0:     set ns [uplevel 1 [list ::namespace current]]
sl@0:     set patternList [auto_qualify $pattern $ns]
sl@0: 
sl@0:     auto_load_index
sl@0: 
sl@0:     foreach pattern $patternList {
sl@0:         foreach name [array names auto_index $pattern] {
sl@0:             if {([namespace which -command $name] eq "")
sl@0: 		    && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
sl@0:                 namespace eval :: $auto_index($name)
sl@0:             }
sl@0:         }
sl@0:     }
sl@0: }
sl@0: 
sl@0: # auto_execok --
sl@0: #
sl@0: # Returns string that indicates name of program to execute if 
sl@0: # name corresponds to a shell builtin or an executable in the
sl@0: # Windows search path, or "" otherwise.  Builds an associative 
sl@0: # array auto_execs that caches information about previous checks, 
sl@0: # for speed.
sl@0: #
sl@0: # Arguments: 
sl@0: # name -			Name of a command.
sl@0: 
sl@0: if {$tcl_platform(platform) eq "windows"} {
sl@0: # Windows version.
sl@0: #
sl@0: # Note that info executable doesn't work under Windows, so we have to
sl@0: # look for files with .exe, .com, or .bat extensions.  Also, the path
sl@0: # may be in the Path or PATH environment variables, and path
sl@0: # components are separated with semicolons, not colons as under Unix.
sl@0: #
sl@0: proc auto_execok name {
sl@0:     global auto_execs env tcl_platform
sl@0: 
sl@0:     if {[info exists auto_execs($name)]} {
sl@0: 	return $auto_execs($name)
sl@0:     }
sl@0:     set auto_execs($name) ""
sl@0: 
sl@0:     set shellBuiltins [list cls copy date del erase dir echo mkdir \
sl@0: 	    md rename ren rmdir rd time type ver vol]
sl@0:     if {$tcl_platform(os) eq "Windows NT"} {
sl@0: 	# NT includes the 'start' built-in
sl@0: 	lappend shellBuiltins "start"
sl@0:     }
sl@0:     if {[info exists env(PATHEXT)]} {
sl@0: 	# Add an initial ; to have the {} extension check first.
sl@0: 	set execExtensions [split ";$env(PATHEXT)" ";"]
sl@0:     } else {
sl@0: 	set execExtensions [list {} .com .exe .bat]
sl@0:     }
sl@0: 
sl@0:     if {[lsearch -exact $shellBuiltins $name] != -1} {
sl@0: 	# When this is command.com for some reason on Win2K, Tcl won't
sl@0: 	# exec it unless the case is right, which this corrects.  COMSPEC
sl@0: 	# may not point to a real file, so do the check.
sl@0: 	set cmd $env(COMSPEC)
sl@0: 	if {[file exists $cmd]} {
sl@0: 	    set cmd [file attributes $cmd -shortname]
sl@0: 	}
sl@0: 	return [set auto_execs($name) [list $cmd /c $name]]
sl@0:     }
sl@0: 
sl@0:     if {[llength [file split $name]] != 1} {
sl@0: 	foreach ext $execExtensions {
sl@0: 	    set file ${name}${ext}
sl@0: 	    if {[file exists $file] && ![file isdirectory $file]} {
sl@0: 		return [set auto_execs($name) [list $file]]
sl@0: 	    }
sl@0: 	}
sl@0: 	return ""
sl@0:     }
sl@0: 
sl@0:     set path "[file dirname [info nameof]];.;"
sl@0:     if {[info exists env(WINDIR)]} {
sl@0: 	set windir $env(WINDIR) 
sl@0:     }
sl@0:     if {[info exists windir]} {
sl@0: 	if {$tcl_platform(os) eq "Windows NT"} {
sl@0: 	    append path "$windir/system32;"
sl@0: 	}
sl@0: 	append path "$windir/system;$windir;"
sl@0:     }
sl@0: 
sl@0:     foreach var {PATH Path path} {
sl@0: 	if {[info exists env($var)]} {
sl@0: 	    append path ";$env($var)"
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     foreach dir [split $path {;}] {
sl@0: 	# Skip already checked directories
sl@0: 	if {[info exists checked($dir)] || $dir eq {}} { continue }
sl@0: 	set checked($dir) {}
sl@0: 	foreach ext $execExtensions {
sl@0: 	    set file [file join $dir ${name}${ext}]
sl@0: 	    if {[file exists $file] && ![file isdirectory $file]} {
sl@0: 		return [set auto_execs($name) [list $file]]
sl@0: 	    }
sl@0: 	}
sl@0:     }
sl@0:     return ""
sl@0: }
sl@0: 
sl@0: } else {
sl@0: # Unix version.
sl@0: #
sl@0: proc auto_execok name {
sl@0:     global auto_execs env
sl@0: 
sl@0:     if {[info exists auto_execs($name)]} {
sl@0: 	return $auto_execs($name)
sl@0:     }
sl@0:     set auto_execs($name) ""
sl@0:     if {[llength [file split $name]] != 1} {
sl@0: 	if {[file executable $name] && ![file isdirectory $name]} {
sl@0: 	    set auto_execs($name) [list $name]
sl@0: 	}
sl@0: 	return $auto_execs($name)
sl@0:     }
sl@0:     foreach dir [split $env(PATH) :] {
sl@0: 	if {$dir eq ""} {
sl@0: 	    set dir .
sl@0: 	}
sl@0: 	set file [file join $dir $name]
sl@0: 	if {[file executable $file] && ![file isdirectory $file]} {
sl@0: 	    set auto_execs($name) [list $file]
sl@0: 	    return $auto_execs($name)
sl@0: 	}
sl@0:     }
sl@0:     return ""
sl@0: }
sl@0: 
sl@0: }
sl@0: 
sl@0: # ::tcl::CopyDirectory --
sl@0: #
sl@0: # This procedure is called by Tcl's core when attempts to call the
sl@0: # filesystem's copydirectory function fail.  The semantics of the call
sl@0: # are that 'dest' does not yet exist, i.e. dest should become the exact
sl@0: # image of src.  If dest does exist, we throw an error.  
sl@0: # 
sl@0: # Note that making changes to this procedure can change the results
sl@0: # of running Tcl's tests.
sl@0: #
sl@0: # Arguments: 
sl@0: # action -              "renaming" or "copying" 
sl@0: # src -			source directory
sl@0: # dest -		destination directory
sl@0: proc tcl::CopyDirectory {action src dest} {
sl@0:     set nsrc [file normalize $src]
sl@0:     set ndest [file normalize $dest]
sl@0:     if {$action eq "renaming"} {
sl@0: 	# Can't rename volumes.  We could give a more precise
sl@0: 	# error message here, but that would break the test suite.
sl@0: 	if {[lsearch -exact [file volumes] $nsrc] != -1} {
sl@0: 	    return -code error "error $action \"$src\" to\
sl@0: 	      \"$dest\": trying to rename a volume or move a directory\
sl@0: 	      into itself"
sl@0: 	}
sl@0:     }
sl@0:     if {[file exists $dest]} {
sl@0: 	if {$nsrc eq $ndest} {
sl@0: 	    return -code error "error $action \"$src\" to\
sl@0: 	      \"$dest\": trying to rename a volume or move a directory\
sl@0: 	      into itself"
sl@0: 	}
sl@0: 	if {$action eq "copying"} {
sl@0: 	    return -code error "error $action \"$src\" to\
sl@0: 	      \"$dest\": file already exists"
sl@0: 	} else {
sl@0: 	    # Depending on the platform, and on the current
sl@0: 	    # working directory, the directories '.', '..'
sl@0: 	    # can be returned in various combinations.  Anyway,
sl@0: 	    # if any other file is returned, we must signal an error.
sl@0: 	    set existing [glob -nocomplain -directory $dest * .*]
sl@0: 	    eval [linsert \
sl@0: 		    [glob -nocomplain -directory $dest -type hidden * .*] 0 \
sl@0: 		    lappend existing]
sl@0: 	    foreach s $existing {
sl@0: 		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
sl@0: 		    return -code error "error $action \"$src\" to\
sl@0: 		      \"$dest\": file already exists"
sl@0: 		}
sl@0: 	    }
sl@0: 	}
sl@0:     } else {
sl@0: 	if {[string first $nsrc $ndest] != -1} {
sl@0: 	    set srclen [expr {[llength [file split $nsrc]] -1}]
sl@0: 	    set ndest [lindex [file split $ndest] $srclen]
sl@0: 	    if {$ndest eq [file tail $nsrc]} {
sl@0: 		return -code error "error $action \"$src\" to\
sl@0: 		  \"$dest\": trying to rename a volume or move a directory\
sl@0: 		  into itself"
sl@0: 	    }
sl@0: 	}
sl@0: 	file mkdir $dest
sl@0:     }
sl@0:     # Have to be careful to capture both visible and hidden files.
sl@0:     # We will also be more generous to the file system and not
sl@0:     # assume the hidden and non-hidden lists are non-overlapping.
sl@0:     # 
sl@0:     # On Unix 'hidden' files begin with '.'.  On other platforms
sl@0:     # or filesystems hidden files may have other interpretations.
sl@0:     set filelist [concat [glob -nocomplain -directory $src *] \
sl@0:       [glob -nocomplain -directory $src -types hidden *]]
sl@0:     
sl@0:     foreach s [lsort -unique $filelist] {
sl@0: 	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
sl@0: 	    file copy $s [file join $dest [file tail $s]]
sl@0: 	}
sl@0:     }
sl@0:     return
sl@0: }