| # 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 |
| } |
| } |