# This file contains support code for the gdbtk test suite.
# Copyright 2001 Red Hat, Inc.
#
# Based on the Tcl testsuite support code, portions of this file
# are Copyright (c) 1990-1994 The Regents of the University of California and
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
global _test env srcdir objdir
if {![info exists srcdir]} {
if {[info exists env(SRCDIR)]} {
set srcdir $env(SRCDIR)
} else {
set srcdir .
}
}
if {![info exists objdir]} {
if {[info exists env(OBJDIR)]} {
set objdir $env(OBJDIR)
} elseif {$_test(interactive)} {
# If running interactively, assume that the objdir is
# relative to the executable's location
set objdir [file join [file dirname [info nameofexecutable]] testsuite gdb.gdbtk]
} else {
set objdir .
}
}
if {![info exists _test(verbose)]} {
if {[info exists env(GDBTK_VERBOSE)]} {
set _test(verbose) $env(GDBTK_VERBOSE)
} else {
set _test(verbose) 0
}
}
if {![info exists _test(tests)]} {
if {[info exists env(GDBTK_TESTS)]} {
set _test(tests) $env(GDBTK_TESTS)
} else {
set _test(tests) {}
}
}
if {[info exists env(GDBTK_LOGFILE)]} {
set _test(logfile) [open $env(GDBTK_LOGFILE) a+]
fconfigure $_test(logfile) -buffering none
} else {
set _test(logfile) {}
}
# Informs gdbtk internals that testsuite is running. An example
# where this is needed is the window manager, which must place
# all windows at some place on the screen so that the system's
# window manager does not interfere. This is reset in gdbtk_test_done.
set env(GDBTK_TEST_RUNNING) 1
# The gdb "file" command to use for gdbtk testing
# NOTE: This proc appends ".exe" to all windows' programs
proc gdbtk_test_file {filename} {
global tcl_platform
if {$tcl_platform(platform) == "windows"} {
append filename ".exe"
}
set err [catch {gdb_cmd "file $filename" 1} text]
if {$err} {
error $text
}
return $text
}
proc gdbtk_test_run {{prog_args {}}} {
global env
# Get the target_info array from the testsuite
array set target_info $env(TARGET_INFO)
# We get the target ready by:
# 1. Run all init commands
# 2. Issue target command
# 3. Issue load command
# 4. Issue run command
foreach cmd $target_info(init) {
set err [catch {gdb_cmd $cmd 0} txt]
if {$err} {
_report_error "Target initialization command \"$cmd\" failed: $txt"
return 0
}
}
if {$target_info(target) != ""} {
set err [catch {gdb_cmd $target_info(target) 0} txt]
if {$err} {
_report_error "Failed to connect to target: $txt"
return 0
}
}
if {$target_info(load) != ""} {
set err [catch {gdb_cmd $target_info(load) 0} txt]
if {$err} {
_report_error "Failed to load: $txt"
return 0
}
}
if {$target_info(run) != ""} {
set err [catch {gdb_cmd $target_info(run) 0} txt]
if {$err} {
_report_error "Could not run target with \"$target_info(run)\": $txt"
return 0
}
}
return 1
}
proc _report_error {msg} {
global _test
if {[info exists _test(interactive)] && $_test(interactive)} {
# Dialog
tk_messageBox -message $msg -icon error -type ok
} else {
# to stderr
puts stderr $msg
}
}
proc gdbtk_print_verbose {status name description script code answer} {
global _test
switch $code {
0 {
set code_words {}
}
1 {
set code_words "Test generated error: $answer"
}
2 {
set code_words "Test generated return exception; result was: $answer"
}
3 {
set code_words "Test generated break exception"
}
4 {
set code_words "Test generated continue exception"
}
5 {
set code_words "Test generated exception $code; message was:$answer"
}
}
if {$_test(verbose) > 1 \
|| ($_test(verbose) != 1 && ($status == "ERROR" || $status == "FAIL"))} {
# Printed when user verbose mode (verbose > 1) or an error/failure occurs
# not running the testsuite (dejagnu)
puts stdout "\n"
puts stdout "==== $name $description"
puts stdout "==== Contents of test case:"
puts stdout "$script"
if {$code_words != ""} {
puts stdout $code_words
}
puts stdout "==== Result was:"
puts stdout "$answer"
} elseif {$_test(verbose)} {
# Printed for the testsuite (verbose = 1)
puts stdout "[list $status $name $description $code_words]"
if {$_test(logfile) != ""} {
puts $_test(logfile) "\n"
puts $_test(logfile) "==== $name $description"
puts $_test(logfile) "==== Contents of test case:"
puts $_test(logfile) "$script"
if {$code_words != ""} {
puts $_test(logfile) $code_words
}
puts $_test(logfile) "==== Result was:"
puts $_test(logfile) "$answer"
}
}
}
# gdbtk_test
#
# This procedure runs a test and prints an error message if the
# test fails.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
# description - Short textual description of the test, to
# help humans understand what it does.
# script - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness.
# answer - Expected result from script.
proc gdbtk_test {name description script answer} {
global _test test_ran
set test_ran 0
if {[string compare $_test(tests) ""] != 0} then {
set ok 0
foreach test $_test(tests) {
if [string match $test $name] then {
set ok 1
break
}
}
if !$ok then return
}
set code [catch {uplevel $script} result]
set test_ran 1
if {$code != 0} {
# Error
gdbtk_print_verbose ERROR $name $description $script \
$code $result
} elseif {[string compare $result $answer] == 0} {
if {[string index $name 0] == "*"} {
# XPASS
set HOW XPASS
} else {
set HOW PASS
}
if {$_test(verbose)} {
gdbtk_print_verbose $HOW $name $description $script \
$code $result
if {$_test(verbose) != 1} {
puts stdout "++++ $name ${HOW}ED"
}
}
if {$_test(logfile) != ""} {
puts $_test(logfile) "++++ $name ${HOW}ED"
}
} else {
if {[string index $name 0] == "*"} {
# XFAIL
set HOW XFAIL
} else {
set HOW FAIL
}
gdbtk_print_verbose $HOW $name $description $script \
$code $result
if {$_test(verbose) != 1} {
puts stdout "---- Result should have been:"
puts stdout "$answer"
puts stdout "---- $name ${HOW}ED"
}
if {$_test(logfile) != ""} {
puts $_test(logfile) "---- Result should have been:"
puts $_test(logfile) "$answer"
puts $_test(logfile) "---- $name ${HOW}ED"
}
}
}
proc gdbtk_dotests {file args} {
global _test
set savedTests $_test(tests)
set _test(tests) $args
source $file
set _test(tests) $savedTests
}
proc gdbtk_test_done {} {
global _test env
if {$_test(logfile) != ""} {
close $_test(logfile)
}
set env(GDBTK_TEST_RUNNING) 0
if {![info exists _test(interactive)] || !$_test(interactive)} {
gdbtk_force_quit
}
}
proc gdbtk_test_error {desc} {
set desc [join [split $desc \n] |]
puts "ERROR \{$desc\} \{\} \{\}"
gdbtk_test_done
}
# Override the warning dialog. We don't want to see them.
rename show_warning real_show_warning
proc show_warning {msg} {
global _test
set str "INSIGHT TESTSUITE WARNING: $msg"
puts stdout $str
if {$_test(logfile) != ""} {
puts $_test(logfile) $str
}
}