diff options
Diffstat (limited to 'lib/framework.exp')
| -rw-r--r-- | lib/framework.exp | 46 |
1 files changed, 26 insertions, 20 deletions
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 |