summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl278
1 files changed, 182 insertions, 96 deletions
diff --git a/library/init.tcl b/library/init.tcl
index f2f85e1..28689ab 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -6,6 +6,7 @@
# 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.
@@ -14,7 +15,7 @@
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.4
+package require -exact Tcl 8.5.11
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -22,7 +23,7 @@ package require -exact Tcl 8.4
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.
-# tclInitScript.h searches around for the directory containing this
+# [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
@@ -35,7 +36,6 @@ package require -exact Tcl 8.4
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
-# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)]} {
@@ -46,30 +46,74 @@ if {![info exists auto_path]} {
}
namespace eval tcl {
variable Dir
- if {[info library] ne ""} {
- foreach Dir [list [info library] [file dirname [info library]]] {
- if {[lsearch -exact $::auto_path $Dir] < 0} {
- lappend ::auto_path $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 {[lsearch -exact $::auto_path $Dir] < 0} {
+ if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
- if {[info exists ::tcl_pkgPath]} {
+ catch {
foreach Dir $::tcl_pkgPath {
- if {[lsearch -exact $::auto_path $Dir] < 0} {
+ 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] == 0} {
+ 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] == 0} {
+ 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
+ }
}
-
+
# Windows specific end of initialization
-if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
+if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
set x $::env($n2)
@@ -109,16 +153,42 @@ if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
# Setup the unknown package handler
-package unknown tclPkgUnknown
-if {![interp issafe]} {
- # setup platform specific unknown package handlers
- if {$::tcl_platform(platform) eq "unix"
- && $::tcl_platform(os) eq "Darwin"} {
- package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
- }
- if {$::tcl_platform(platform) eq "macintosh"} {
- package unknown [list tcl::MacPkgUnknown [package unknown]]
+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]]
}
}
@@ -126,13 +196,11 @@ if {![interp issafe]} {
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)
@@ -166,72 +234,74 @@ if {[namespace which -command tclLog] eq ""} {
# command, including the command name.
proc unknown args {
- global auto_noexec auto_noload env unknown_pending tcl_interactive
- global errorCode errorInfo
+ variable ::tcl::UnknownPending
+ global auto_noexec auto_noload env tcl_interactive
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
+ #return -code error "You need an {*}"
set arglist [lrange $args 1 end]
- set ret [catch {uplevel 1 ::$cmd $arglist} result]
- if {$ret == 0} {
- return $result
- } else {
- return -code $ret -errorcode $errorCode $result
- }
+ set ret [catch {uplevel 1 ::$cmd $arglist} result opts]
+ dict unset opts -errorinfo
+ dict incr opts -level
+ return -options $opts $result
}
- # 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.
-
- # Safety check in case something unsets the variables
- # ::errorInfo or ::errorCode. [Bug 1063707]
- if {![info exists errorCode]} {
- set errorCode ""
- }
- if {![info exists errorInfo]} {
- set errorInfo ""
- }
- set savedErrorCode $errorCode
- set savedErrorInfo $errorInfo
+ catch {set savedErrorInfo $::errorInfo}
+ catch {set savedErrorCode $::errorCode}
set name $cmd
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} {
- append errorInfo "\n (autoloading \"$name\")"
- return -code $ret -errorcode $errorCode -errorinfo $errorInfo $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 {[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} {
#
# Compute stack trace contribution from the [uplevel].
# 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 cinfo $args
- set ellipsis ""
- while {[string bytelength $cinfo] > 150} {
- set cinfo [string range $cinfo 0 end-1]
- set ellipsis "..."
+ 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 $ellipsis "\"\n (\"uplevel\" body line 1)"
+ append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
#
@@ -244,7 +314,9 @@ proc unknown args {
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
- return -code error -errorcode $errorCode $msg
+ dict unset opts -errorinfo
+ dict incr opts -level
+ return -options $opts $msg
}
#
# Stack trace is nested, trim off just the contribution
@@ -261,32 +333,33 @@ proc unknown args {
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $expect $errorInfo]
+ [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
}
return -code error -errorcode $errorCode \
-errorinfo $einfo $msg
} else {
- return -code $code $msg
+ dict incr opts -level
+ return -options $opts $msg
}
}
}
- 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]
if {$new ne ""} {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
set redir ""
if {[namespace which -command console] eq ""} {
set redir ">&@stdout <@stdin"
}
- return [uplevel 1 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 eq "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
@@ -298,7 +371,10 @@ proc unknown args {
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
- return [uplevel 1 $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 candidates [info commands $name*]} msg]
@@ -306,9 +382,9 @@ proc unknown args {
set name ""
}
if {$ret != 0} {
- return -code $ret -errorcode $errorCode \
- "error in unknown while checking if \"$name\" is\
- a unique command abbreviation:\n$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]
@@ -325,7 +401,10 @@ proc unknown args {
}
}
if {[llength $cmds] == 1} {
- return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
+ 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]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
@@ -347,7 +426,7 @@ proc unknown args {
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
- global auto_index auto_oldpath auto_path
+ global auto_index auto_path
if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
@@ -399,9 +478,10 @@ proc auto_load {cmd {namespace {}}} {
# None.
proc auto_load_index {} {
- global auto_index auto_oldpath auto_path errorInfo errorCode
+ variable ::tcl::auto_oldpath
+ global auto_index auto_path
- if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
+ if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {
return 0
}
set auto_oldpath $auto_path
@@ -424,7 +504,7 @@ proc auto_load_index {} {
eval [read $f]
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
- if {[string index $line 0] eq "#"
+ if {([string index $line 0] eq "#") \
|| ([llength $line] != 2)} {
continue
}
@@ -435,12 +515,12 @@ proc auto_load_index {} {
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
- } msg]
+ } msg opts]
if {$f ne ""} {
close $f
}
if {$error} {
- error $msg $errorInfo $errorCode
+ return -options $opts $msg
}
}
}
@@ -577,10 +657,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 {[lsearch -exact $shellBuiltins [string tolower $name]] != -1} {
+ 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.
@@ -620,7 +700,7 @@ proc auto_execok name {
foreach dir [split $path {;}] {
# Skip already checked directories
- if {[info exists checked($dir)] || $dir eq {}} { continue }
+ if {[info exists checked($dir)] || ($dir eq {})} { continue }
set checked($dir) {}
foreach ext $execExtensions {
set file [file join $dir ${name}${ext}]
@@ -680,10 +760,11 @@ proc auto_execok name {
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 {[lsearch -exact [file volumes] $nsrc] != -1} {
+ if {$nsrc in [file volumes]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
@@ -696,17 +777,22 @@ proc tcl::CopyDirectory {action src dest} {
into itself"
}
if {$action eq "copying"} {
- return -code error "error $action \"$src\" to\
- \"$dest\": file already exists"
+ # 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 * .*]
- eval [linsert \
- [glob -nocomplain -directory $dest -type hidden * .*] 0 \
- lappend existing]
+ lappend existing {*}[glob -nocomplain -directory $dest \
+ -type hidden * .*]
foreach s $existing {
if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
return -code error "error $action \"$src\" to\
@@ -734,10 +820,10 @@ proc tcl::CopyDirectory {action src dest} {
# or filesystems hidden files may have other interpretations.
set filelist [concat [glob -nocomplain -directory $src *] \
[glob -nocomplain -directory $src -types hidden *]]
-
+
foreach s [lsort -unique $filelist] {
if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
- file copy $s [file join $dest [file tail $s]]
+ file copy -force $s [file join $dest [file tail $s]]
}
}
return