diff options
Diffstat (limited to 'gdb/testsuite/gdb.gdbtk/defs')
-rw-r--r-- | gdb/testsuite/gdb.gdbtk/defs | 306 |
1 files changed, 0 insertions, 306 deletions
diff --git a/gdb/testsuite/gdb.gdbtk/defs b/gdb/testsuite/gdb.gdbtk/defs deleted file mode 100644 index 8e3fe5b4531..00000000000 --- a/gdb/testsuite/gdb.gdbtk/defs +++ /dev/null @@ -1,306 +0,0 @@ -# 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 - } -} |