Use consistent behavior for Tcl errors in test scripts

5 files changed, 53 insertions, 26 deletions

diff --git a/ChangeLog b/ChangeLog
index f60a023..e9f1664 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,11 +3,22 @@
 	PR 41824 / PR 41918
 
 	Thanks to Tom de Vries for raising these concerns and offering the
-	initial patch that was rewritten to produce this.
+	initial testsuite patch that led to these changes.
+
+	* NEWS: Add item for consistent abort-on-error handling.
+
+	* lib/framework.exp (unknown): Always link global variables.  Tidy.
+	Silently propagate errors raised in autoloaded procedures and move
+	the UNRESOLVED result and aborting the test run to...
+	* runtest.exp (runtest): Report an UNRESOLVED result if a test
+	script aborts due to a Tcl error.  Link global errorCode and
+	report its value if an error occurs.  For consistency, abort the
+	test run on any Tcl error in a test script instead of only when
+	calling an undefined procedure.
 
 	* testsuite/runtest.main/abort.exp: Add tests to verify handling
 	of arithmetic errors (divide-by-zero) in an auto-loaded procedure
-	called from a test script.
+	called from a test script.  Adjust other patterns.
 
 	* testsuite/runtest.main/abort/testsuite/abort.test/abort-al-dbz.exp:
 	New file.
diff --git a/NEWS b/NEWS
index 4354422..619f0ff 100644
--- a/NEWS
+++ b/NEWS
@@ -9,6 +9,9 @@ Changes since 1.6.2:
    the default of reading "site.exp".  See the manual for details.
 X. runtest now accepts a --keep_going option to continue with other test
    scripts after a test script invokes an undefined command.
+X. Unless the --keep_going option is used, runtest now aborts if a test
+   script fails with any Tcl error.  Previously, only calling an undefined
+   procedure would cause the test run to abort.
 3. A utility procedure relative_filename has been added.  This procedure
    computes a relative file name to a given destination from a given base.
 4. The utility procedure 'grep' now accepts a '-n' option that
diff --git a/lib/framework.exp b/lib/framework.exp
index db6e661..0850595 100644
--- a/lib/framework.exp
+++ b/lib/framework.exp
@@ -258,36 +258,42 @@ proc isnative { } {
 
 rename ::unknown ::tcl_unknown
 proc unknown { args } {
+    global errorCode
+    global errorInfo
+    global exit_status
+
     set code [catch {uplevel 1 ::tcl_unknown $args} msg]
     if { $code != 0 } {
-	global errorCode
-	global errorInfo
-	global exit_status
-
 	set ret_cmd [list return -code $code]
 
-	clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
-	if {[info exists errorCode]} {
+	# If the command now exists, then it was autoloaded.  We are here,
+	# therefore invoking the autoloaded command raised an error.
+	# Silently propagate errors from autoloaded procedures, but
+	# complain noisily about undefined commands.
+	set have_it_now [llength [info commands [lindex $args 0]]]
+
+	if { ! $have_it_now } {
+	    clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
+	    set exit_status 2
+	}
+
+	if { [info exists errorCode] } {
 	    lappend ret_cmd -errorcode $errorCode
-	    send_error "The error code is $errorCode\n"
+	    if { ! $have_it_now } {
+		send_error "The error code is $errorCode\n"
+	    }
 	}
-	if {[info exists errorInfo]} {
-	    # omitting errorInfo from the propagated error makes this code
+	if { [info exists errorInfo] } {
+	    # omitting errorInfo from the propagated error makes this proc
 	    # invisible with the backtrace pointing directly to the problem
-	    send_error "The info on the error is:\n$errorInfo\n"
+	    if { ! $have_it_now } {
+		send_error "The info on the error is:\n$errorInfo\n"
+	    }
 	}
-	set exit_status 2
-
-	set unresolved_msg "testcase '[uplevel info script]' aborted"
-	append unresolved_msg " at call to unknown command '$args'"
-	unresolved $unresolved_msg
 
 	lappend ret_cmd $msg
-	if { $::dejagnu::opt::keep_going } {
-	    eval $ret_cmd
-	} else {
-	    log_and_exit
-	}
+
+	eval $ret_cmd
     } else {
 	# Propagate return value.
 	return $msg
diff --git a/runtest.exp b/runtest.exp
index 028ad5b..245c536 100644
--- a/runtest.exp
+++ b/runtest.exp
@@ -1562,6 +1562,7 @@ proc runtest { test_file_name } {
     global bug_id
     global test_result
     global errcnt
+    global errorCode
     global errorInfo
     global tool
     global testdir
@@ -1596,10 +1597,15 @@ proc runtest { test_file_name } {
 	    # increments `errcnt'.  If we do call perror we'd have to
 	    # reset errcnt afterwards.
 	    clone_output "ERROR: tcl error sourcing $test_file_name."
+	    if {[info exists errorCode]} {
+		clone_output "ERROR: tcl error code $errorCode"
+	    }
 	    if {[info exists errorInfo]} {
 		clone_output "ERROR: $errorInfo"
 		unset errorInfo
 	    }
+	    unresolved "testcase '$test_file_name' aborted due to Tcl error"
+	    if { ! $::dejagnu::opt::keep_going } { log_and_exit }
 	}
 
 	if {[info exists tool]} {
diff --git a/testsuite/runtest.main/abort.exp b/testsuite/runtest.main/abort.exp
index 864f1e0..b352b56 100644
--- a/testsuite/runtest.main/abort.exp
+++ b/testsuite/runtest.main/abort.exp
@@ -48,27 +48,28 @@ set tests {
     { "abort on undefined command"
 	"abort-undef.exp"
 	"PASS: running abort-undef.exp.*\
-	*UNRESOLVED: .* aborted at call to unknown command.*\
+	*UNRESOLVED: .* aborted.*\
 	*expected passes\[ \t\]+1\n.*unresolved testcases\[ \t\]+1\n" }
     { "stop at auto-loaded divide-by-zero without --keep_going"
 	"abort-al-dbz.exp simple.exp"
 	"PASS: running abort-al-dbz.exp.*\
-	*UNRESOLVED: .* aborted at .*\
+	*UNRESOLVED: .* aborted.*\
 	*expected passes\[ \t\]+1\n.*unresolved testcases\[ \t\]+1\n" }
     { "continue after auto-loaded divide-by-zero with --keep_going"
 	"--keep_going abort-al-dbz.exp simple.exp"
 	"PASS: running abort-al-dbz.exp.*\
+	*UNRESOLVED: .* aborted.*\
 	*PASS: simple test.*\
 	*expected passes\[ \t\]+2\n" }
     { "stop at abort without --keep_going"
 	"abort-undef.exp simple.exp"
 	"PASS: running abort-undef.exp.*\
-	*UNRESOLVED: .* aborted at call to unknown command.*\
+	*UNRESOLVED: .* aborted.*\
 	*expected passes\[ \t\]+1\n.*unresolved testcases\[ \t\]+1\n" }
     { "continue after abort with --keep_going"
 	"--keep_going abort-undef.exp simple.exp"
 	"PASS: running abort-undef.exp.*\
-	*UNRESOLVED: .* aborted at call to unknown command.*\
+	*UNRESOLVED: .* aborted.*\
 	*PASS: simple test.*\
 	*expected passes\[ \t\]+2\n.*unresolved testcases\[ \t\]+1\n" }
 }