1 | # ---------------------------------------------------------------------- |
---|
2 | # COMPONENT: test - run a test and query the results |
---|
3 | # |
---|
4 | # Encapsulates the testing logic, to keep it isolated from the rest of |
---|
5 | # the tester GUI. Constructor requires the location of the tool.xml |
---|
6 | # for the new version, and the test xml file containing the golden set |
---|
7 | # of results. |
---|
8 | # ====================================================================== |
---|
9 | # AUTHOR: Ben Rafferty, Purdue University |
---|
10 | # Copyright (c) 2010 Purdue Research Foundation |
---|
11 | # |
---|
12 | # See the file "license.terms" for information on usage and |
---|
13 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
14 | # ====================================================================== |
---|
15 | |
---|
16 | namespace eval Rappture::Tester { #forward declaration } |
---|
17 | |
---|
18 | itcl::class Rappture::Tester::Test { |
---|
19 | public variable notifycommand "" |
---|
20 | |
---|
21 | constructor {tool testxml args} { #defined later } |
---|
22 | destructor { #defined later } |
---|
23 | |
---|
24 | public method getResult {} |
---|
25 | public method getTestInfo {args} |
---|
26 | public method getRunInfo {args} |
---|
27 | public method getDiffs {args} |
---|
28 | |
---|
29 | public method getTestobj {} |
---|
30 | public method getTestxml {} |
---|
31 | |
---|
32 | public method run {args} |
---|
33 | public method abort {} |
---|
34 | public method regoldenize {} |
---|
35 | |
---|
36 | private variable _toolobj "" ;# Rappture::Tool for tool being tested |
---|
37 | private variable _testxml "" ;# XML file for test case |
---|
38 | private variable _testobj "" ;# Rappture::Library object for _testxml |
---|
39 | |
---|
40 | private variable _result "?" ;# current status of this test |
---|
41 | private variable _runobj "" ;# results from last run |
---|
42 | private variable _diffs "" ;# diffs with respect to _runobj |
---|
43 | |
---|
44 | private method _setWaiting {{newval ""}} |
---|
45 | private method _setResult {name} |
---|
46 | private method _computeDiffs {obj1 obj2 args} |
---|
47 | private method _buildFailure {str} |
---|
48 | |
---|
49 | # use this to add tests to the "run" queue |
---|
50 | public proc queue {op args} |
---|
51 | |
---|
52 | # useful helper function -- looks for val among choices |
---|
53 | public proc oneof {choices val} { |
---|
54 | return [expr {[lsearch -exact $choices $val] >= 0}] |
---|
55 | } |
---|
56 | |
---|
57 | private common _queue ;# queue of objects waiting to run |
---|
58 | set _queue(tests) "" ;# list of tests in the queue |
---|
59 | set _queue(pending) "" ;# after event for "next" call |
---|
60 | set _queue(running) "" ;# test object currently running |
---|
61 | set _queue(outputcmd) "" ;# callback for reporting output |
---|
62 | } |
---|
63 | |
---|
64 | # ---------------------------------------------------------------------- |
---|
65 | # CONSTRUCTOR |
---|
66 | # ---------------------------------------------------------------------- |
---|
67 | itcl::body Rappture::Tester::Test::constructor {toolobj testxml args} { |
---|
68 | set _toolobj $toolobj |
---|
69 | set _testxml $testxml |
---|
70 | set _testobj [Rappture::library $testxml] |
---|
71 | |
---|
72 | eval configure $args |
---|
73 | } |
---|
74 | |
---|
75 | # ---------------------------------------------------------------------- |
---|
76 | # DESTRUCTOR |
---|
77 | # ---------------------------------------------------------------------- |
---|
78 | itcl::body Rappture::Tester::Test::destructor {} { |
---|
79 | itcl::delete object $_testobj |
---|
80 | # runobj can point to testobj if the test has just been |
---|
81 | # regoldenized. Don't try to delete twice. |
---|
82 | if {$_runobj ne "" && $_runobj ne $_testobj} { |
---|
83 | itcl::delete object $_runobj |
---|
84 | } |
---|
85 | } |
---|
86 | |
---|
87 | # ---------------------------------------------------------------------- |
---|
88 | # USAGE: getResult |
---|
89 | # |
---|
90 | # Returns the result of the test: |
---|
91 | # ? ...... test hasn't been run yet |
---|
92 | # Pass ... test ran recently and passed |
---|
93 | # Fail ... test ran recently and failed |
---|
94 | # Error ... test ran recently and run failed with an error |
---|
95 | # ---------------------------------------------------------------------- |
---|
96 | itcl::body Rappture::Tester::Test::getResult {} { |
---|
97 | return $_result |
---|
98 | } |
---|
99 | |
---|
100 | # ---------------------------------------------------------------------- |
---|
101 | # USAGE: getTestInfo <path> |
---|
102 | # USAGE: getTestInfo children <path> |
---|
103 | # USAGE: getTestInfo element ?-as type? <path> |
---|
104 | # |
---|
105 | # Returns info about the Test case at the specified <path> in the XML. |
---|
106 | # If the <path> is missing or misspelled, this method returns "" |
---|
107 | # instead of an error. |
---|
108 | # ---------------------------------------------------------------------- |
---|
109 | itcl::body Rappture::Tester::Test::getTestInfo {args} { |
---|
110 | if {[llength $args] == 1} { |
---|
111 | set path [lindex $args 0] |
---|
112 | return [$_testobj get $path] |
---|
113 | } |
---|
114 | return [eval $_testobj $args] |
---|
115 | } |
---|
116 | |
---|
117 | # ---------------------------------------------------------------------- |
---|
118 | # USAGE: getRunInfo <path> |
---|
119 | # USAGE: getRunInfo children <path> |
---|
120 | # USAGE: getRunInfo element ?-as type? <path> |
---|
121 | # |
---|
122 | # Returns info about the most recent run at the specified <path> in |
---|
123 | # the XML. If the <path> is missing or misspelled, this method returns |
---|
124 | # "" instead of an error. |
---|
125 | # ---------------------------------------------------------------------- |
---|
126 | itcl::body Rappture::Tester::Test::getRunInfo {args} { |
---|
127 | if {[llength $args] == 1} { |
---|
128 | set path [lindex $args 0] |
---|
129 | return [$_runobj get $path] |
---|
130 | } |
---|
131 | return [eval $_runobj $args] |
---|
132 | } |
---|
133 | |
---|
134 | # ---------------------------------------------------------------------- |
---|
135 | # USAGE: run ?-output callback path value path value ...? |
---|
136 | # |
---|
137 | # Kicks off a new simulation and checks the results against the golden |
---|
138 | # set of results. Any arguments passed in are passed along to the |
---|
139 | # Tool object managing the run. This may include parameter override |
---|
140 | # values and a callback for partial output. |
---|
141 | # ---------------------------------------------------------------------- |
---|
142 | itcl::body Rappture::Tester::Test::run {args} { |
---|
143 | # Delete existing library if rerun |
---|
144 | if {$_runobj ne ""} { |
---|
145 | itcl::delete object $_runobj |
---|
146 | set _runobj "" |
---|
147 | set _diffs "" |
---|
148 | } |
---|
149 | |
---|
150 | # copy inputs from the test into the run file |
---|
151 | $_toolobj reset |
---|
152 | foreach path [Rappture::entities -as path $_testobj input] { |
---|
153 | if {[$_testobj element -as type $path.current] ne ""} { |
---|
154 | lappend args $path [$_testobj get $path.current] |
---|
155 | } |
---|
156 | } |
---|
157 | |
---|
158 | # run the test case... |
---|
159 | _setResult "Running" |
---|
160 | foreach {status result} [eval $_toolobj run $args] break |
---|
161 | |
---|
162 | if {$status == 0} { |
---|
163 | if {$result eq "ABORT"} { |
---|
164 | _setResult "?" |
---|
165 | return "aborted" |
---|
166 | } elseif {[Rappture::library isvalid $result]} { |
---|
167 | set _runobj $result |
---|
168 | |
---|
169 | if {![oneof {0 ok} [$_testobj get output.status]]} { |
---|
170 | # expected test to fail, but it didn't |
---|
171 | set idiffs [_computeDiffs [$_toolobj xml object] $_runobj -in input] |
---|
172 | set odiffs [_computeDiffs $_testobj $_runobj -what run] |
---|
173 | set _diffs [concat $idiffs $odiffs] |
---|
174 | _setResult "Fail" |
---|
175 | } else { |
---|
176 | set idiffs [_computeDiffs [$_toolobj xml object] $_testobj -in input] |
---|
177 | set odiffs [_computeDiffs $_testobj $_runobj -in output] |
---|
178 | set _diffs [concat $idiffs $odiffs] |
---|
179 | |
---|
180 | # any differences from expected result mean test failed |
---|
181 | if {[llength $_diffs] == 0} { |
---|
182 | _setResult "Pass" |
---|
183 | } else { |
---|
184 | _setResult "Fail" |
---|
185 | } |
---|
186 | } |
---|
187 | return "finished" |
---|
188 | } else { |
---|
189 | set _runobj [_buildFailure $result] |
---|
190 | if {![oneof {0 ok} [$_testobj get output.status]] |
---|
191 | && [$_testobj get output.log] eq $result} { |
---|
192 | _setResult "Pass" |
---|
193 | } else { |
---|
194 | set idiffs [_computeDiffs [$_toolobj xml object] $_runobj -in input] |
---|
195 | set odiffs [_computeDiffs $_testobj $_runobj -what run] |
---|
196 | set _diffs [concat $idiffs $odiffs] |
---|
197 | _setResult "Fail" |
---|
198 | } |
---|
199 | return "finished" |
---|
200 | } |
---|
201 | } else { |
---|
202 | set _runobj [_buildFailure $result] |
---|
203 | if {![oneof {0 ok} [$_testobj get output.status]] |
---|
204 | && [$_testobj get output.log] eq $result} { |
---|
205 | _setResult "Pass" |
---|
206 | } else { |
---|
207 | set idiffs [_computeDiffs [$_toolobj xml object] $_runobj -in input] |
---|
208 | set odiffs [_computeDiffs $_testobj $_runobj -what run] |
---|
209 | set _diffs [concat $idiffs $odiffs] |
---|
210 | _setResult "Fail" |
---|
211 | } |
---|
212 | return "finished" |
---|
213 | } |
---|
214 | } |
---|
215 | |
---|
216 | # ---------------------------------------------------------------------- |
---|
217 | # USAGE: abort |
---|
218 | # |
---|
219 | # Causes the current test kicked off by the "run" method to be aborted. |
---|
220 | # ---------------------------------------------------------------------- |
---|
221 | itcl::body Rappture::Tester::Test::abort {} { |
---|
222 | $_toolobj abort |
---|
223 | } |
---|
224 | |
---|
225 | # ---------------------------------------------------------------------- |
---|
226 | # USAGE: regoldenize |
---|
227 | # |
---|
228 | # Regoldenize the test by overwriting the test xml containin the golden |
---|
229 | # results with the data in the runfile generated by the last run. Copy |
---|
230 | # test label and description into the new file. Update the test's |
---|
231 | # result attributes to reflect the changes. Throws an error if the test |
---|
232 | # has not been run. |
---|
233 | # |
---|
234 | # After regoldenizing, _testobj and _runobj will both refer to the same |
---|
235 | # library object, and the previous _runobj will be discarded. |
---|
236 | # ---------------------------------------------------------------------- |
---|
237 | itcl::body Rappture::Tester::Test::regoldenize {} { |
---|
238 | if {$_runobj eq ""} { |
---|
239 | error "no test result to goldenize" |
---|
240 | } |
---|
241 | $_runobj put test.label [$_testobj get test.label] |
---|
242 | $_runobj put test.description [$_testobj get test.description] |
---|
243 | |
---|
244 | set fid [open $_testxml w] |
---|
245 | puts $fid "<?xml version=\"1.0\"?>" |
---|
246 | puts $fid [$_runobj xml] |
---|
247 | close $fid |
---|
248 | |
---|
249 | itcl::delete object $_testobj |
---|
250 | set _testobj $_runobj |
---|
251 | set _runobj "" |
---|
252 | |
---|
253 | set _diffs "" |
---|
254 | _setResult Pass |
---|
255 | } |
---|
256 | |
---|
257 | # ---------------------------------------------------------------------- |
---|
258 | # USAGE: getDiffs ?<path>? |
---|
259 | # |
---|
260 | # With no extra args, this returns a list of paths that differ between |
---|
261 | # the golden and new results--either because the data values are |
---|
262 | # different, or because elements are missing or their attributes have |
---|
263 | # changed. |
---|
264 | # |
---|
265 | # If a particular <path> is specified, then detailed diffs are returned |
---|
266 | # for that path. This is useful for "structure" diffs, where many |
---|
267 | # things may be different within a single object. |
---|
268 | # ---------------------------------------------------------------------- |
---|
269 | itcl::body Rappture::Tester::Test::getDiffs {args} { |
---|
270 | if {[llength $args] == 0} { |
---|
271 | return $_diffs |
---|
272 | } elseif {[llength $args] != 1} { |
---|
273 | error "wrong # args: should be \"getDiffs ?path?\"" |
---|
274 | } |
---|
275 | |
---|
276 | set path [lindex $args 0] |
---|
277 | if {[string match input.* $path]} { |
---|
278 | # if we're matching input, compare the original XML vs. the test |
---|
279 | return [_computeDiffs [$_toolobj xml object] $_testobj -in $path -detail max] |
---|
280 | } |
---|
281 | |
---|
282 | # otherwise, compare the golden test vs. the test result |
---|
283 | return [_computeDiffs $_testobj $_runobj -in $path -detail max] |
---|
284 | } |
---|
285 | |
---|
286 | # ---------------------------------------------------------------------- |
---|
287 | # USAGE: getTestobj |
---|
288 | # |
---|
289 | # Returns a library object representing the test case. |
---|
290 | # ---------------------------------------------------------------------- |
---|
291 | itcl::body Rappture::Tester::Test::getTestobj {} { |
---|
292 | return $_testobj |
---|
293 | } |
---|
294 | |
---|
295 | # ---------------------------------------------------------------------- |
---|
296 | # USAGE: getTestxml |
---|
297 | # |
---|
298 | # Returns the name of the xml file representing the test case. |
---|
299 | # ---------------------------------------------------------------------- |
---|
300 | itcl::body Rappture::Tester::Test::getTestxml {} { |
---|
301 | return $_testxml |
---|
302 | } |
---|
303 | |
---|
304 | # ---------------------------------------------------------------------- |
---|
305 | # USAGE: _setResult ?|Pass|Fail|Waiting|Running |
---|
306 | # |
---|
307 | # Used internally to change the state of this test case. If there |
---|
308 | # is a -notifycommand script for this object, it is invoked to notify |
---|
309 | # an interested client that the object has changed. |
---|
310 | # ---------------------------------------------------------------------- |
---|
311 | itcl::body Rappture::Tester::Test::_setResult {name} { |
---|
312 | set _result $name |
---|
313 | if {[string length $notifycommand] > 0} { |
---|
314 | uplevel #0 $notifycommand $this |
---|
315 | } |
---|
316 | } |
---|
317 | |
---|
318 | # ---------------------------------------------------------------------- |
---|
319 | # USAGE: _setWaiting ?boolean? |
---|
320 | # |
---|
321 | # Used to mark a Test as "waiting". This usually happens when a test |
---|
322 | # is added to the queue, about to be run. |
---|
323 | # ---------------------------------------------------------------------- |
---|
324 | itcl::body Rappture::Tester::Test::_setWaiting {{newval ""}} { |
---|
325 | if {$newval ne "" && [string is boolean $newval]} { |
---|
326 | if {$newval} { |
---|
327 | _setResult "Waiting" |
---|
328 | } else { |
---|
329 | _setResult "?" |
---|
330 | } |
---|
331 | } |
---|
332 | return $_result |
---|
333 | } |
---|
334 | |
---|
335 | # ---------------------------------------------------------------------- |
---|
336 | # USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-in xxx? \ |
---|
337 | # ?-what value|attrs|run|all? ?-detail min|max? |
---|
338 | # |
---|
339 | # Used internally to compute differences between two different XML |
---|
340 | # objects. This is normally used to look for differences between an |
---|
341 | # entire test case and a new run, but can also be used to look at |
---|
342 | # differences within a particular section or element via the -in flag. |
---|
343 | # |
---|
344 | # Returns a list of the following form: |
---|
345 | # -what <diff> -path <path> -obj1 <xmlobj> -obj2 <xmlobj> \ |
---|
346 | # -v1 <value1> -v2 <value2> |
---|
347 | # |
---|
348 | # where <diff> is one of: |
---|
349 | # value - ....... element is missing from <xmlObj2> |
---|
350 | # value c ....... element changed between <xmlObj1> and <xmlObj2> |
---|
351 | # value + ....... element is missing from <xmlObj1> |
---|
352 | # attrs c ....... attributes are different <xmlObj1> and <xmlObj2> |
---|
353 | # type c ........ object types are different <xmlObj1> and <xmlObj2> |
---|
354 | # attr - <path>.. attribute at <path> is missing from <xmlObj2> |
---|
355 | # attr + <path>.. attribute at <path> is missing from <xmlObj1> |
---|
356 | # attr c <path>.. attribute at <path> changed between objects |
---|
357 | # ---------------------------------------------------------------------- |
---|
358 | itcl::body Rappture::Tester::Test::_computeDiffs {obj1 obj2 args} { |
---|
359 | Rappture::getopts args params { |
---|
360 | value -in output |
---|
361 | value -what "attrs value" |
---|
362 | value -detail min |
---|
363 | } |
---|
364 | if {$params(-what) == "all"} { |
---|
365 | set params(-what) "attrs value run" |
---|
366 | } |
---|
367 | |
---|
368 | # handle any run output diffs first, so they appear at the top |
---|
369 | # report this as one incident -- not separate reports for status/log |
---|
370 | set rlist "" |
---|
371 | if {[lsearch $params(-what) "run"] >= 0} { |
---|
372 | set st1 [$obj1 get output.status] |
---|
373 | set st2 [$obj2 get output.status] |
---|
374 | if {$st1 ne $st2} { |
---|
375 | # status changes are most serious |
---|
376 | lappend rlist [list -what status -path output.status \ |
---|
377 | -obj1 $obj1 -obj2 $obj2] |
---|
378 | } else { |
---|
379 | set log1 [$obj1 get output.log] |
---|
380 | set log2 [$obj2 get output.log] |
---|
381 | if {$log1 ne $log2} { |
---|
382 | # flag log changes instead if status agrees |
---|
383 | lappend rlist [list -what status -path output.log \ |
---|
384 | -obj1 $obj1 -obj2 $obj2] |
---|
385 | } |
---|
386 | } |
---|
387 | } |
---|
388 | |
---|
389 | # scan through the specified sections or paths |
---|
390 | foreach elem $params(-in) { |
---|
391 | if {[string first . $elem] >= 0} { |
---|
392 | set v1paths $elem |
---|
393 | set v2paths $elem |
---|
394 | } else { |
---|
395 | # query the values for all entities in both objects |
---|
396 | set v1paths [Rappture::entities $obj1 $elem] |
---|
397 | set v2paths [Rappture::entities $obj2 $elem] |
---|
398 | } |
---|
399 | |
---|
400 | # scan through values for obj1 and compare against obj2 |
---|
401 | foreach path $v1paths { |
---|
402 | set details [list -path $path -obj1 $obj1 -obj2 $obj2] |
---|
403 | |
---|
404 | set i [lsearch -exact $v2paths $path] |
---|
405 | if {$i < 0} { |
---|
406 | # missing from obj2 |
---|
407 | lappend rlist [linsert $details 0 -what "value -"] |
---|
408 | } else { |
---|
409 | foreach part $params(-what) { |
---|
410 | switch -- $part { |
---|
411 | value { |
---|
412 | set val1 [Rappture::objects::import $obj1 $path] |
---|
413 | set val2 [Rappture::objects::import $obj2 $path] |
---|
414 | lappend details -val1 $val1 -val2 $val2 |
---|
415 | |
---|
416 | if {$val1 eq "" || $val2 eq ""} { |
---|
417 | lappend rlist [linsert $details 0 -what "value c"] |
---|
418 | } elseif {[$val1 info class] != [$val2 info class]} { |
---|
419 | lappend rlist [linsert $details 0 -what "value c"] |
---|
420 | } elseif {[$val1 compare $val2] != 0} { |
---|
421 | lappend rlist [linsert $details 0 -what "value c"] |
---|
422 | } else { |
---|
423 | itcl::delete object $val1 $val2 |
---|
424 | } |
---|
425 | # handled this comparison |
---|
426 | set v2paths [lreplace $v2paths $i $i] |
---|
427 | } |
---|
428 | attrs { |
---|
429 | set what [list structure $path] |
---|
430 | set type1 [$obj1 element -as type $path] |
---|
431 | set type2 [$obj2 element -as type $path] |
---|
432 | if {$type1 eq $type2} { |
---|
433 | set same yes |
---|
434 | if {[catch {Rappture::objects::get $type1 -attributes} alist]} { |
---|
435 | # oops! unknown object type |
---|
436 | lappend rlist [linsert $details 0 -what unkobj] |
---|
437 | set alist "" |
---|
438 | } |
---|
439 | foreach rec $alist { |
---|
440 | array set attr [lrange $rec 1 end] |
---|
441 | set apath $path.$attr(-path) |
---|
442 | set v1 [$obj1 get $apath] |
---|
443 | set v2 [$obj2 get $apath] |
---|
444 | set dt [linsert $details end -v1 $v1 -v2 $v2] |
---|
445 | |
---|
446 | if {$v2 eq "" && $v1 ne ""} { |
---|
447 | # missing from obj2 |
---|
448 | if {$params(-detail) == "max"} { |
---|
449 | lappend rlist [linsert $dt 0 -what [list attr - $attr(-path)]] |
---|
450 | } else { |
---|
451 | set same no |
---|
452 | break |
---|
453 | } |
---|
454 | } elseif {$v1 eq "" && $v2 ne ""} { |
---|
455 | # missing from obj1 |
---|
456 | if {$params(-detail) == "max"} { |
---|
457 | lappend rlist [linsert $dt 0 -what [list attr + $attr(-path)]] |
---|
458 | } else { |
---|
459 | set same no |
---|
460 | break |
---|
461 | } |
---|
462 | } elseif {$v1 ne $v2} { |
---|
463 | # different from obj2 |
---|
464 | if {$params(-detail) == "max"} { |
---|
465 | lappend rlist [linsert $dt 0 -what [list attr c $attr(-path)]] |
---|
466 | } else { |
---|
467 | set same no |
---|
468 | break |
---|
469 | } |
---|
470 | } |
---|
471 | } |
---|
472 | if {$params(-detail) == "min" && !$same} { |
---|
473 | lappend details -what attrs |
---|
474 | lappend rlist [linsert $dt 0 -what "attrs c"] |
---|
475 | } |
---|
476 | } else { |
---|
477 | lappend details -val1 $type1 -val2 $type2 |
---|
478 | lappend rlist [linsert $details 0 -what "type c"] |
---|
479 | } |
---|
480 | } |
---|
481 | run { |
---|
482 | # do nothing -- already handled above |
---|
483 | |
---|
484 | # handled this comparison |
---|
485 | set v2paths [lreplace $v2paths $i $i] |
---|
486 | } |
---|
487 | default { |
---|
488 | error "bad part \"$part\": should be attrs, value, run" |
---|
489 | } |
---|
490 | } |
---|
491 | } |
---|
492 | } |
---|
493 | } |
---|
494 | |
---|
495 | # add any values left over in the obj2 |
---|
496 | foreach path $v2paths { |
---|
497 | set details [list -path $path -obj1 $obj1 -obj2 $obj2] |
---|
498 | lappend rlist [linsert $details 0 -what "value +"] |
---|
499 | } |
---|
500 | } |
---|
501 | return $rlist |
---|
502 | } |
---|
503 | |
---|
504 | # ---------------------------------------------------------------------- |
---|
505 | # USAGE: _buildFailure <output> |
---|
506 | # |
---|
507 | # Returns a new Rappture::library object that contains a copy of the |
---|
508 | # original test with the given <output> and a failing status. This |
---|
509 | # is used to represent the result of a test that aborts without |
---|
510 | # producing a valid run.xml file. |
---|
511 | # ---------------------------------------------------------------------- |
---|
512 | itcl::body Rappture::Tester::Test::_buildFailure {output} { |
---|
513 | set info "<?xml version=\"1.0\"?>\n[$_testobj xml]" |
---|
514 | set obj [Rappture::LibraryObj ::#auto $info] |
---|
515 | $obj remove test |
---|
516 | |
---|
517 | $obj put output.time [clock format [clock seconds]] |
---|
518 | $obj put output.status failed |
---|
519 | $obj put output.user $::tcl_platform(user) |
---|
520 | $obj put output.log $output |
---|
521 | |
---|
522 | return $obj |
---|
523 | } |
---|
524 | |
---|
525 | # ====================================================================== |
---|
526 | # RUN QUEUE |
---|
527 | # ====================================================================== |
---|
528 | # USAGE: queue add <testObj> <testObj>... |
---|
529 | # USAGE: queue clear ?<testObj> <testObj>...? |
---|
530 | # USAGE: queue status <command> |
---|
531 | # USAGE: queue next |
---|
532 | # USAGE: queue output <string> |
---|
533 | # |
---|
534 | # Used to manipulate the run queue for the program as a whole. |
---|
535 | # |
---|
536 | # The "queue add" option adds the given <testObj> objects to the run |
---|
537 | # queue. As soon as an object is added to the queue, it is marked |
---|
538 | # "waiting". When it runs, it is marked "running", and it finally |
---|
539 | # goes to the "pass" or "fail" state. If an object is already in |
---|
540 | # the queue, then this operation does nothing. |
---|
541 | # |
---|
542 | # The "queue clear" option clears specific objects from the queue. |
---|
543 | # If no objects are specified, then it clears all remaining objects. |
---|
544 | # |
---|
545 | # The "queue status" option is used to set the callback for handling |
---|
546 | # output from runs. This command is called two ways: |
---|
547 | # command start <testObj> |
---|
548 | # command add <testObj> "string of output" |
---|
549 | # |
---|
550 | # The "queue next" option is used internally to run the next object |
---|
551 | # in the queue. The "queue output" option is also used internally |
---|
552 | # to handle the output coming back from a run. The output gets |
---|
553 | # shuttled along to the callback specified by "queue status". |
---|
554 | # ---------------------------------------------------------------------- |
---|
555 | itcl::body Rappture::Tester::Test::queue {option args} { |
---|
556 | switch -- $option { |
---|
557 | add { |
---|
558 | # add these tests to the run queue |
---|
559 | foreach obj $args { |
---|
560 | if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} { |
---|
561 | error "bad value \"$obj\": should be Test object" |
---|
562 | } |
---|
563 | if {[lsearch $_queue(tests) $obj] < 0} { |
---|
564 | $obj _setWaiting 1 |
---|
565 | lappend _queue(tests) $obj |
---|
566 | } |
---|
567 | } |
---|
568 | if {$_queue(running) eq "" && $_queue(pending) eq ""} { |
---|
569 | set _queue(pending) [after idle \ |
---|
570 | Rappture::Tester::Test::queue next] |
---|
571 | } |
---|
572 | } |
---|
573 | clear { |
---|
574 | # remove these tests from the run queue |
---|
575 | foreach obj $args { |
---|
576 | if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} { |
---|
577 | error "bad value \"$obj\": should be Test object" |
---|
578 | } |
---|
579 | |
---|
580 | # remove the test from the queue |
---|
581 | set i [lsearch $_queue(tests) $obj] |
---|
582 | if {$i >= 0} { |
---|
583 | set _queue(tests) [lreplace $_queue(tests) $i $i] |
---|
584 | } |
---|
585 | |
---|
586 | # mark object as no longer "waiting" |
---|
587 | if {[$obj _setWaiting]} { |
---|
588 | $obj _setWaiting 0 |
---|
589 | } |
---|
590 | } |
---|
591 | } |
---|
592 | status { |
---|
593 | if {[llength $args] != 1} { |
---|
594 | error "wrong # args: should be \"status command\"" |
---|
595 | } |
---|
596 | set _queue(outputcmd) [lindex $args 0] |
---|
597 | } |
---|
598 | next { |
---|
599 | set _queue(pending) "" |
---|
600 | |
---|
601 | # get the next object from the queue |
---|
602 | set obj [lindex $_queue(tests) 0] |
---|
603 | set _queue(tests) [lrange $_queue(tests) 1 end] |
---|
604 | |
---|
605 | if {$obj ne ""} { |
---|
606 | set _queue(running) $obj |
---|
607 | # invoke the callback to signal start of a run |
---|
608 | if {[string length $_queue(outputcmd)] > 0} { |
---|
609 | uplevel #0 $_queue(outputcmd) start $obj |
---|
610 | } |
---|
611 | |
---|
612 | # run the test |
---|
613 | set callback "Rappture::Tester::Test::queue output" |
---|
614 | set status [$obj run -output $callback] |
---|
615 | set _queue(running) "" |
---|
616 | |
---|
617 | if {$status == "aborted"} { |
---|
618 | # if the test was aborted, clear any waiting tests |
---|
619 | Rappture::Tester::Test::queue clear |
---|
620 | } elseif {[string match failed:* $status]} { |
---|
621 | bgerror $status |
---|
622 | } |
---|
623 | |
---|
624 | # set up to run the next test in the queue |
---|
625 | set _queue(pending) [after idle \ |
---|
626 | Rappture::Tester::Test::queue next] |
---|
627 | } |
---|
628 | } |
---|
629 | output { |
---|
630 | if {[llength $args] != 1} { |
---|
631 | error "wrong # args: should be \"output string\"" |
---|
632 | } |
---|
633 | if {[string length $_queue(outputcmd)] > 0} { |
---|
634 | uplevel #0 $_queue(outputcmd) add $_queue(running) $args |
---|
635 | } |
---|
636 | } |
---|
637 | default { |
---|
638 | error "bad option \"$option\": should be add, clear, status, output, next" |
---|
639 | } |
---|
640 | } |
---|
641 | } |
---|