summaryrefslogtreecommitdiff
path: root/gdb/testsuite/gdb.gdbtk/defs
diff options
context:
space:
mode:
Diffstat (limited to 'gdb/testsuite/gdb.gdbtk/defs')
-rw-r--r--gdb/testsuite/gdb.gdbtk/defs306
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
- }
-}
View Lorry Controller Status