blob: 7916104f7c75061555ea3238586d23d64627d691 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
# This file contains support code for the gdbtk test suite.
#
# 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 srcdir _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)
}
}
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
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:\n$answer"
}
2 {
set code_words "Test generated return exception; result was:\n$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:\n$answer"
}
}
debug "gdbtk_test_verbose: _test(verbose)=$_test(verbose) status=$status"
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} {
# PASS
if {$_test(verbose)} {
gdbtk_print_verbose pass $name $description $script \
$code $result
if {$_test(verbose) != 1} {
puts stdout "++++ $name PASSED"
}
}
if {$_test(logfile) != ""} {
puts $_test(logfile) "++++ $name PASSED"
}
} else {
# FAIL
gdbtk_print_verbose fail $name $description $script \
$code $result
if {$_test(verbose) != 1} {
puts stdout "---- Result should have been:"
puts stdout "$answer"
puts stdout "---- $name FAILED"
}
if {$_test(logfile) != ""} {
puts $_test(logfile) "---- Result should have been:"
puts $_test(logfile) "$answer"
puts $_test(logfile) "---- $name FAILED"
}
}
}
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)} {
gdb_force_quit
}
}
|
