diff options
Diffstat (limited to 'library/init.tcl')
| -rw-r--r-- | library/init.tcl | 1004 |
1 files changed, 520 insertions, 484 deletions
diff --git a/library/init.tcl b/library/init.tcl index ebf1913..f63eedf 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,70 +3,212 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34 -# # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # 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.0 +package require -exact Tcl 8.6.1 # Compute the auto path to use in this interpreter. -# (auto_path could be already set, in safe interps for instance) +# The values on the path come from several locations: +# +# The environment variable TCLLIBPATH +# +# tcl_library, which is the directory containing this init.tcl script. +# [tclInit] (Tcl_Init()) searches around for the directory containing this +# init.tcl and defines tcl_library to that location before sourcing it. +# +# The parent directory of tcl_library. Adding the parent +# means that packages in peer directories will be found automatically. +# +# Also add the directory ../lib relative to the directory where the +# executable is located. This is meant to find binary packages for the +# same architecture as the current executable. +# +# tcl_pkgPath, which is set by the platform-specific initialization routines +# On UNIX it is compiled in +# On Windows, it is not used if {![info exists auto_path]} { - if [catch {set auto_path $env(TCLLIBPATH)}] { + if {[info exists env(TCLLIBPATH)]} { + set auto_path $env(TCLLIBPATH) + } else { set auto_path "" } } -if {[lsearch -exact $auto_path [info library]] < 0} { - lappend auto_path [info library] +namespace eval tcl { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + } + + if {![interp issafe]} { + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + encoding dirs $Path + } + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} {set val $arg} + } + return $val + } + proc max {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} {set val $arg} + } + return $val + } + namespace export min max + } } -catch { - foreach __dir $tcl_pkgPath { - if {[lsearch -exact $auto_path $__dir] < 0} { - lappend auto_path $__dir + +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { + namespace eval tcl { + proc EnvTraceProc {lo n1 n2 op} { + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x + } + proc InitWinEnv {} { + global env tcl_platform + foreach p [array names env] { + set u [string toupper $p] + if {$u ne $p} { + switch -- $u { + COMSPEC - + PATH { + 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 \ + [namespace code [list EnvTraceProc $p]] + } + } + } + } + if {![info exists env(COMSPEC)]} { + set env(COMSPEC) cmd.exe + } } + InitWinEnv } - unset __dir } # Setup the unknown package handler -package unknown tclPkgUnknown + +if {[interp issafe]} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} +} 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"} { + package unknown {::tcl::tm::UnknownHandler \ + {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} + } else { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + # Set up the 'clock' ensemble + + namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] + + proc clock args { + namespace eval ::tcl::clock [list namespace ensemble create -command \ + [uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \ + -subcommands { + add clicks format microseconds milliseconds scan seconds + }] + + # Auto-loading stubs for 'clock.tcl' + + foreach cmd {add format scan} { + proc ::tcl::clock::$cmd args { + variable TclLibDir + source -encoding utf-8 [file join $TclLibDir clock.tcl] + return [uplevel 1 [info level 0]] + } + } + + return [uplevel 1 [info level 0]] + } +} # Conditionalize for presence of exec. -if {[info commands exec] == ""} { +if {[namespace which -command exec] eq ""} { - # Some machines, such as the Macintosh, do not have exec. Also, on all + # Some machines do not have exec. Also, on all # platforms, safe interpreters do not have exec. set auto_noexec 1 } -set errorCode "" -set errorInfo "" # Define a log command (which can be overwitten to log errors # differently, specially when stderr is not available) -if {[info commands tclLog] == ""} { +if {[namespace which -command tclLog] eq ""} { proc tclLog {string} { catch {puts stderr $string} } } -# The procs defined in this file that have a leading space -# are 'hidden' from auto_mkindex because they are not -# auto-loadable. - - # unknown -- # This procedure is called when a Tcl command is invoked that doesn't # exist in the interpreter. It takes the following steps to make the @@ -87,102 +229,173 @@ if {[info commands tclLog] == ""} { # args - A list whose elements are the words of the original # command, including the command name. - proc unknown args { - global auto_noexec auto_noload env unknown_pending tcl_interactive - global errorCode errorInfo +proc unknown args { + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - # Save the values of errorCode and errorInfo variables, since they - # may get modified if caught errors occur below. The variables will - # be restored just before re-executing the missing command. + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } - set savedErrorCode $errorCode - set savedErrorInfo $errorInfo set name [lindex $args 0] - if ![info exists auto_noload] { + if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # - if [info exists unknown_pending($name)] { - return -code error "self-referential recursion in \"unknown\" for command \"$name\""; - } - set unknown_pending($name) pending; - set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg] - unset unknown_pending($name); + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::namespace current}] + } msg opts] + unset UnknownPending($name) if {$ret != 0} { - return -code $ret -errorcode $errorCode \ - "error while autoloading \"$name\": $msg" + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg } - if ![array size unknown_pending] { - unset unknown_pending + if {![array size UnknownPending]} { + unset UnknownPending } - if $msg { - set errorCode $savedErrorCode - set errorInfo $savedErrorInfo - set code [catch {uplevel 1 $args} msg] + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] if {$code == 1} { # - # Strip the last five lines off the error stack (they're - # from the "uplevel" command). + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. # - - set new [split $errorInfo \n] - set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] - return -code error -errorcode $errorCode \ - -errorinfo $new $msg + 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] + while {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + append cinfo "\"\n (\"uplevel\" body line 1)" + append cinfo "\n invoked from within" + append cinfo "\n\"uplevel 1 \$args\"" + # + # Try each possible form of the stack trace + # and trim the extra contribution from the matching case + # + set expect "$msg\n while executing\n\"$cinfo" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set expect "\n invoked from within\n\"$cinfo" + set exlen [string length $expect] + set eilen [string length $errInfo] + set i [expr {$eilen - $exlen - 1}] + set einfo [string range $errInfo 0 $i] + # + # For now verify that $errInfo consists of what we are about + # to return plus what we expected to trim off. + # + if {$errInfo ne "$einfo$expect"} { + error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ + [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo] + } + return -code error -errorcode $errCode \ + -errorinfo $einfo $msg } else { - return -code $code $msg + dict incr opts -level + return -options $opts $msg } } } - if {([info level] == 1) && ([info script] == "") \ + if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} { - if ![info exists auto_noexec] { + if {![info exists auto_noexec]} { set new [auto_execok $name] - if {$new != ""} { - set errorCode $savedErrorCode - set errorInfo $savedErrorInfo + if {$new ne ""} { set redir "" - if {[info commands console] == ""} { + if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" } - return [uplevel exec $redir $new [lrange $args 1 end]] + uplevel 1 [list ::catch \ + [concat exec $redir $new [lrange $args 1 end]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } - set errorCode $savedErrorCode - set errorInfo $savedErrorInfo - if {$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} } - if [info exists newcmd] { + if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 - return [uplevel $newcmd] + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } - set ret [catch {set cmds [info commands $name*]} msg] - if {[string compare $name "::"] == 0} { + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { set name "" } if {$ret != 0} { - return -code $ret -errorcode $errorCode \ - "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } } if {[llength $cmds] == 1} { - return [uplevel [lreplace $args 0 0 $cmds]] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } - if {[llength $cmds] != 0} { - if {$name == ""} { - return -code error "empty command name \"\"" - } else { - return -code error \ - "ambiguous command name \"$name\": [lsort $cmds]" - } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } return -code error "invalid command name \"$name\"" @@ -194,91 +407,117 @@ if {[info commands tclLog] == ""} { # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. # -# Arguments: +# Arguments: # cmd - Name of the command to find and load. # namespace (optional) The namespace where the command is being used - must be # a canonical namespace as returned [namespace current] # for instance. If not given, namespace current is used. - proc auto_load {cmd {namespace {}}} { - global auto_index auto_oldpath auto_path env errorInfo errorCode +proc auto_load {cmd {namespace {}}} { + global auto_index auto_path - if {[string length $namespace] == 0} { - set namespace [uplevel {namespace current}] + if {$namespace eq ""} { + set namespace [uplevel 1 [list ::namespace current]] } set nameList [auto_qualify $cmd $namespace] # workaround non canonical auto_index entries that might be around # from older auto_mkindex versions lappend nameList $cmd foreach name $nameList { - if [info exists auto_index($name)] { - uplevel #0 $auto_index($name) - return [expr {[info commands $name] != ""}] + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + # There's a couple of ways to look for a command of a given + # name. One is to use + # info commands $name + # Unfortunately, if the name has glob-magic chars in it like * + # or [], it may not match. For our purposes here, a better + # route is to use + # namespace which -command $name + if {[namespace which -command $name] ne ""} { + return 1 + } } } - if ![info exists auto_path] { + if {![info exists auto_path]} { + return 0 + } + + if {![auto_load_index]} { return 0 } - if [info exists auto_oldpath] { - if {$auto_oldpath == $auto_path} { - return 0 + foreach name $nameList { + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + if {[namespace which -command $name] ne ""} { + return 1 + } } } + return 0 +} + +# auto_load_index -- +# Loads the contents of tclIndex files on the auto_path directory +# list. This is usually invoked within auto_load to load the index +# of available commands. Returns 1 if the index is loaded, and 0 if +# the index is already loaded and up to date. +# +# Arguments: +# None. + +proc auto_load_index {} { + variable ::tcl::auto_oldpath + global auto_index auto_path + + if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { + return 0 + } set auto_oldpath $auto_path # Check if we are a safe interpreter. In that case, we support only # newer format tclIndex files. set issafe [interp issafe] - for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { set dir [lindex $auto_path $i] set f "" if {$issafe} { catch {source [file join $dir tclIndex]} - } elseif [catch {set f [open [file join $dir tclIndex]]}] { + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { set id [gets $f] - if {$id == "# Tcl autoload index file, version 2.0"} { + if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] - } elseif {$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 index $line 0] == "#") + if {([string index $line 0] eq "#") \ || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) \ - "source [file join $dir [lindex $line 1]]" + "source [file join $dir [lindex $line 1]]" } } else { - error \ - "[file join $dir tclIndex] isn't a proper Tcl index file" + error "[file join $dir tclIndex] isn't a proper Tcl index file" } - } msg] - if {$f != ""} { + } msg opts] + if {$f ne ""} { close $f } - if $error { - error $msg $errorInfo $errorCode - } - } - } - foreach name $nameList { - if [info exists auto_index($name)] { - uplevel #0 $auto_index($name) - if {[info commands $name] != ""} { - return 1 + if {$error} { + return -options $opts $msg } } } - return 0 + return 1 } # auto_qualify -- -# compute a fully qualified names list for use in the auto_index array. +# +# Compute a fully qualified names list for use in the auto_index array. # For historical reasons, commands in the global namespace do not have leading # :: in the index key. The list has two elements when the command name is # relative (no leading ::) and the namespace is not the global one. Otherwise @@ -291,7 +530,7 @@ if {[info commands tclLog] == ""} { # a canonical namespace as returned by [namespace current] # for instance. - proc auto_qualify {cmd namespace} { +proc auto_qualify {cmd namespace} { # count separators and clean them up # (making sure that foo:::::bar will be treated as foo::bar) @@ -302,53 +541,85 @@ if {[info commands tclLog] == ""} { # Before each return case we give an example of which category it is # with the following form : - # ( inputCmd, inputNameSpace) -> output + # (inputCmd, inputNameSpace) -> output - if {[regexp {^::(.*)$} $cmd x tail]} { + if {[string match ::* $cmd]} { if {$n > 1} { - # ( ::foo::bar , * ) -> ::foo::bar + # (::foo::bar , *) -> ::foo::bar return [list $cmd] } else { - # ( ::global , * ) -> global - return [list $tail] + # (::global , *) -> global + return [list [string range $cmd 2 end]] } } - + # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { - if {[string compare $namespace ::] == 0} { - # ( nocolons , :: ) -> nocolons + if {$namespace eq "::"} { + # (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 + return [list ::$cmd] } else { - if {[string compare $namespace ::] == 0} { - # ( foo::bar , :: ) -> ::foo::bar - return [list ::$cmd] - } else { - # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar - return [list ${namespace}::$cmd ::$cmd] - } + # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar + return [list ${namespace}::$cmd ::$cmd] } } -if {[string compare $tcl_platform(platform) windows] == 0} { +# auto_import -- +# +# Invoked during "namespace import" to make see if the imported commands +# reside in an autoloaded library. If so, the commands are loaded so +# that they will be available for the import links. If not, then this +# procedure does nothing. +# +# Arguments - +# pattern The pattern of commands being imported (like "foo::*") +# a canonical namespace as returned by [namespace current] + +proc auto_import {pattern} { + global auto_index + + # If no namespace is specified, this will be an error case + + if {![string match *::* $pattern]} { + return + } + + set ns [uplevel 1 [list ::namespace current]] + set patternList [auto_qualify $pattern $ns] + + auto_load_index + + foreach pattern $patternList { + foreach name [array names auto_index $pattern] { + if {([namespace which -command $name] eq "") + && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { + namespace eval :: $auto_index($name) + } + } + } +} # auto_execok -- # -# Returns string that indicates name of program to execute if +# Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, # for speed. # -# Arguments: +# Arguments: # name - Name of a command. +if {$tcl_platform(platform) eq "windows"} { # Windows version. # # Note that info executable doesn't work under Windows, so we have to @@ -359,18 +630,37 @@ if {[string compare $tcl_platform(platform) windows] == 0} { proc auto_execok name { global auto_execs env tcl_platform - if [info exists auto_execs($name)] { + if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" - if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename - ren rmdir rd time type ver vol} $name] != -1} { - return [set auto_execs($name) [list $env(COMSPEC) /c $name]] + set shellBuiltins [list cls copy date del erase dir echo mkdir \ + md rename ren rmdir rd time type ver vol] + if {$tcl_platform(os) eq "Windows NT"} { + # NT includes the 'start' built-in + lappend shellBuiltins "start" + } + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + 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. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] } if {[llength [file split $name]] != 1} { - foreach ext {{} .com .exe .bat} { + foreach ext $execExtensions { set file ${name}${ext} if {[file exists $file] && ![file isdirectory $file]} { return [set auto_execs($name) [list $file]] @@ -381,24 +671,29 @@ proc auto_execok name { set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) + set windir $env(WINDIR) } if {[info exists windir]} { - if {$tcl_platform(os) == "Windows NT"} { + if {$tcl_platform(os) eq "Windows NT"} { append path "$windir/system32;" } append path "$windir/system;$windir;" } - if {[info exists env(PATH)]} { - append path $env(PATH) + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } } - foreach dir [split $path {;}] { - if {$dir == ""} { - set dir . - } - foreach ext {{} .com .exe .bat} { + 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]] @@ -409,23 +704,12 @@ proc auto_execok name { } } else { - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to an executable in the path. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - # Unix version. # proc auto_execok name { global auto_execs env - if [info exists auto_execs($name)] { + if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" @@ -436,7 +720,7 @@ proc auto_execok name { return $auto_execs($name) } foreach dir [split $env(PATH) :] { - if {$dir == ""} { + if {$dir eq ""} { set dir . } set file [file join $dir $name] @@ -449,337 +733,89 @@ proc auto_execok name { } } -# auto_reset -- -# Destroy all cached information for auto-loading and auto-execution, -# so that the information gets recomputed the next time it's needed. -# Also delete any procedures that are listed in the auto-load index -# except those defined in this file. -# -# Arguments: -# None. - -proc auto_reset {} { - global auto_execs auto_index auto_oldpath - foreach p [info procs] { - if {[info exists auto_index($p)] && ![string match auto_* $p] - && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup - tclMacPkgSearch tclPkgUnknown} $p] < 0)} { - rename $p {} - } - } - catch {unset auto_execs} - catch {unset auto_index} - catch {unset auto_oldpath} -} -# auto_mkindex -- -# Regenerate a tclIndex file from Tcl source files. Takes as argument -# the name of the directory in which the tclIndex file is to be placed, -# followed by any number of glob patterns to use in that directory to -# locate all of the relevant files. It does not parse or source the file -# so the generated index will not contain the appropriate namespace qualifiers -# if you don't explicitly specify it. +# ::tcl::CopyDirectory -- # -# Arguments: -# dir - Name of the directory in which to create an index. -# args - Any number of additional arguments giving the -# names of files within dir. If no additional -# are given auto_mkindex will look for *.tcl. - -proc auto_mkindex {dir args} { - global errorCode errorInfo - set oldDir [pwd] - cd $dir - set dir [pwd] - append index "# Tcl autoload index file, version 2.0\n" - append index "# This file is generated by the \"auto_mkindex\" command\n" - append index "# and sourced to set up indexing information for one or\n" - append index "# more commands. Typically each line is a command that\n" - append index "# sets an element in the auto_index array, where the\n" - append index "# element name is the name of a command and the value is\n" - append index "# a script that loads the command.\n\n" - if {$args == ""} { - set args *.tcl - } - foreach file [eval glob $args] { - set f "" - set error [catch { - set f [open $file] - while {[gets $f line] >= 0} { - if [regexp {^proc[ ]+([^ ]*)} $line match procName] { - set procName [lindex [auto_qualify $procName "::"] 0] - append index "set [list auto_index($procName)]" - append index " \[list source \[file join \$dir [list $file]\]\]\n" - } - } - close $f - } msg] - if $error { - set code $errorCode - set info $errorInfo - catch {close $f} - cd $oldDir - error $msg $info $code - } - } - set f "" - set error [catch { - set f [open tclIndex w] - puts $f $index nonewline - close $f - cd $oldDir - } msg] - if $error { - set code $errorCode - set info $errorInfo - catch {close $f} - cd $oldDir - error $msg $info $code - } -} - -# pkg_mkIndex -- -# This procedure creates a package index in a given directory. The -# package index consists of a "pkgIndex.tcl" file whose contents are -# a Tcl script that sets up package information with "package require" -# commands. The commands describe all of the packages defined by the -# files given as arguments. +# This procedure is called by Tcl's core when attempts to call the +# filesystem's copydirectory function fail. The semantics of the call +# are that 'dest' does not yet exist, i.e. dest should become the exact +# image of src. If dest does exist, we throw an error. +# +# Note that making changes to this procedure can change the results +# of running Tcl's tests. # # Arguments: -# dir - Name of the directory in which to create the index. -# args - Any number of additional arguments, each giving -# a glob pattern that matches the names of one or -# more shared libraries or Tcl script files in -# dir. - -proc pkg_mkIndex {dir args} { - global errorCode errorInfo - if {[llength $args] == 0} { - return -code error "wrong # args: should be\ - \"pkg_mkIndex dir pattern ?pattern ...?\""; - } - append index "# Tcl package index file, version 1.0\n" - append index "# This file is generated by the \"pkg_mkIndex\" command\n" - append index "# and sourced either when an application starts up or\n" - append index "# by a \"package unknown\" script. It invokes the\n" - append index "# \"package ifneeded\" command to set up package-related\n" - append index "# information so that packages will be loaded automatically\n" - append index "# in response to \"package require\" commands. When this\n" - append index "# script is sourced, the variable \$dir must contain the\n" - append index "# full path name of this file's directory.\n" - set oldDir [pwd] - cd $dir - foreach file [eval glob $args] { - # For each file, figure out what commands and packages it provides. - # To do this, create a child interpreter, load the file into the - # interpreter, and get a list of the new commands and packages - # that are defined. Define an empty "package unknown" script so - # that there are no recursive package inclusions. - - set c [interp create] - - # If Tk is loaded in the parent interpreter, load it into the - # child also, in case the extension depends on it. - - foreach pkg [info loaded] { - if {[lindex $pkg 1] == "Tk"} { - $c eval {set argv {-geometry +0+0}} - load [lindex $pkg 0] Tk $c - break - } - } - $c eval [list set file $file] - if [catch { - $c eval { - proc dummy args {} - rename package package-orig - proc package {what args} { - switch -- $what { - require { return ; # ignore transitive requires } - default { eval package-orig {$what} $args } - } - } - proc pkgGetAllNamespaces {{root {}}} { - set list $root - foreach ns [namespace children $root] { - eval lappend list [pkgGetAllNamespaces $ns] - } - return $list - } - package unknown dummy - set origCmds [info commands] - set dir "" ;# in case file is pkgIndex.tcl - set pkgs "" - - # Try to load the file if it has the shared library extension, - # otherwise source it. It's important not to try to load - # files that aren't shared libraries, because on some systems - # (like SunOS) the loader will abort the whole application - # when it gets an error. - - if {[string compare [file extension $file] \ - [info sharedlibextension]] == 0} { - - # The "file join ." command below is necessary. Without - # it, if the file name has no \'s and we're on UNIX, the - # load command will invoke the LD_LIBRARY_PATH search - # mechanism, which could cause the wrong file to be used. - - load [file join . $file] - set type load - } else { - source $file - set type source - } - foreach ns [pkgGetAllNamespaces] { - namespace import ${ns}::* - } - foreach i [info commands] { - set cmds($i) 1 - } - foreach i $origCmds { - catch {unset cmds($i)} - - } - foreach i [array names cmds] { - # reverse engineer which namespace a command comes from - set absolute [namespace origin $i] - if {[string compare ::$i $absolute] != 0} { - set cmds($absolute) 1 - unset cmds($i) - } - } - foreach i [package names] { - if {([string compare [package provide $i] ""] != 0) - && ([string compare $i Tcl] != 0) - && ([string compare $i Tk] != 0)} { - lappend pkgs [list $i [package provide $i]] - } +# action - "renaming" or "copying" +# src - source directory +# dest - destination directory +proc tcl::CopyDirectory {action src dest} { + set nsrc [file normalize $src] + set ndest [file normalize $dest] + + 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 {$nsrc in [file volumes]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + if {[file exists $dest]} { + if {$nsrc eq $ndest} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + if {$action eq "copying"} { + # We used to throw an error here, but, looking more closely + # at the core copy code in tclFCmd.c, if the destination + # exists, then we should only call this function if -force + # is true, which means we just want to over-write. So, + # the following code is now commented out. + # + # return -code error "error $action \"$src\" to\ + # \"$dest\": file already exists" + } else { + # Depending on the platform, and on the current + # working directory, the directories '.', '..' + # can be returned in various combinations. Anyway, + # if any other file is returned, we must signal an error. + set existing [glob -nocomplain -directory $dest * .*] + lappend existing {*}[glob -nocomplain -directory $dest \ + -type hidden * .*] + foreach s $existing { + if {[file tail $s] ni {. ..}} { + return -code error "error $action \"$src\" to\ + \"$dest\": file already exists" } } - } msg] { - tclLog "error while loading or sourcing $file: $msg" - } - foreach pkg [$c eval set pkgs] { - lappend files($pkg) [list $file [$c eval set type] \ - [lsort [$c eval array names cmds]]] - } - interp delete $c - } - foreach pkg [lsort [array names files]] { - append index "\npackage ifneeded $pkg\ - \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ - [list $files($pkg)]\]" - } - set f [open pkgIndex.tcl w] - puts $f $index - close $f - cd $oldDir -} - -# tclPkgSetup -- -# This is a utility procedure use by pkgIndex.tcl files. It is invoked -# as part of a "package ifneeded" script. It calls "package provide" -# to indicate that a package is available, then sets entries in the -# auto_index array so that the package's files will be auto-loaded when -# the commands are used. -# -# Arguments: -# dir - Directory containing all the files for this package. -# pkg - Name of the package (no version number). -# version - Version number for the package, such as 2.1.3. -# files - List of files that constitute the package. Each -# element is a sub-list with three elements. The first -# is the name of a file relative to $dir, the second is -# "load" or "source", indicating whether the file is a -# loadable binary or a script to source, and the third -# is a list of commands defined by this file. - -proc tclPkgSetup {dir pkg version files} { - global auto_index - - package provide $pkg $version - foreach fileInfo $files { - set f [lindex $fileInfo 0] - set type [lindex $fileInfo 1] - foreach cmd [lindex $fileInfo 2] { - if {$type == "load"} { - set auto_index($cmd) [list load [file join $dir $f] $pkg] - } else { - set auto_index($cmd) [list source [file join $dir $f]] - } } - } -} - -# tclMacPkgSearch -- -# The procedure is used on the Macintosh to search a given directory for files -# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the -# interpreter to setup the package database. - -proc tclMacPkgSearch {dir} { - foreach x [glob -nocomplain [file join $dir *.shlb]] { - if [file isfile $x] { - set res [resource open $x] - foreach y [resource list TEXT $res] { - if {$y == "pkgIndex"} {source -rsrc pkgIndex} + } else { + if {[string first $nsrc $ndest] != -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\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" } - catch {resource close $res} } + file mkdir $dest } -} - -# tclPkgUnknown -- -# This procedure provides the default for the "package unknown" function. -# It is invoked when a package that's needed can't be found. It scans -# the auto_path directories and their immediate children looking for -# pkgIndex.tcl files and sources any such files that are found to setup -# the package database. (On the Macintosh we also search for pkgIndex -# TEXT resources in all files.) -# -# Arguments: -# name - Name of desired package. Not used. -# version - Version of desired package. Not used. -# exact - Either "-exact" or omitted. Not used. - -proc tclPkgUnknown {name version {exact {}}} { - global auto_path tcl_platform env + # Have to be careful to capture both visible and hidden files. + # We will also be more generous to the file system and not + # assume the hidden and non-hidden lists are non-overlapping. + # + # On Unix 'hidden' files begin with '.'. On other platforms + # or filesystems hidden files may have other interpretations. + set filelist [concat [glob -nocomplain -directory $src *] \ + [glob -nocomplain -directory $src -types hidden *]] - if ![info exists auto_path] { - return - } - for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { - # we can't use glob in safe interps, so enclose the following - # in a catch statement - catch { - foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ - * pkgIndex.tcl]] { - set dir [file dirname $file] - if [catch {source $file} msg] { - tclLog "error reading package index file $file: $msg" - } - } - } - set dir [lindex $auto_path $i] - set file [file join $dir pkgIndex.tcl] - # safe interps usually don't have "file readable", nor stderr channel - if {[interp issafe] || [file readable $file]} { - if {[catch {source $file} msg] && ![interp issafe]} { - tclLog "error reading package index file $file: $msg" - } - } - # On the Macintosh we also look in the resource fork - # of shared libraries - # We can't use tclMacPkgSearch in safe interps because it uses glob - if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} { - set dir [lindex $auto_path $i] - tclMacPkgSearch $dir - foreach x [glob -nocomplain [file join $dir *]] { - if [file isdirectory $x] { - set dir $x - tclMacPkgSearch $dir - } - } + foreach s [lsort -unique $filelist] { + if {[file tail $s] ni {. ..}} { + file copy -force -- $s [file join $dest [file tail $s]] } } + return } |