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  <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