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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
# This file contains support code for the Tcl test suite. It is
# normally sourced by the individual files in the test suite before
# they run their tests. This improved approach to testing was designed
# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
#
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) defs 1.7 94/12/17 15:53:52
package require Iwidgets
if ![info exists VERBOSE] {
set VERBOSE 0
}
if ![info exists DELAY] {
set DELAY 0
}
if ![info exists TESTS] {
set TESTS {}
}
# Some of the tests don't work on some system configurations due to
# configuration quirks, not due to Tk problems; in order to prevent
# false alarms, these tests are only run in the master development
# directory for Tk. The presence of a file "doAllTests" in this
# directory is used to indicate that these tests should be run.
set doNonPortableTests [file exists doAllTests]
proc print_verbose {test_name test_description contents_of_test code answer} {
puts stdout "\n"
puts stdout "==== $test_name $test_description"
puts stdout "==== Contents of test case:"
puts stdout "$contents_of_test"
if {$code != 0} {
if {$code == 1} {
puts stdout "==== Test generated error:"
puts stdout $answer
} elseif {$code == 2} {
puts stdout "==== Test generated return exception; result was:"
puts stdout $answer
} elseif {$code == 3} {
puts stdout "==== Test generated break exception"
} elseif {$code == 4} {
puts stdout "==== Test generated continue exception"
} else {
puts stdout "==== Test generated exception $code; message was:"
puts stdout $answer
}
} else {
puts stdout "==== Result was:"
puts stdout "$answer"
}
}
proc test {test_name test_description contents_of_test passing_results} {
global VERBOSE
global TESTS
global DELAY
if {[string compare $TESTS ""] != 0} then {
set ok 0
foreach test $TESTS {
if [string match $test $test_name] then {
set ok 1
break
}
}
if !$ok then return
}
set code [catch {uplevel $contents_of_test} answer]
if {$code != 0} {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
} elseif {[string compare $answer $passing_results] == 0} then {
if $VERBOSE then {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
puts stdout "++++ $test_name PASSED"
}
} else {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
puts stdout "---- Result should have been:"
puts stdout "$passing_results"
puts stdout "---- $test_name FAILED"
}
after $DELAY
}
#
# Like test, but does reg expr check on the results.
# Useful when the result must follow a pattern but some exact details
# are not necessary, like an internal number appended to a frame, etc.
#
proc test_pattern {test_name test_description contents_of_test passing_results} {
global VERBOSE
global TESTS
if {[string compare $TESTS ""] != 0} then {
set ok 0
foreach test $TESTS {
if [string match $test $test_name] then {
set ok 1
break
}
}
if !$ok then return
}
set code [catch {uplevel $contents_of_test} answer]
if {$code != 0} {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
} elseif {[regexp -- [lindex $passing_results 1] [lindex $answer 1]] == 1 } {
if $VERBOSE then {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
puts stdout "++++ $test_name PASSED"
}
} else {
print_verbose $test_name $test_description $contents_of_test \
$code $answer
puts stdout "---- Result should have been:"
puts stdout "$passing_results"
puts stdout "**** $test_name FAILED ****"
}
}
proc dotests {file args} {
global TESTS
set savedTests $TESTS
set TESTS $args
source $file
set TESTS $savedTests
}
# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.
if {![winfo ismapped .]} {
wm geometry . +0+0
update
}
# The following code can be used to perform tests involving a second
# process running in the background.
# Locate tktest executable
global argv0
if {0} {
puts "file executable $argv0...[file executable $argv0]"
if { [file executable $argv0] } {
if { [string index $argv0 0] == "/" } {
set tktest $argv0
} else {
set tktest "[pwd]/$argv0"
}
} elseif { [file executable ../$argv0] } {
set tktest "[pwd]/../$argv0"
} else {
set tktest {}
puts "Unable to find tktest executable, skipping multiple process tests."
}
} else {set tktest ../tktest}
# Create background process
proc setupbg {{args ""}} {
global tktest fd bgData
set fd [open "|$tktest -geometry +0+0 $args" r+]
puts $fd "puts foo; flush stdout"
flush $fd
gets $fd
fileevent $fd readable bgReady
}
# Send a command to the background process, catching errors and
# flushing I/O channels
proc dobg {command} {
global fd bgData bgDone
puts $fd "catch {$command} msg; update; puts \$msg; puts **DONE**; flush stdout"
flush $fd
set bgDone 0
set bgData {}
tkwait variable bgDone
set bgData
}
# Data arrived from background process. Check for special marker
# indicating end of data for this command, and make data available
# to dobg procedure.
proc bgReady {} {
global fd bgData bgDone
set x [gets $fd]
if [eof $fd] {
fileevent $fd readable {}
set bgDone 1
} elseif {$x == "**DONE**"} {
set bgDone 1
} else {
append bgData $x
}
}
# Exit the background process, and close the pipes
proc cleanupbg {} {
global fd
catch {
puts $fd "exit"
close $fd
}
}
|
