In the script library, selected modernizations from Patrick Fradin.

6 files changed, 67 insertions, 59 deletions

diff --git a/library/auto.tcl b/library/auto.tcl
index 55fc90f..b0fb61d 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -20,19 +20,20 @@
 # None.
 
 proc auto_reset {} {
-    if {[array exists ::auto_index]} {
-	foreach cmdName [array names ::auto_index] {
+    global auto_execs auto_index auto_path
+    if {[array exists auto_index]} {
+	foreach cmdName [array names auto_index] {
 	    set fqcn [namespace which $cmdName]
 	    if {$fqcn eq ""} {continue}
 	    rename $fqcn {}
 	}
     }
-    unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
-    if {[catch {llength $::auto_path}]} {
-	set ::auto_path [list [info library]]
+    unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
+    if {[catch {llength $auto_path}]} {
+	set auto_path [list [info library]]
     } else {
-	if {[info library] ni $::auto_path} {
-	    lappend ::auto_path [info library]
+	if {[info library] ni $auto_path} {
+	    lappend auto_path [info library]
 	}
     }
 }
@@ -53,7 +54,7 @@ proc auto_reset {} {
 
 proc tcl_findLibrary {basename version patch initScript enVarName varName} {
     upvar #0 $varName the_library
-    global env
+    global auto_path env tcl_platform
 
     set dirs {}
     set errors {}
@@ -86,10 +87,10 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
 	# 3. Relative to auto_path directories.  This checks relative to the
 	# Tcl library as well as allowing loading of libraries added to the
 	# auto_path that is not relative to the core library or binary paths.
-	foreach d $::auto_path {
+	foreach d $auto_path {
 	    lappend dirs [file join $d $basename$version]
-	    if {$::tcl_platform(platform) eq "unix"
-		&& $::tcl_platform(os) eq "Darwin"} {
+	    if {$tcl_platform(platform) eq "unix"
+		    && $tcl_platform(os) eq "Darwin"} {
 		# 4. On MacOSX, check the Resources/Scripts subdir too
 		lappend dirs [file join $d $basename$version Resources Scripts]
 	    }
diff --git a/library/init.tcl b/library/init.tcl
index 1e7e2cd..21e0370 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -12,6 +12,7 @@
 # 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]"
 }
@@ -116,9 +117,10 @@ namespace eval tcl {
 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
@@ -159,8 +161,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 {
@@ -235,7 +237,7 @@ 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
 
     # If the command word has the form "namespace inscope ns cmd"
     # then concatenate its arguments onto the end and evaluate it.
@@ -250,8 +252,8 @@ proc unknown args {
 	return -options $opts $result
     }
 
-    catch {set savedErrorInfo $::errorInfo}
-    catch {set savedErrorCode $::errorCode}
+    catch {set savedErrorInfo $errorInfo}
+    catch {set savedErrorCode $errorCode}
     set name $cmd
     if {![info exists auto_noload]} {
 	#
@@ -280,9 +282,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} {
@@ -291,8 +293,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]
@@ -309,7 +311,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.
@@ -324,18 +326,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
@@ -344,7 +346,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]
@@ -797,7 +799,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"
 		}
@@ -805,7 +807,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\
@@ -825,8 +827,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
diff --git a/library/word.tcl b/library/word.tcl
index 16a4638..b8f34a5 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -67,7 +67,7 @@ namespace eval ::tcl {
 proc tcl_wordBreakAfter {str start} {
     variable ::tcl::WordBreakRE
     set result {-1 -1}
-    regexp -indices -start $start $WordBreakRE(after) $str result
+    regexp -indices -start $start -- $WordBreakRE(after) $str result
     return [lindex $result 1]
 }
 
@@ -85,7 +85,7 @@ proc tcl_wordBreakAfter {str start} {
 proc tcl_wordBreakBefore {str start} {
     variable ::tcl::WordBreakRE
     set result {-1 -1}
-    regexp -indices $WordBreakRE(before) [string range $str 0 $start] result
+    regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
     return [lindex $result 1]
 }
 
@@ -104,7 +104,7 @@ proc tcl_wordBreakBefore {str start} {
 proc tcl_endOfWord {str start} {
     variable ::tcl::WordBreakRE
     set result {-1 -1}
-    regexp -indices -start $start $WordBreakRE(end) $str result
+    regexp -indices -start $start -- $WordBreakRE(end) $str result
     return [lindex $result 1]
 }
 
@@ -122,7 +122,7 @@ proc tcl_endOfWord {str start} {
 proc tcl_startOfNextWord {str start} {
     variable ::tcl::WordBreakRE
     set result {-1 -1}
-    regexp -indices -start $start $WordBreakRE(next) $str result
+    regexp -indices -start $start -- $WordBreakRE(next) $str result
     return [lindex $result 1]
 }
 
@@ -138,7 +138,7 @@ proc tcl_startOfNextWord {str start} {
 proc tcl_startOfPreviousWord {str start} {
     variable ::tcl::WordBreakRE
     set word {-1 -1}
-    regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \
+    regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
 	    result word
     return [lindex $word 0]
 }
diff --git a/tests/platform.test b/tests/platform.test
index 4f1eb82..ab82d07 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -9,10 +9,14 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
-    namespace import -force ::tcltest::*
-}
+package require tcltest 2
+
+namespace eval ::tcl::test::platform {
+    namespace import ::tcltest::testConstraint
+    namespace import ::tcltest::test
+    namespace import ::tcltest::cleanupTests
+
+    variable ::tcl_platform
 
 testConstraint testCPUID [llength [info commands testcpuid]]
 
@@ -51,7 +55,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
     -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
 
 # cleanup
-::tcltest::cleanupTests
+cleanupTests
+
+}
+namespace delete ::tcl::test::platform
 return
 
 # Local Variables:
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 003dd00..1014d52 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -11,7 +11,7 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 package require tcltest 2.2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
 unset -nocomplain path
 catch {set oldlang $env(LANG)}
 set env(LANG) C
@@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
     set pipe1 [open "|[list [interpreter]]" r+]
     puts $pipe1 {
 	proc accept {channel host port} {
-	    puts $channel {puts [fconfigure stdin -peername]; exit}
+	    puts $channel {puts [chan configure stdin -peername]; exit}
 	    close $channel
 	    exit
 	}
-	puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
+	puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
 	vwait forever \
 	    }
     # Note the backslash above; this is important to make sure that the
@@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
     set pipe2 [open "|[list [interpreter] <@$sock]" r]
     set result [gets $pipe2]
     # Clear any pending data; stops certain kinds of (non-important) errors
-    fconfigure $pipe1 -blocking 0; gets $pipe1
-    fconfigure $pipe2 -blocking 0; gets $pipe2
+    chan configure $pipe1 -blocking 0; gets $pipe1
+    chan configure $pipe2 -blocking 0; gets $pipe2
     # Close the pipes and the socket.
     close $pipe2
     close $pipe1
@@ -343,7 +343,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
 } -body {
     set env(LANG) C
     set f [open "|[list [interpreter]]" w+]
-    fconfigure $f -buffering none
+    chan configure $f -buffering none
     puts $f {puts [encoding system]; exit}
     set enc [gets $f]
     close $f
@@ -356,7 +356,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} {
     catch {set oldlc_all $env(LC_ALL)}
     set env(LC_ALL) japanese
     set f [open "|[list [interpreter]]" w+]
-    fconfigure $f -buffering none
+    chan configure $f -buffering none
     puts $f {puts [encoding system]; exit}
     set enc [gets $f]
     close $f
@@ -403,7 +403,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
 } -returnCodes 0
 
 # cleanup
-catch {unset env(LANG)}
+unset -nocomplain env(LANG)
 catch {set env(LANG) $oldlang}
 unset -nocomplain path
 ::tcltest::cleanupTests
diff --git a/tests/unknown.test b/tests/unknown.test
index 69a468f..99b17b8 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -11,12 +11,10 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
-    namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
 
-catch {unset x}
+unset -nocomplain x
 catch {rename unknown unknown.old}
 
 test unknown-1.1 {non-existent "unknown" command} {
@@ -61,5 +59,5 @@ test unknown-4.1 {errors in "unknown" procedure} {
 # cleanup
 catch {rename unknown {}}
 catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
 return