summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl105
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]]
}
}