--- Begin Message ---
|
Subject: |
[PATCH] Propagate error value of auto-loaded command |
|
Date: |
Wed, 17 Jun 2020 14:34:14 +0200 |
|
User-agent: |
Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.9.0 |
Hi,
I think I found a bug in proc unknown in lib/framework.exp.
Patch describing the problem and fixing it attached below.
Thanks,
- Tom
Propagate error value of auto-loaded command
Consider a library file foo.tcl:
...
proc foo { } {
throw {ARITH DIVZERO {divide by zero}} {divide by zero}
}
...
and a test-case test.tcl:
...
\#!/usr/bin/tclsh
auto_mkindex lib *.tcl
lappend auto_path [pwd]/lib
foo
...
which gives us:
...
divide by zero
while executing
"throw {ARITH DIVZERO {divide by zero}} {divide by zero}"
(procedure "foo" line 2)
invoked from within
"foo"
(file "./test.tcl" line 7)
...
When overriding the ::unknown command using:
...
rename ::unknown ::tcl_unknown
proc unknown args {
if {[catch {uplevel 1 ::tcl_unknown $args} msg]} {
puts "ERROR: proc \"$args\" does not exist: $msg"
exit
} else {
return $msg
}
}
...
we have instead:
...
$ ./test.tcl
ERROR: proc "foo" does not exist: divide by zero
...
This can be fixed by testing for the specific error code, and otherwise
propagating the error:
...
proc unknown args {
set code [catch {uplevel 1 ::tcl_unknown $args} msg]
if { $code == 1 } {
global errorInfo errorCode
if { [lindex errorCode 0] eq "TCL"
&& [lindex errorCode 1] eq "LOOKUP"
&& [lindex errorCode 2] eq "COMMAND"
&& [lindex errorCode 3] eq [lindex $args 0] } {
puts "ERROR: proc \"$args\" does not exist: $msg"
exit
}
return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
}
return -code $code $msg
}
...
Fix unknown in lib/framework.exp accordingly.
ChangeLog:
2020-06-17 Tom de Vries <tdevries@suse.de>
* lib/framework.exp (unknown): Propagate error value of auto-loaded
command.
---
lib/framework.exp | 34 +++++++++++++++++++++-------------
1 file changed, 21 insertions(+), 13 deletions(-)
diff --git a/lib/framework.exp b/lib/framework.exp
index c9875d2..1347cc1 100644
--- a/lib/framework.exp
+++ b/lib/framework.exp
@@ -258,24 +258,32 @@ proc isnative { } {
rename ::unknown ::tcl_unknown
proc unknown args {
- if {[catch {uplevel 1 ::tcl_unknown $args} msg]} {
+ set code [catch {uplevel 1 ::tcl_unknown $args} msg]
+ if { $code == 1 } {
global errorCode
global errorInfo
global exit_status
-
- clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
- if {[info exists errorCode]} {
- send_error "The error code is $errorCode\n"
- }
- if {[info exists errorInfo]} {
- send_error "The info on the error is:\n$errorInfo\n"
+ if { [lindex errorCode 0] eq "TCL"
+ && [lindex errorCode 1] eq "LOOKUP"
+ && [lindex errorCode 2] eq "COMMAND"
+ && [lindex errorCode 3] eq [lindex $args 0] } {
+ clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
+ if {[info exists errorCode]} {
+ send_error "The error code is $errorCode\n"
+ }
+ if {[info exists errorInfo]} {
+ send_error "The info on the error is:\n$errorInfo\n"
+ }
+ set exit_status 2
+ log_and_exit
}
- set exit_status 2
- log_and_exit
- } else {
- # Propagate return value.
- return $msg
+
+ # Propagate error
+ return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
}
+
+ # Propagate return value.
+ return -code $code $msg
}
# Print output to stdout (or stderr) and to log file
--- End Message ---