bug#41918: [PATCH] Propagate error value of auto-loaded command

[Tom de Vries]

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  <tdevr...@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

_______________________________________________
Bug-dejagnu mailing list
Bug-dejagnu@gnu.org
https://lists.gnu.org/mailman/listinfo/bug-dejagnu