* library/auto.tcl: Updates to the Tcl script library to make

        * library/history.tcl:  use of Tcl 8.4 feautures.  Thanks to
        * library/init.tcl:     Patrick Fradin for prompting on this.
        * library/package.tcl:  [Patch 1237755].
        * library/safe.tcl:
        * library/word.tcl:

1 files changed, 53 insertions, 52 deletions

diff --git a/library/init.tcl b/library/init.tcl
index ea1cd85..8105642 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# RCS: @(#) $Id: init.tcl,v 1.55.2.5 2005/04/28 05:34:40 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -48,7 +48,7 @@ if {![info exists auto_path]} {
 }
 namespace eval tcl {
     variable Dir
-    if {[info library] != ""} {
+    if {[info library] ne ""} {
 	foreach Dir [list [info library] [file dirname [info library]]] {
 	    if {[lsearch -exact $::auto_path $Dir] < 0} {
 		lappend ::auto_path $Dir
@@ -71,7 +71,7 @@ namespace eval tcl {
   
 # Windows specific end of initialization
 
-if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
+if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
     namespace eval tcl {
 	proc EnvTraceProc {lo n1 n2 op} {
 	    set x $::env($n2)
@@ -82,23 +82,23 @@ if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
 	    global env tcl_platform
 	    foreach p [array names env] {
 		set u [string toupper $p]
-		if {![string equal $u $p]} {
+		if {$u ne $p} {
 		    switch -- $u {
 			COMSPEC -
 			PATH {
 			    if {![info exists env($u)]} {
 				set env($u) $env($p)
 			    }
-			    trace variable env($p) w \
+			    trace add variable env($p) write \
 				    [namespace code [list EnvTraceProc $p]]
-			    trace variable env($u) w \
+			    trace add variable env($u) write \
 				    [namespace code [list EnvTraceProc $p]]
 			}
 		    }
 		}
 	    }
 	    if {![info exists env(COMSPEC)]} {
-		if {[string equal $tcl_platform(os) "Windows NT"]} {
+		if {$tcl_platform(os) eq "Windows NT"} {
 		    set env(COMSPEC) cmd.exe
 		} else {
 		    set env(COMSPEC) command.com
@@ -115,18 +115,18 @@ package unknown tclPkgUnknown
 
 if {![interp issafe]} {
     # setup platform specific unknown package handlers
-    if {[string equal $::tcl_platform(platform) "unix"] && \
-	    [string equal $::tcl_platform(os) "Darwin"]} {
+    if {$::tcl_platform(platform) eq "unix"
+	    && $::tcl_platform(os) eq "Darwin"} {
 	package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
     }
-    if {[string equal $::tcl_platform(platform) "macintosh"]} {
+    if {$::tcl_platform(platform) eq "macintosh"} {
 	package unknown [list tcl::MacPkgUnknown [package unknown]]
     }
 }
 
 # Conditionalize for presence of exec.
 
-if {[llength [info commands exec]] == 0} {
+if {[namespace which -command exec] eq ""} {
 
     # Some machines, such as the Macintosh, do not have exec. Also, on all
     # platforms, safe interpreters do not have exec.
@@ -139,7 +139,7 @@ set errorInfo ""
 # Define a log command (which can be overwitten to log errors
 # differently, specially when stderr is not available)
 
-if {[llength [info commands tclLog]] == 0} {
+if {[namespace which -command tclLog] eq ""} {
     proc tclLog {string} {
 	catch {puts stderr $string}
     }
@@ -199,7 +199,7 @@ proc unknown args {
     }
     set savedErrorCode $errorCode
     set savedErrorInfo $errorInfo
-    set name [lindex $args 0]
+    set name $cmd
     if {![info exists auto_noload]} {
 	#
 	# Make sure we're not trying to load the same proc twice.
@@ -273,15 +273,15 @@ proc unknown args {
 	}
     }
 
-    if {([info level] == 1) && [string equal [info script] ""] \
+    if {([info level] == 1) && [info script] eq "" \
 	    && [info exists tcl_interactive] && $tcl_interactive} {
 	if {![info exists auto_noexec]} {
 	    set new [auto_execok $name]
-	    if {$new != ""} {
+	    if {$new ne ""} {
 		set errorCode $savedErrorCode
 		set errorInfo $savedErrorInfo
 		set redir ""
-		if {[string equal [info commands console] ""]} {
+		if {[namespace which -command console] eq ""} {
 		    set redir ">&@stdout <@stdin"
 		}
 		return [uplevel 1 exec $redir $new [lrange $args 1 end]]
@@ -289,11 +289,11 @@ proc unknown args {
 	}
 	set errorCode $savedErrorCode
 	set errorInfo $savedErrorInfo
-	if {[string equal $name "!!"]} {
+	if {$name eq "!!"} {
 	    set newcmd [history event]
-	} elseif {[regexp {^!(.+)$} $name dummy event]} {
+	} elseif {[regexp {^!(.+)$} $name -> event]} {
 	    set newcmd [history event $event]
-	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
+	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
 	    set newcmd [history event -1]
 	    catch {regsub -all -- $old $newcmd $new newcmd}
 	}
@@ -304,7 +304,7 @@ proc unknown args {
 	}
 
 	set ret [catch {set candidates [info commands $name*]} msg]
-	if {[string equal $name "::"]} {
+	if {$name eq "::"} {
 	    set name ""
 	}
 	if {$ret != 0} {
@@ -312,11 +312,18 @@ proc unknown args {
 		"error in unknown while checking if \"$name\" is\
 		a unique command abbreviation:\n$msg"
 	}
+	# Handle empty $name separately due to strangeness in [string first]
+	if {$name eq ""} {
+	    if {[llength $candidates] != 1} {
+		return -code error "empty command name \"\""
+	    }
+	    return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
+	}
 	# Filter out bogus matches when $name contained
 	# a glob-special char [Bug 946952]
 	set cmds [list]
 	foreach x $candidates {
-	    if {[string range $x 0 [expr [string length $name]-1]] eq $name} {
+	    if {[string first $name $x] == 0} {
 		lappend cmds $x
 	    }
 	}
@@ -324,12 +331,7 @@ proc unknown args {
 	    return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
 	}
 	if {[llength $cmds]} {
-	    if {[string equal $name ""]} {
-		return -code error "empty command name \"\""
-	    } else {
-		return -code error \
-			"ambiguous command name \"$name\": [lsort $cmds]"
-	    }
+	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
 	}
     }
     return -code error "invalid command name \"$name\""
@@ -350,7 +352,7 @@ proc unknown args {
 proc auto_load {cmd {namespace {}}} {
     global auto_index auto_oldpath auto_path
 
-    if {[string length $namespace] == 0} {
+    if {$namespace eq ""} {
 	set namespace [uplevel 1 [list ::namespace current]]
     }
     set nameList [auto_qualify $cmd $namespace]
@@ -402,8 +404,7 @@ proc auto_load {cmd {namespace {}}} {
 proc auto_load_index {} {
     global auto_index auto_oldpath auto_path errorInfo errorCode
 
-    if {[info exists auto_oldpath] && \
-	    [string equal $auto_oldpath $auto_path]} {
+    if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
 	return 0
     }
     set auto_oldpath $auto_path
@@ -422,12 +423,11 @@ proc auto_load_index {} {
 	} else {
 	    set error [catch {
 		set id [gets $f]
-		if {[string equal $id \
-			"# Tcl autoload index file, version 2.0"]} {
+		if {$id eq "# Tcl autoload index file, version 2.0"} {
 		    eval [read $f]
-		} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
+		} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
 		    while {[gets $f line] >= 0} {
-			if {[string equal [string index $line 0] "#"] \
+			if {[string index $line 0] eq "#" 
 				|| ([llength $line] != 2)} {
 			    continue
 			}
@@ -439,7 +439,7 @@ proc auto_load_index {} {
 		    error "[file join $dir tclIndex] isn't a proper Tcl index file"
 		}
 	    } msg]
-	    if {$f != ""} {
+	    if {$f ne ""} {
 		close $f
 	    }
 	    if {$error} {
@@ -478,13 +478,13 @@ proc auto_qualify {cmd namespace} {
     # with the following form :
     # ( inputCmd, inputNameSpace) -> output
 
-    if {[regexp {^::(.*)$} $cmd x tail]} {
+    if {[string match ::* $cmd]} {
 	if {$n > 1} {
 	    # ( ::foo::bar , * ) -> ::foo::bar
 	    return [list $cmd]
 	} else {
 	    # ( ::global , * ) -> global
-	    return [list $tail]
+	    return [list [string range $cmd 2 end]]
 	}
     }
     
@@ -492,14 +492,14 @@ proc auto_qualify {cmd namespace} {
     # (if the current namespace is not the global one)
 
     if {$n == 0} {
-	if {[string equal $namespace ::]} {
+	if {$namespace eq "::"} {
 	    # ( nocolons , :: ) -> nocolons
 	    return [list $cmd]
 	} else {
 	    # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
 	    return [list ${namespace}::$cmd $cmd]
 	}
-    } elseif {[string equal $namespace ::]} {
+    } elseif {$namespace eq "::"} {
 	#  ( foo::bar , :: ) -> ::foo::bar
 	return [list ::$cmd]
     } else {
@@ -554,7 +554,7 @@ proc auto_import {pattern} {
 # Arguments: 
 # name -			Name of a command.
 
-if {[string equal windows $tcl_platform(platform)]} {
+if {$tcl_platform(platform) eq "windows"} {
 # Windows version.
 #
 # Note that info executable doesn't work under Windows, so we have to
@@ -572,7 +572,7 @@ proc auto_execok name {
 
     set shellBuiltins [list cls copy date del erase dir echo mkdir \
 	    md rename ren rmdir rd time type ver vol]
-    if {[string equal $tcl_platform(os) "Windows NT"]} {
+    if {$tcl_platform(os) eq "Windows NT"} {
 	# NT includes the 'start' built-in
 	lappend shellBuiltins "start"
     }
@@ -609,7 +609,7 @@ proc auto_execok name {
 	set windir $env(WINDIR) 
     }
     if {[info exists windir]} {
-	if {[string equal $tcl_platform(os) "Windows NT"]} {
+	if {$tcl_platform(os) eq "Windows NT"} {
 	    append path "$windir/system32;"
 	}
 	append path "$windir/system;$windir;"
@@ -623,7 +623,7 @@ proc auto_execok name {
 
     foreach dir [split $path {;}] {
 	# Skip already checked directories
-	if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
+	if {[info exists checked($dir)] || $dir eq {}} { continue }
 	set checked($dir) {}
 	foreach ext $execExtensions {
 	    set file [file join $dir ${name}${ext}]
@@ -652,7 +652,7 @@ proc auto_execok name {
 	return $auto_execs($name)
     }
     foreach dir [split $env(PATH) :] {
-	if {[string equal $dir ""]} {
+	if {$dir eq ""} {
 	    set dir .
 	}
 	set file [file join $dir $name]
@@ -683,7 +683,7 @@ proc auto_execok name {
 proc tcl::CopyDirectory {action src dest} {
     set nsrc [file normalize $src]
     set ndest [file normalize $dest]
-    if {[string equal $action "renaming"]} {
+    if {$action eq "renaming"} {
 	# Can't rename volumes.  We could give a more precise
 	# error message here, but that would break the test suite.
 	if {[lsearch -exact [file volumes] $nsrc] != -1} {
@@ -693,12 +693,12 @@ proc tcl::CopyDirectory {action src dest} {
 	}
     }
     if {[file exists $dest]} {
-	if {$nsrc == $ndest} {
+	if {$nsrc eq $ndest} {
 	    return -code error "error $action \"$src\" to\
 	      \"$dest\": trying to rename a volume or move a directory\
 	      into itself"
 	}
-	if {[string equal $action "copying"]} {
+	if {$action eq "copying"} {
 	    return -code error "error $action \"$src\" to\
 	      \"$dest\": file already exists"
 	} else {
@@ -707,10 +707,11 @@ proc tcl::CopyDirectory {action src dest} {
 	    # can be returned in various combinations.  Anyway,
 	    # if any other file is returned, we must signal an error.
 	    set existing [glob -nocomplain -directory $dest * .*]
-	    eval [list lappend existing] \
-	      [glob -nocomplain -directory $dest -type hidden * .*]
+	    eval [linsert \
+		    [glob -nocomplain -directory $dest -type hidden * .*] 0 \
+		    lappend existing]
 	    foreach s $existing {
-		if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+		if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
 		    return -code error "error $action \"$src\" to\
 		      \"$dest\": file already exists"
 		}
@@ -720,7 +721,7 @@ proc tcl::CopyDirectory {action src dest} {
 	if {[string first $nsrc $ndest] != -1} {
 	    set srclen [expr {[llength [file split $nsrc]] -1}]
 	    set ndest [lindex [file split $ndest] $srclen]
-	    if {$ndest == [file tail $nsrc]} {
+	    if {$ndest eq [file tail $nsrc]} {
 		return -code error "error $action \"$src\" to\
 		  \"$dest\": trying to rename a volume or move a directory\
 		  into itself"
@@ -738,7 +739,7 @@ proc tcl::CopyDirectory {action src dest} {
       [glob -nocomplain -directory $src -types hidden *]]
     
     foreach s [lsort -unique $filelist] {
-	if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+	if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
 	    file copy $s [file join $dest [file tail $s]]
 	}
     }