diff options
Diffstat (limited to 'contrib/tcl/library/init.tcl')
| -rw-r--r-- | contrib/tcl/library/init.tcl | 106 |
1 files changed, 74 insertions, 32 deletions
diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl index 43bd37c..1985224 100644 --- a/contrib/tcl/library/init.tcl +++ b/contrib/tcl/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# SCCS: @(#) init.tcl 1.79 97/06/24 17:18:54 +# SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -18,9 +18,11 @@ if {[info commands package] == ""} { package require -exact Tcl 8.0 # Compute the auto path to use in this interpreter. - -if [catch {set auto_path $env(TCLLIBPATH)}] { - set auto_path "" +# (auto_path could be already set, in safe interps for instance) +if {![info exists auto_path]} { + if [catch {set auto_path $env(TCLLIBPATH)}] { + set auto_path "" + } } if {[lsearch -exact $auto_path [info library]] < 0} { lappend auto_path [info library] @@ -47,6 +49,14 @@ if {[info commands exec] == ""} { 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] == ""} { + proc tclLog {string} { + catch {puts stderr $string} + } +} # unknown -- # This procedure is called when a Tcl command is invoked that doesn't @@ -132,14 +142,17 @@ proc unknown args { set errorCode $savedErrorCode set errorInfo $savedErrorInfo if {$name == "!!"} { -# return [uplevel {history redo}] - return -code error "!! is disabled until history is fixed in Tcl8.0" + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name dummy event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} } - if [regexp {^!(.+)$} $name dummy event] { - return [uplevel [list history redo $event]] - } - if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { - return [uplevel [list history substitute $old $new]] + if [info exists newcmd] { + tclLog $newcmd + history change $newcmd 0 + return [uplevel $newcmd] } set ret [catch {set cmds [info commands $name*]} msg] @@ -177,9 +190,11 @@ proc unknown args { proc auto_load cmd { global auto_index auto_oldpath auto_path env errorInfo errorCode - if [info exists auto_index($cmd)] { - uplevel #0 $auto_index($cmd) - return [expr {[info commands $cmd] != ""}] + foreach name [list $cmd ::$cmd] { + if [info exists auto_index($name)] { + uplevel #0 $auto_index($name) + return [expr {[info commands $name] != ""}] + } } if ![info exists auto_path] { return 0 @@ -455,6 +470,10 @@ proc auto_mkindex {dir args} { 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" @@ -489,6 +508,13 @@ proc pkg_mkIndex {dir args} { 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 } + } + } package unknown dummy set origCmds [info commands] set dir "" ;# in case file is pkgIndex.tcl @@ -514,11 +540,23 @@ proc pkg_mkIndex {dir args} { source $file set type source } + foreach ns [namespace children] { + 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) @@ -529,7 +567,7 @@ proc pkg_mkIndex {dir args} { } } } msg] { - puts "error while loading or sourcing $file: $msg" + tclLog "error while loading or sourcing $file: $msg" } foreach pkg [$c eval set pkgs] { lappend files($pkg) [list $file [$c eval set type] \ @@ -623,33 +661,37 @@ proc tclPkgUnknown {name version {exact {}}} { set save_dir $dir } for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { - foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ - * pkgIndex.tcl]] { - set dir [file dirname $file] - if [catch {source $file} msg] { - puts stderr \ - "error reading package index file $file: $msg" + # 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] - if [file readable $file] { - if [catch {source $file} msg] { - puts stderr \ - "error reading package index file $file: $msg" + # 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 - if {$tcl_platform(platform) == "macintosh"} { + # 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 x [glob -nocomplain [file join $dir *]] { + if [file isdirectory $x] { + set dir $x + tclMacPkgSearch $dir + } } - } } } if {[info exists save_dir]} { |
