summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclInterp.c7
-rw-r--r--generic/tclMain.c20
-rw-r--r--library/auto.tcl29
-rw-r--r--library/clock.tcl72
-rw-r--r--library/init.tcl57
6 files changed, 92 insertions, 105 deletions
diff --git a/ChangeLog b/ChangeLog
index 0df87bb..0d25fa5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2004-10-25 Don Porter <dgp@users.sourceforge.net>
+
+ * library/auto.tcl Purged Tcl's script library of all
+ * library/clock.tcl remaining references to global vars
+ * library/init.tcl ::errorInfo and ::errorCode.
+
+ * generic/tclMain.c (Tcl_Main): Updated to make use of
+ TclGetReturnOptions instead of ::errorInfo variable.
+
+ * generic/tclInterp.c (tclInit): Bug fix. Access dict variables
+ with [dict get], not array syntax.
+
2004-10-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* tests/tm.test: Rewrote the tests to actually perform syntax
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 51ce8fd..4ee52f6 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.47 2004/10/15 04:01:32 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.48 2004/10/25 17:24:37 dgp Exp $
*/
#include "tclInt.h"
@@ -84,10 +84,11 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
set tcl_library $i\n\
set tclfile [file join $i init.tcl]\n\
if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg opt]} {\n\
+ if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n\
return\n\
} else {\n\
- append errors \"$tclfile: $msg\n$opt(-errorinfo)\n\"\n\
+ append errors \"$tclfile: $msg\n\"\n\
+ append errors \"[dict get $opts -errorinfo]\n\"\n\
}\n\
}\n\
}\n\
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 238b485..7869cec 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.28 2004/10/15 04:01:32 dgp Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.29 2004/10/25 17:24:39 dgp Exp $
*/
#include "tclInt.h"
@@ -435,17 +435,19 @@ Tcl_Main(argc, argv, appInitProc)
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
+ Tcl_Obj *options = TclGetReturnOptions(interp, code);
+ Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1);
+ Tcl_Obj *valuePtr;
- /*
- * The following statement guarantees that the errorInfo
- * variable is set properly when the error has to do with
- * the opening or reading of the file.
- */
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
- Tcl_AddErrorInfo(interp, "");
- Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
- NULL, TCL_GLOBAL_ONLY));
+ if (valuePtr) {
+ Tcl_WriteObj(errChannel, valuePtr);
+ }
Tcl_WriteChars(errChannel, "\n", 1);
+ Tcl_DecrRefCount(options);
}
exitCode = 1;
}
diff --git a/library/auto.tcl b/library/auto.tcl
index c80e1ea..7552414 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
-# RCS: @(#) $Id: auto.tcl,v 1.18 2004/08/23 17:40:27 dgp Exp $
+# RCS: @(#) $Id: auto.tcl,v 1.19 2004/10/25 17:24:39 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -51,7 +51,7 @@ proc auto_reset {} {
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
- global env errorInfo
+ global env
set dirs {}
set errors {}
@@ -141,10 +141,11 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
- if {![catch {uplevel #0 [list source $file]} msg]} {
+ if {![catch {uplevel #0 [list source $file]} msg opts]} {
return
} else {
- append errors "$file: $msg\n$errorInfo\n"
+ append errors "$file: $msg\n"
+ append errors [dict get $opts -errorinfo]\n
}
}
}
@@ -186,8 +187,6 @@ if {[interp issafe]} {
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
- global errorCode errorInfo
-
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
@@ -209,13 +208,11 @@ proc auto_mkindex {dir args} {
auto_mkindex_parser::init
foreach file [glob {expand}$args] {
- if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
+ if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
append index $msg
} else {
- set code $errorCode
- set info $errorInfo
cd $oldDir
- error $msg $info $code
+ return -options $opts $msg
}
}
auto_mkindex_parser::cleanup
@@ -230,7 +227,6 @@ proc auto_mkindex {dir args} {
# code for "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
- global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
@@ -256,13 +252,11 @@ proc auto_mkindex_old {dir args} {
}
}
close $f
- } msg]
+ } msg opts]
if {$error} {
- set code $errorCode
- set info $errorInfo
catch {close $f}
cd $oldDir
- error $msg $info $code
+ return -options $opts $msg
}
}
set f ""
@@ -271,13 +265,12 @@ proc auto_mkindex_old {dir args} {
puts -nonewline $f $index
close $f
cd $oldDir
- } msg]
+ } msg opts]
if {$error} {
- set code $errorCode
- set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
+ return -options $opts $msg
}
}
diff --git a/library/clock.tcl b/library/clock.tcl
index 7fdc654..15456d2 100644
--- a/library/clock.tcl
+++ b/library/clock.tcl
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: clock.tcl,v 1.8 2004/10/22 14:27:39 kennykb Exp $
+# RCS: @(#) $Id: clock.tcl,v 1.9 2004/10/25 17:24:39 dgp Exp $
#
#----------------------------------------------------------------------
@@ -1036,7 +1036,7 @@ proc ::tcl::clock::format { args } {
set retval
- } result]
+ } result opts]
# Restore the locale
@@ -1045,12 +1045,10 @@ proc ::tcl::clock::format { args } {
}
if { $status == 1 } {
- if { [lindex $::errorCode 0] eq {clock} } {
+ if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
return -code error $result
} else {
- return -code error \
- -errorcode $::errorCode -errorinfo $::errorInfo \
- $result
+ return -options $opts $result
}
} else {
return $result
@@ -1153,15 +1151,7 @@ proc ::tcl::clock::scan { args } {
"legacy \[clock scan\] does not support -locale"
}
- if { [catch {
- FreeScan $string $base $timezone $locale
- } retval] } {
- return -code error \
- -errorcode $::errorCode -errorinfo $::errorInfo \
- $retval
- } else {
- return $retval
- }
+ return [FreeScan $string $base $timezone $locale]
}
# Change locale if a fresh locale has been given on the command line.
@@ -1176,7 +1166,7 @@ proc ::tcl::clock::scan { args } {
set scanner [ParseClockScanFormat $format]
$scanner $string $base $timezone
- } result]
+ } result opts]
# Restore the locale
@@ -1185,12 +1175,10 @@ proc ::tcl::clock::scan { args } {
}
if { $status == 1 } {
- if { [lindex $::errorCode 0] eq {clock} } {
+ if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
return -code error $result
} else {
- return -code error \
- -errorcode $::errorCode -errorinfo $::errorInfo \
- $result
+ return -options $opts $result
}
} else {
return $result
@@ -2998,8 +2986,9 @@ proc ::tcl::clock::ConvertLocalToUTC { date } {
if { [catch {
ConvertLocalToUTCViaC [dict get $date localSeconds]
- } result] } {
- return -code error -errorcode $::errorCode $result
+ } result opts] } {
+ dict unset opts -errorinfo
+ return -options $opts $result
}
dict set date seconds $result
return $date
@@ -3008,8 +2997,9 @@ proc ::tcl::clock::ConvertLocalToUTC { date } {
# Get the time zone data
- if { [catch { SetupTimeZone $timezone } retval] } {
- return -code error -errorcode $::errorCode $retval
+ if { [catch { SetupTimeZone $timezone } retval opts] } {
+ dict unset opts -errorinfo
+ return -options $opts $retval
}
# Initially assume that local == UTC, and locate the last time
@@ -3103,8 +3093,9 @@ proc ::tcl::clock::ConvertUTCToLocal { date timezone } {
# Get the data for time changes in the given zone
- if { [catch { SetupTimeZone $timezone } retval] } {
- return -code error -errorcode $::errorCode $retval
+ if { [catch { SetupTimeZone $timezone } retval opts] } {
+ dict unset opts -errorinfo
+ return -options $opts $retval
}
if { $timezone eq {:localtime} } {
@@ -3113,8 +3104,9 @@ proc ::tcl::clock::ConvertUTCToLocal { date timezone } {
if { [catch {
ConvertUTCToLocalViaC $date
- } retval] } {
- return -code error -errorcode $::errorCode $retval
+ } retval opts] } {
+ dict unset opts -errorinfo
+ return -options $opts $retval
}
return $retval
}
@@ -3278,12 +3270,11 @@ proc ::tcl::clock::SetupTimeZone { timezone } {
# This looks like a POSIX time zone - try to process it
- if { [catch {ProcessPosixTimeZone $tzfields} data] } {
- if { [lindex $::errorCode 0] eq {CLOCK} } {
- return -code error -errorcode $::errorCode $data
- } else {
- error $tzfields $::errorInfo $::errorCode
+ if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
+ if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
+ dict unset opts -errorinfo
}
+ return -options $opts $data
} else {
set TZData($timezone) $data
}
@@ -3294,9 +3285,9 @@ proc ::tcl::clock::SetupTimeZone { timezone } {
# again with a time zone file - this time without a colon
if { [catch { LoadTimeZoneFile $timezone }]
- && [catch { LoadZoneinfoFile $timezone }] } {
- return -code error -errorcode $::errorCode \
- "time zone $timezone not found"
+ && [catch { LoadZoneinfoFile $timezone } - opts] } {
+ dict unset opts -errorinfo
+ return -options $opts "time zone $timezone not found"
}
set TZData($timezone) $TZData(:$timezone)
}
@@ -4831,7 +4822,7 @@ proc ::tcl::clock::add { clockval args } {
}
}
}
- } result]
+ } result opts]
# Restore the locale
@@ -4840,11 +4831,10 @@ proc ::tcl::clock::add { clockval args } {
}
if { $status == 1 } {
- if { [lindex $::errorCode 0] eq {CLOCK} } {
- return -code error -errorcode $::errorCode $result
- } else {
- error $result $::errorInfo $::errorCode
+ if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
+ dict unset opts -errorinfo
}
+ return -options $opts $result
} else {
return $clockval
}
diff --git a/library/init.tcl b/library/init.tcl
index 7b8d4de..96a2bad 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.65 2004/08/18 22:03:32 andreas_kupries Exp $
+# RCS: @(#) $Id: init.tcl,v 1.66 2004/10/25 17:24:40 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -130,8 +130,6 @@ if {[llength [info commands exec]] == 0} {
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)
@@ -167,7 +165,6 @@ if {[llength [info commands tclLog]] == 0} {
proc unknown args {
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive
- global errorCode errorInfo
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
@@ -175,48 +172,42 @@ proc unknown args {
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
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
+ return -options $opts $ret
}
- # 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.
-
- set savedErrorCode $errorCode
- set savedErrorInfo $errorInfo
set name [lindex $args 0]
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists UnknownPending($name)]} {
- return -code error "self-referential recursion in \"unknown\" for command \"$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]
+ 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 UnknownPending]} {
unset UnknownPending
}
if {$msg} {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- set code [catch {uplevel 1 $args} msg]
+ 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
if {[string bytelength $cinfo] > 153} {
set cinfo [string range $cinfo 0 152]
@@ -238,7 +229,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
@@ -270,8 +263,6 @@ proc unknown args {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new != ""} {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
@@ -279,8 +270,6 @@ proc unknown args {
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
@@ -300,9 +289,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]
@@ -393,7 +382,7 @@ proc auto_load {cmd {namespace {}}} {
proc auto_load_index {} {
variable ::tcl::auto_oldpath
- global auto_index auto_path errorInfo errorCode
+ global auto_index auto_path
if {[info exists auto_oldpath] && \
[string equal $auto_oldpath $auto_path]} {
@@ -431,12 +420,12 @@ proc auto_load_index {} {
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
- } msg]
+ } msg opts]
if {$f != ""} {
close $f
}
if {$error} {
- error $msg $errorInfo $errorCode
+ return -options $opts $msg
}
}
}
generated by cgit v0.12 at 2024-11-18 10:38:28 (GMT)