1 files changed, 59 insertions, 251 deletions

diff --git a/library/init.tcl b/library/init.tcl
index 2d8e303..f63eedf 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,8 +3,6 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# RCS: @(#) $Id: init.tcl,v 1.118 2008/12/19 03:54:44 dgp Exp $
-#
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
 # Copyright (c) 1998-1999 Scriptics Corporation.
@@ -14,10 +12,11 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
 
+# This test intentionally written in pre-7.5 Tcl 
 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.6b1
+package require -exact Tcl 8.6.1
 
 # Compute the auto path to use in this interpreter.
 # The values on the path come from several locations:
@@ -78,7 +77,7 @@ namespace eval tcl {
     # TIP #255 min and max functions
     namespace eval mathfunc {
 	proc min {args} {
-	    if {[llength $args] == 0} {
+	    if {![llength $args]} {
 		return -code error \
 		    "too few arguments to math function \"min\""
 	    }
@@ -89,12 +88,12 @@ namespace eval tcl {
 		if {[catch {expr {double($arg)}} err]} {
 		    return -code error $err
 		}
-		if {$arg < $val} { set val $arg }
+		if {$arg < $val} {set val $arg}
 	    }
 	    return $val
 	}
 	proc max {args} {
-	    if {[llength $args] == 0} {
+	    if {![llength $args]} {
 		return -code error \
 		    "too few arguments to math function \"max\""
 	    }
@@ -105,7 +104,7 @@ namespace eval tcl {
 		if {[catch {expr {double($arg)}} err]} {
 		    return -code error $err
 		}
-		if {$arg > $val} { set val $arg }
+		if {$arg > $val} {set val $arg}
 	    }
 	    return $val
 	}
@@ -113,209 +112,15 @@ namespace eval tcl {
     }
 }
 
-# TIP #329: [try] and [throw]
-# These are *temporary* implementations, to be replaced with ones in C and
-# bytecode at a later date before 8.6.0
-namespace eval ::tcl::control {
-    # These are not local, since this allows us to [uplevel] a [catch] rather
-    # than [catch] the [uplevel]ing of something, resulting in a cleaner
-    # -errorinfo:
-    variable em {}
-    variable opts {}
-
-    variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 }
-
-    namespace export throw try
-
-    # ::tcl::control::throw --
-    #
-    #	Creates an error with machine-readable "code" parts and
-    #	human-readable "message" parts.
-    #
-    # Arguments:
-    #	throw -		list describing errorcode
-    #	message -	Human-readable version of error
-    proc throw {type message} {
-	return -code error -errorcode $type -errorinfo $message -level 1 \
-	    $message
-    }
-
-    # ::tcl::control::try --
-    #
-    #	Advanced error handling construct.
-    #
-    # Arguments:
-    #	See try(n) for details
-    proc try {args} {
-	variable magicCodes
-
-	# ----- Parse arguments -----
-
-	set trybody [lindex $args 0]
-	set finallybody {}
-	set handlers [list]
-	set i 1
-
-	while {$i < [llength $args]} {
-	    switch -- [lindex $args $i] {
-		"on" {
-		    incr i
-		    set code [lindex $args $i]
-		    if {[dict exists $magicCodes $code]} {
-			set code [dict get $magicCodes $code]
-		    } elseif {![string is integer -strict $code]} {
-			set msgPart [join [dict keys $magicCodes] {", "}]
-			error "bad code '[lindex $args $i]': must be\
-			    integer or \"$msgPart\""
-		    }
-		    lappend handlers [lrange $args $i $i] \
-			[format %d $code] {} {*}[lrange $args $i+1 $i+2]
-		    incr i 3
-		}
-		"trap" {
-		    incr i
-		    if {![string is list [lindex $args $i]]} {
-			error "bad prefix '[lindex $args $i]':\
-			    must be a list"
-		    }
-		    lappend handlers [lrange $args $i $i] 1 \
-			{*}[lrange $args $i $i+2]
-		    incr i 3
-		}
-		"finally" {
-		    incr i
-		    set finallybody [lindex $args $i]
-		    incr i
-		    break
-		}
-		default {
-		    error "bad handler '[lindex $args $i]': must be\
-			\"on code varlist body\", or\
-			\"trap prefix varlist body\""
-		}
-	    }
-	}
-
-	if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} {
-	    error "wrong # args: should be\
-		\"try body ?handler ...? ?finally body?\""
-	}
-
-	# ----- Execute 'try' body -----
-
-	variable em
-	variable opts
-	set EMVAR  [namespace which -variable em]
-	set OPTVAR [namespace which -variable opts]
-	set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]]
-
-	if {$code == 1} {
-	    set line [dict get $opts -errorline]
-	    dict append opts -errorinfo \
-		"\n    (\"[lindex [info level 0] 0]\" body line $line)"
-	}
-
-	# Keep track of the original error message & options
-	set _em $em
-	set _opts $opts
-
-	# ----- Find and execute handler -----
-
-	set errorcode {}
-	if {[dict exists $opts -errorcode]} {
-	    set errorcode [dict get $opts -errorcode]
-	}
-	set found false
-	foreach {descrip oncode pattern varlist body} $handlers {
-	    if {!$found} {
-		if {
-		    ($code != $oncode) || ([lrange $pattern 0 end] ne
-		    [lrange $errorcode 0 [llength $pattern]-1] )
-		} then {
-		    continue
-		}
-	    }
-	    set found true
-	    if {$body eq "-"} {
-		continue
-	    }
-
-	    # Handler found ...
-
-	    # Assign trybody results into variables
-	    lassign $varlist resultsVarName optionsVarName
-	    if {[llength $varlist] >= 1} {
-		upvar 1 $resultsVarName resultsvar
-		set resultsvar $em
-	    }
-	    if {[llength $varlist] >= 2} {
-		upvar 1 $optionsVarName optsvar
-		set optsvar $opts
-	    }
-
-	    # Execute the handler
-	    set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]]
-
-	    if {$code == 1} {
-		set line [dict get $opts -errorline]
-		dict append opts -errorinfo \
-		    "\n    (\"[lindex [info level 0] 0] ... $descrip\"\
-		    body line $line)"
-		# On error chain to original outcome
-		dict set opts -during $_opts
-	    }
-
-	    # Handler result replaces the original result (whether success or
-	    # failure); capture context of original exception for reference.
-	    set _em $em
-	    set _opts $opts
-
-	    # Handler has been executed - stop looking for more
-	    break
-	}
-
-	# No catch handler found -- error falls through to caller
-	# OR catch handler executed -- result falls through to caller
-
-	# ----- If we have a finally block then execute it -----
-
-	if {$finallybody ne {}} {
-	    set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]]
-
-	    # Finally result takes precedence except on success
-
-	    if {$code == 1} {
-		set line [dict get $opts -errorline]
-		dict append opts -errorinfo \
-		    "\n    (\"[lindex [info level 0] 0] ... finally\"\
-		    body line $line)"
-		# On error chain to original outcome
-		dict set opts -during $_opts
-	    }
-	    if {$code != 0} {
-		set _em $em
-		set _opts $opts
-	    }
-
-	    # Otherwise our result is not affected
-	}
-
-	# Propagate the error or the result of the executed catch body to the
-	# caller.
-	dict incr _opts -level
-	return -options $_opts $_em
-    }
-}
-namespace import ::tcl::control::*
-
 # Windows specific end of initialization
 
 if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
     namespace eval tcl {
 	proc EnvTraceProc {lo n1 n2 op} {
-	    set x $::env($n2)
-	    set ::env($lo) $x
-	    set ::env([string toupper $lo]) $x
+	    global env
+	    set x $env($n2)
+	    set env($lo) $x
+	    set env([string toupper $lo]) $x
 	}
 	proc InitWinEnv {} {
 	    global env tcl_platform
@@ -325,9 +130,9 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
 		    switch -- $u {
 			COMSPEC -
 			PATH {
-			    if {![info exists env($u)]} {
-				set env($u) $env($p)
-			    }
+			    set temp $env($p)
+			    unset env($p)
+			    set env($u) $temp
 			    trace add variable env($p) write \
 				    [namespace code [list EnvTraceProc $p]]
 			    trace add variable env($u) write \
@@ -337,11 +142,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
 		}
 	    }
 	    if {![info exists env(COMSPEC)]} {
-		if {$tcl_platform(os) eq "Windows NT"} {
-		    set env(COMSPEC) cmd.exe
-		} else {
-		    set env(COMSPEC) command.com
-		}
+		set env(COMSPEC) cmd.exe
 	    }
 	}
 	InitWinEnv
@@ -356,8 +157,8 @@ if {[interp issafe]} {
 } else {
     # Set up search for Tcl Modules (TIP #189).
     # and setup platform specific unknown package handlers
-    if {$::tcl_platform(os) eq "Darwin"
-	    && $::tcl_platform(platform) eq "unix"} {
+    if {$tcl_platform(os) eq "Darwin"
+	    && $tcl_platform(platform) eq "unix"} {
 	package unknown {::tcl::tm::UnknownHandler \
 		{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
     } else {
@@ -430,10 +231,14 @@ if {[namespace which -command tclLog] eq ""} {
 
 proc unknown args {
     variable ::tcl::UnknownPending
-    global auto_noexec auto_noload env tcl_interactive
+    global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
 
-    catch {set savedErrorInfo $::errorInfo}
-    catch {set savedErrorCode $::errorCode}
+    if {[info exists errorInfo]} {
+	set savedErrorInfo $errorInfo
+    }
+    if {[info exists errorCode]} {
+	set savedErrorCode $errorCode
+    }
 
     set name [lindex $args 0]
     if {![info exists auto_noload]} {
@@ -442,13 +247,13 @@ proc unknown args {
 	#
 	if {[info exists UnknownPending($name)]} {
 	    return -code error "self-referential recursion\
-		    in \"unknown\" for command \"$name\"";
+		    in \"unknown\" for command \"$name\""
 	}
-	set UnknownPending($name) pending;
+	set UnknownPending($name) pending
 	set ret [catch {
 		auto_load $name [uplevel 1 {::namespace current}]
 	} msg opts]
-	unset UnknownPending($name);
+	unset UnknownPending($name)
 	if {$ret != 0} {
 	    dict append opts -errorinfo "\n    (autoloading \"$name\")"
 	    return -options $opts $msg
@@ -463,9 +268,9 @@ proc unknown args {
 		unset -nocomplain ::errorCode
 	    }
 	    if {[info exists savedErrorInfo]} {
-		set ::errorInfo $savedErrorInfo
+		set errorInfo $savedErrorInfo
 	    } else {
-		unset -nocomplain ::errorInfo
+		unset -nocomplain errorInfo
 	    }
 	    set code [catch {uplevel 1 $args} msg opts]
 	    if {$code ==  1} {
@@ -474,8 +279,8 @@ proc unknown args {
 		# Note the dependence on how Tcl_AddErrorInfo, etc.
 		# construct the stack trace.
 		#
-		set errorInfo [dict get $opts -errorinfo]
-		set errorCode [dict get $opts -errorcode]
+		set errInfo [dict get $opts -errorinfo]
+		set errCode [dict get $opts -errorcode]
 		set cinfo $args
 		if {[string bytelength $cinfo] > 150} {
 		    set cinfo [string range $cinfo 0 150]
@@ -492,7 +297,7 @@ proc unknown args {
 		# and trim the extra contribution from the matching case
 		#
 		set expect "$msg\n    while executing\n\"$cinfo"
-		if {$errorInfo eq $expect} {
+		if {$errInfo eq $expect} {
 		    #
 		    # The stack has only the eval from the expanded command
 		    # Do not generate any stack trace here.
@@ -507,18 +312,18 @@ proc unknown args {
 		#
 		set expect "\n    invoked from within\n\"$cinfo"
 		set exlen [string length $expect]
-		set eilen [string length $errorInfo]
+		set eilen [string length $errInfo]
 		set i [expr {$eilen - $exlen - 1}]
-		set einfo [string range $errorInfo 0 $i]
+		set einfo [string range $errInfo 0 $i]
 		#
-		# For now verify that $errorInfo consists of what we are about
+		# For now verify that $errInfo consists of what we are about
 		# to return plus what we expected to trim off.
 		#
-		if {$errorInfo ne "$einfo$expect"} {
+		if {$errInfo ne "$einfo$expect"} {
 		    error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
-			[list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
+			[list CORE UNKNOWN BADTRACE $einfo $expect $errInfo]
 		}
-		return -code error -errorcode $errorCode \
+		return -code error -errorcode $errCode \
 			-errorinfo $einfo $msg
 	    } else {
 		dict incr opts -level
@@ -527,7 +332,7 @@ proc unknown args {
 	}
     }
 
-    if {([info level] == 1) && ([info script] eq "") \
+    if {([info level] == 1) && ([info script] eq "") 
 	    && [info exists tcl_interactive] && $tcl_interactive} {
 	if {![info exists auto_noexec]} {
 	    set new [auto_execok $name]
@@ -736,14 +541,14 @@ proc auto_qualify {cmd namespace} {
 
     # Before each return case we give an example of which category it is
     # with the following form :
-    # ( inputCmd, inputNameSpace) -> output
+    # (inputCmd, inputNameSpace) -> output
 
     if {[string match ::* $cmd]} {
 	if {$n > 1} {
-	    # ( ::foo::bar , * ) -> ::foo::bar
+	    # (::foo::bar , *) -> ::foo::bar
 	    return [list $cmd]
 	} else {
-	    # ( ::global , * ) -> global
+	    # (::global , *) -> global
 	    return [list [string range $cmd 2 end]]
 	}
     }
@@ -753,17 +558,17 @@ proc auto_qualify {cmd namespace} {
 
     if {$n == 0} {
 	if {$namespace eq "::"} {
-	    # ( nocolons , :: ) -> nocolons
+	    # (nocolons , ::) -> nocolons
 	    return [list $cmd]
 	} else {
-	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
+	    # (nocolons , ::sub) -> ::sub::nocolons nocolons
 	    return [list ${namespace}::$cmd $cmd]
 	}
     } elseif {$namespace eq "::"} {
-	#  ( foo::bar , :: ) -> ::foo::bar
+	#  (foo::bar , ::) -> ::foo::bar
 	return [list ::$cmd]
     } else {
-	# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
+	# (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar
 	return [list ${namespace}::$cmd ::$cmd]
     }
 }
@@ -840,10 +645,10 @@ proc auto_execok name {
 	# Add an initial ; to have the {} extension check first.
 	set execExtensions [split ";$env(PATHEXT)" ";"]
     } else {
-	set execExtensions [list {} .com .exe .bat]
+	set execExtensions [list {} .com .exe .bat .cmd]
     }
 
-    if {$name in $shellBuiltins} {
+    if {[string tolower $name] in $shellBuiltins} {
 	# When this is command.com for some reason on Win2K, Tcl won't
 	# exec it unless the case is right, which this corrects.  COMSPEC
 	# may not point to a real file, so do the check.
@@ -881,11 +686,14 @@ proc auto_execok name {
 	}
     }
 
-    foreach dir [split $path {;}] {
-	# Skip already checked directories
-	if {[info exists checked($dir)] || ($dir eq {})} { continue }
-	set checked($dir) {}
-	foreach ext $execExtensions {
+    foreach ext $execExtensions {
+	unset -nocomplain checked
+	foreach dir [split $path {;}] {
+	    # Skip already checked directories
+	    if {[info exists checked($dir)] || ($dir eq "")} {
+		continue
+	    }
+	    set checked($dir) {}
 	    set file [file join $dir ${name}${ext}]
 	    if {[file exists $file] && ![file isdirectory $file]} {
 		return [set auto_execs($name) [list $file]]
@@ -977,7 +785,7 @@ proc tcl::CopyDirectory {action src dest} {
 	    lappend existing {*}[glob -nocomplain -directory $dest \
 		    -type hidden * .*]
 	    foreach s $existing {
-		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
+		if {[file tail $s] ni {. ..}} {
 		    return -code error "error $action \"$src\" to\
 		      \"$dest\": file already exists"
 		}
@@ -985,7 +793,7 @@ proc tcl::CopyDirectory {action src dest} {
 	}
     } else {
 	if {[string first $nsrc $ndest] != -1} {
-	    set srclen [expr {[llength [file split $nsrc]] -1}]
+	    set srclen [expr {[llength [file split $nsrc]] - 1}]
 	    set ndest [lindex [file split $ndest] $srclen]
 	    if {$ndest eq [file tail $nsrc]} {
 		return -code error "error $action \"$src\" to\
@@ -1005,8 +813,8 @@ proc tcl::CopyDirectory {action src dest} {
       [glob -nocomplain -directory $src -types hidden *]]
 
     foreach s [lsort -unique $filelist] {
-	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
-	    file copy -force $s [file join $dest [file tail $s]]
+	if {[file tail $s] ni {. ..}} {
+	    file copy -force -- $s [file join $dest [file tail $s]]
 	}
     }
     return