diff options
author | dgp <dgp@noemail.net> | 2005-07-22 21:59:35 (GMT) |
---|---|---|
committer | dgp <dgp@noemail.net> | 2005-07-22 21:59:35 (GMT) |
commit | 1b035825e58d287201213671bb05ee8ed7f3d424 (patch) | |
tree | 1afdc31e39babf2156e2ff5c0cbc65c505ed0116 /library/init.tcl | |
parent | b38f9b383964c2aa1e357ebbb383161b45df41db (diff) | |
download | tcl-1b035825e58d287201213671bb05ee8ed7f3d424.zip tcl-1b035825e58d287201213671bb05ee8ed7f3d424.tar.gz tcl-1b035825e58d287201213671bb05ee8ed7f3d424.tar.bz2 |
* 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:
FossilOrigin-Name: 755e2a7f252832a677edf11cb3e180286df99f85
Diffstat (limited to 'library/init.tcl')
-rw-r--r-- | library/init.tcl | 105 |
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]] } } |