From d45310cd257d399b8208fa9907f7c9f2f4ac7eda Mon Sep 17 00:00:00 2001 From: Jacob Bachmeyer Date: Thu, 18 Jun 2020 18:52:33 -0500 Subject: Use consistent behavior for Tcl errors in test scripts --- ChangeLog | 15 +++++++++++-- NEWS | 3 +++ lib/framework.exp | 46 +++++++++++++++++++++++----------------- runtest.exp | 6 ++++++ testsuite/runtest.main/abort.exp | 9 ++++---- 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" } } -- cgit v1.1