diff options
-rw-r--r-- | ChangeLog | 9 | ||||
-rw-r--r-- | lib/framework.exp | 9 | ||||
-rw-r--r-- | runtest.exp | 18 |
3 files changed, 35 insertions, 1 deletions
@@ -1,3 +1,12 @@ +2020-06-26 Jacob Bachmeyer <jcb62281+dev@gmail.com> + + PR 41824 / PR 41918 + + * lib/framework.exp (log_and_exit): Print collected Tcl errors. + + * runtest.exp (dejagnu::error): New namespace. + (runtest): Collect Tcl errors caught while executing test scripts. + 2020-06-24 Jacob Bachmeyer <jcb62281+dev@gmail.com> PR 41824 / PR 41918 diff --git a/lib/framework.exp b/lib/framework.exp index 0850595..9cfff9d 100644 --- a/lib/framework.exp +++ b/lib/framework.exp @@ -381,6 +381,15 @@ proc log_and_exit {} { warning "${tool}_version failed:\n$output" } } + if {[llength $::dejagnu::error::list] > 0} { + # print errors again at end of output + foreach { cell } $::dejagnu::error::list { + clone_output "ERROR: in testcase [lindex $cell 0]" + clone_output "ERROR: [lindex $cell 1]" + clone_output "ERROR: tcl error code [lindex $cell 2]" + clone_output "ERROR: tcl error info:\n[lindex $cell 3]" + } + } close_logs verbose -log "runtest completed at [timestamp -format %c]" if {$mail_logs} { diff --git a/runtest.exp b/runtest.exp index 6f7e557..83c4140 100644 --- a/runtest.exp +++ b/runtest.exp @@ -104,6 +104,14 @@ namespace eval ::dejagnu::opt { variable keep_going 1 ;# continue after a fatal error in testcase? } +# +# Collected errors +# +namespace eval ::dejagnu::error { + # list of { file message errorCode errorInfo } lists + variable list [list] +} + # Various ccache versions provide incorrect debug info such as ignoring # different current directory, breaking GDB testsuite. set env(CCACHE_DISABLE) 1 @@ -1587,7 +1595,7 @@ proc runtest { test_file_name } { } } - if { [catch "uplevel #0 source $test_file_name"] == 1 } { + if { [catch "uplevel #0 source $test_file_name" msg] == 1 } { # If we have a Tcl error, propagate the exit status so # that 'make' (if it invokes runtest) notices the error. global exit_status exit_error @@ -1595,6 +1603,7 @@ proc runtest { test_file_name } { if { $exit_status == 0 } { set exit_status 2 } + set new_error [list $test_file_name $msg] # We can't call `perror' here, it resets `errorInfo' # before we want to look at it. Also remember that perror # increments `errcnt'. If we do call perror we'd have to @@ -1602,11 +1611,18 @@ proc runtest { test_file_name } { clone_output "ERROR: tcl error sourcing $test_file_name." if {[info exists errorCode]} { clone_output "ERROR: tcl error code $errorCode" + lappend new_error $errorCode + } else { + lappend new_error [list] } if {[info exists errorInfo]} { clone_output "ERROR: $errorInfo" + lappend new_error $errorInfo unset errorInfo + } else { + lappend new_error [list] } + lappend ::dejagnu::error::list $new_error unresolved "testcase '$test_file_name' aborted due to Tcl error" if { ! $::dejagnu::opt::keep_going } { log_and_exit } } |