diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 116 |
1 files changed, 57 insertions, 59 deletions
diff --git a/library/init.tcl b/library/init.tcl index a62f3a0..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.122 2009/12/30 13:47:53 msofer 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.1 +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 } @@ -118,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 @@ -130,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 \ @@ -142,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 @@ -161,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 { @@ -235,14 +231,13 @@ 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 {[info exists ::errorInfo]} { - set savedErrorInfo $::errorInfo + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo } - if {[info exists ::errorCode]} { - set savedErrorCode $::errorCode + if {[info exists errorCode]} { + set savedErrorCode $errorCode } set name [lindex $args 0] @@ -252,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 @@ -273,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} { @@ -284,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] @@ -302,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. @@ -317,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 @@ -337,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] @@ -546,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]] } } @@ -563,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] } } @@ -650,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. @@ -691,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]] @@ -787,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" } @@ -795,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\ @@ -815,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 |