source: trunk/tester/scripts/test.tcl @ 2163

Last change on this file since 2163 was 2163, checked in by mmc, 11 years ago

Fix for the tester to work better with the various language bindings
that return "0" instead of "ok" and "1" instead of "failure". The
tester now treats anything other than 0/ok as failure.

File size: 24.7 KB
Line 
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
16namespace eval Rappture::Tester { #forward declaration }
17
18itcl::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# ----------------------------------------------------------------------
67itcl::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# ----------------------------------------------------------------------
78itcl::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# ----------------------------------------------------------------------
96itcl::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# ----------------------------------------------------------------------
109itcl::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# ----------------------------------------------------------------------
126itcl::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# ----------------------------------------------------------------------
142itcl::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# ----------------------------------------------------------------------
221itcl::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# ----------------------------------------------------------------------
237itcl::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
252    set _diffs ""
253    _setResult Pass
254}
255
256# ----------------------------------------------------------------------
257# USAGE: getDiffs ?<path>?
258#
259# With no extra args, this returns a list of paths that differ between
260# the golden and new results--either because the data values are
261# different, or because elements are missing or their attributes have
262# changed.
263#
264# If a particular <path> is specified, then detailed diffs are returned
265# for that path.  This is useful for "structure" diffs, where many
266# things may be different within a single object.
267# ----------------------------------------------------------------------
268itcl::body Rappture::Tester::Test::getDiffs {args} {
269    if {[llength $args] == 0} {
270        return $_diffs
271    } elseif {[llength $args] != 1} {
272        error "wrong # args: should be \"getDiffs ?path?\""
273    }
274
275    set path [lindex $args 0]
276    if {[string match input.* $path]} {
277        # if we're matching input, compare the original XML vs. the test
278        return [_computeDiffs [$_toolobj xml object] $_testobj -in $path -detail max]
279    }
280
281    # otherwise, compare the golden test vs. the test result
282    return [_computeDiffs $_testobj $_runobj -in $path -detail max]
283}
284
285# ----------------------------------------------------------------------
286# USAGE: getTestobj
287#
288# Returns a library object representing the test case.
289# ----------------------------------------------------------------------
290itcl::body Rappture::Tester::Test::getTestobj {} {
291    return $_testobj
292}
293
294# ----------------------------------------------------------------------
295# USAGE: getTestxml
296#
297# Returns the name of the xml file representing the test case.
298# ----------------------------------------------------------------------
299itcl::body Rappture::Tester::Test::getTestxml {} {
300    return $_testxml
301}
302
303# ----------------------------------------------------------------------
304# USAGE: _setResult ?|Pass|Fail|Waiting|Running
305#
306# Used internally to change the state of this test case.  If there
307# is a -notifycommand script for this object, it is invoked to notify
308# an interested client that the object has changed.
309# ----------------------------------------------------------------------
310itcl::body Rappture::Tester::Test::_setResult {name} {
311    set _result $name
312    if {[string length $notifycommand] > 0} {
313        uplevel #0 $notifycommand $this
314    }
315}
316
317# ----------------------------------------------------------------------
318# USAGE: _setWaiting ?boolean?
319#
320# Used to mark a Test as "waiting".  This usually happens when a test
321# is added to the queue, about to be run.
322# ----------------------------------------------------------------------
323itcl::body Rappture::Tester::Test::_setWaiting {{newval ""}} {
324    if {$newval ne "" && [string is boolean $newval]} {
325        if {$newval} {
326            _setResult "Waiting"
327        } else {
328            _setResult "?"
329        }
330    }
331    return $_result
332}
333
334# ----------------------------------------------------------------------
335# USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-in xxx? \
336#            ?-what value|attrs|run|all? ?-detail min|max?
337#
338# Used internally to compute differences between two different XML
339# objects.  This is normally used to look for differences between an
340# entire test case and a new run, but can also be used to look at
341# differences within a particular section or element via the -in flag.
342#
343# Returns a list of the following form:
344#     -what <diff> -path <path> -obj1 <xmlobj> -obj2 <xmlobj> \
345#           -v1 <value1> -v2 <value2>
346#
347#       where <diff> is one of:
348#         value - ....... element is missing from <xmlObj2>
349#         value c ....... element changed between <xmlObj1> and <xmlObj2>
350#         value + ....... element is missing from <xmlObj1>
351#         attrs c ....... attributes are different <xmlObj1> and <xmlObj2>
352#         type c ........ object types are different <xmlObj1> and <xmlObj2>
353#         attr - <path>.. attribute at <path> is missing from <xmlObj2>
354#         attr + <path>.. attribute at <path> is missing from <xmlObj1>
355#         attr c <path>.. attribute at <path> changed between objects
356# ----------------------------------------------------------------------
357itcl::body Rappture::Tester::Test::_computeDiffs {obj1 obj2 args} {
358    Rappture::getopts args params {
359        value -in output
360        value -what "attrs value"
361        value -detail min
362    }
363    if {$params(-what) == "all"} {
364        set params(-what) "attrs value run"
365    }
366
367    # handle any run output diffs first, so they appear at the top
368    # report this as one incident -- not separate reports for status/log
369    set rlist ""
370    if {[lsearch $params(-what) "run"] >= 0} {
371        set st1 [$obj1 get output.status]
372        set st2 [$obj2 get output.status]
373        if {$st1 ne $st2} {
374            # status changes are most serious
375            lappend rlist [list -what status -path output.status \
376                -obj1 $obj1 -obj2 $obj2]
377        } else {
378            set log1 [$obj1 get output.log]
379            set log2 [$obj2 get output.log]
380            if {$log1 ne $log2} {
381                # flag log changes instead if status agrees
382                lappend rlist [list -what status -path output.log \
383                    -obj1 $obj1 -obj2 $obj2]
384            }
385        }
386    }
387
388    # scan through the specified sections or paths
389    foreach elem $params(-in) {
390        if {[string first . $elem] >= 0} {
391            set v1paths $elem
392            set v2paths $elem
393        } else {
394            # query the values for all entities in both objects
395            set v1paths [Rappture::entities $obj1 $elem]
396            set v2paths [Rappture::entities $obj2 $elem]
397        }
398
399        # scan through values for obj1 and compare against obj2
400        foreach path $v1paths {
401            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
402
403            set i [lsearch -exact $v2paths $path]
404            if {$i < 0} {
405                # missing from obj2
406                lappend rlist [linsert $details 0 -what "value -"]
407            } else {
408                foreach part $params(-what) {
409                    switch -- $part {
410                      value {
411                        set val1 [Rappture::objects::import $obj1 $path]
412                        set val2 [Rappture::objects::import $obj2 $path]
413                        lappend details -val1 $val1 -val2 $val2
414
415                        if {$val1 eq "" || $val2 eq ""} {
416                            lappend rlist [linsert $details 0 -what "value c"]
417                        } elseif {[$val1 info class] != [$val2 info class]} {
418                            lappend rlist [linsert $details 0 -what "value c"]
419                        } elseif {[$val1 compare $val2] != 0} {
420                            lappend rlist [linsert $details 0 -what "value c"]
421                        } else {
422                            itcl::delete object $val1 $val2
423                        }
424                        # handled this comparison
425                        set v2paths [lreplace $v2paths $i $i]
426                      }
427                      attrs {
428                        set what [list structure $path]
429                        set type1 [$obj1 element -as type $path]
430                        set type2 [$obj2 element -as type $path]
431                        if {$type1 eq $type2} {
432                          set same yes
433                          if {[catch {Rappture::objects::get $type1 -attributes} alist]} {
434                              # oops! unknown object type
435                              lappend rlist [linsert $details 0 -what unkobj]
436                              set alist ""
437                          }
438                          foreach rec $alist {
439                              array set attr [lrange $rec 1 end]
440                              set apath $path.$attr(-path)
441                              set v1 [$obj1 get $apath]
442                              set v2 [$obj2 get $apath]
443                              set dt [linsert $details end -v1 $v1 -v2 $v2]
444
445                              if {$v2 eq "" && $v1 ne ""} {
446                                  # missing from obj2
447                                  if {$params(-detail) == "max"} {
448                                      lappend rlist [linsert $dt 0 -what [list attr - $attr(-path)]]
449                                  } else {
450                                      set same no
451                                      break
452                                  }
453                              } elseif {$v1 eq "" && $v2 ne ""} {
454                                  # missing from obj1
455                                  if {$params(-detail) == "max"} {
456                                      lappend rlist [linsert $dt 0 -what [list attr + $attr(-path)]]
457                                  } else {
458                                      set same no
459                                      break
460                                  }
461                              } elseif {$v1 ne $v2} {
462                                  # different from obj2
463                                  if {$params(-detail) == "max"} {
464                                      lappend rlist [linsert $dt 0 -what [list attr c $attr(-path)]]
465                                  } else {
466                                      set same no
467                                      break
468                                  }
469                              }
470                          }
471                          if {$params(-detail) == "min" && !$same} {
472                              lappend details -what attrs
473                              lappend rlist [linsert $dt 0 -what "attrs c"]
474                          }
475                        } else {
476                          lappend details -val1 $type1 -val2 $type2
477                          lappend rlist [linsert $details 0 -what "type c"]
478                        }
479                      }
480                      run {
481                        # do nothing -- already handled above
482
483                        # handled this comparison
484                        set v2paths [lreplace $v2paths $i $i]
485                      }
486                      default {
487                        error "bad part \"$part\": should be attrs, value, run"
488                      }
489                    }
490                }
491            }
492        }
493
494        # add any values left over in the obj2
495        foreach path $v2paths {
496            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
497            lappend rlist [linsert $details 0 -what "value +"]
498        }
499    }
500    return $rlist
501}
502
503# ----------------------------------------------------------------------
504# USAGE: _buildFailure <output>
505#
506# Returns a new Rappture::library object that contains a copy of the
507# original test with the given <output> and a failing status.  This
508# is used to represent the result of a test that aborts without
509# producing a valid run.xml file.
510# ----------------------------------------------------------------------
511itcl::body Rappture::Tester::Test::_buildFailure {output} {
512    set info "<?xml version=\"1.0\"?>\n[$_testobj xml]"
513    set obj [Rappture::LibraryObj ::#auto $info]
514    $obj remove test
515
516    $obj put output.time [clock format [clock seconds]]
517    $obj put output.status failed
518    $obj put output.user $::tcl_platform(user)
519    $obj put output.log $output
520
521    return $obj
522}
523
524# ======================================================================
525# RUN QUEUE
526# ======================================================================
527# USAGE: queue add <testObj> <testObj>...
528# USAGE: queue clear ?<testObj> <testObj>...?
529# USAGE: queue status <command>
530# USAGE: queue next
531# USAGE: queue output <string>
532#
533# Used to manipulate the run queue for the program as a whole.
534#
535# The "queue add" option adds the given <testObj> objects to the run
536# queue.  As soon as an object is added to the queue, it is marked
537# "waiting".  When it runs, it is marked "running", and it finally
538# goes to the "pass" or "fail" state.  If an object is already in
539# the queue, then this operation does nothing.
540#
541# The "queue clear" option clears specific objects from the queue.
542# If no objects are specified, then it clears all remaining objects.
543#
544# The "queue status" option is used to set the callback for handling
545# output from runs.  This command is called two ways:
546#    command start <testObj>
547#    command add <testObj> "string of output"
548#
549# The "queue next" option is used internally to run the next object
550# in the queue.  The "queue output" option is also used internally
551# to handle the output coming back from a run.  The output gets
552# shuttled along to the callback specified by "queue status".
553# ----------------------------------------------------------------------
554itcl::body Rappture::Tester::Test::queue {option args} {
555    switch -- $option {
556        add {
557            # add these tests to the run queue
558            foreach obj $args {
559                if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
560                    error "bad value \"$obj\": should be Test object"
561                }
562                if {[lsearch $_queue(tests) $obj] < 0} {
563                    $obj _setWaiting 1
564                    lappend _queue(tests) $obj
565                }
566            }
567            if {$_queue(running) eq "" && $_queue(pending) eq ""} {
568                set _queue(pending) [after idle \
569                    Rappture::Tester::Test::queue next]
570            }
571        }
572        clear {
573            # remove these tests from the run queue
574            foreach obj $args {
575                if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
576                    error "bad value \"$obj\": should be Test object"
577                }
578
579                # remove the test from the queue
580                set i [lsearch $_queue(tests) $obj]
581                if {$i >= 0} {
582                    set _queue(tests) [lreplace $_queue(tests) $i $i]
583                }
584
585                # mark object as no longer "waiting"
586                if {[$obj _setWaiting]} {
587                    $obj _setWaiting 0
588                }
589            }
590        }
591        status {
592            if {[llength $args] != 1} {
593                error "wrong # args: should be \"status command\""
594            }
595            set _queue(outputcmd) [lindex $args 0]
596        }
597        next {
598            set _queue(pending) ""
599
600            # get the next object from the queue
601            set obj [lindex $_queue(tests) 0]
602            set _queue(tests) [lrange $_queue(tests) 1 end]
603
604            if {$obj ne ""} {
605                set _queue(running) $obj
606                # invoke the callback to signal start of a run
607                if {[string length $_queue(outputcmd)] > 0} {
608                    uplevel #0 $_queue(outputcmd) start $obj
609                }
610
611                # run the test
612                set callback "Rappture::Tester::Test::queue output"
613                set status [$obj run -output $callback]
614                set _queue(running) ""
615
616                if {$status == "aborted"} {
617                    # if the test was aborted, clear any waiting tests
618                    Rappture::Tester::Test::queue clear
619                } elseif {[string match failed:* $status]} {
620                    bgerror $status
621                }
622
623                # set up to run the next test in the queue
624                set _queue(pending) [after idle \
625                    Rappture::Tester::Test::queue next]
626            }
627        }
628        output {
629            if {[llength $args] != 1} {
630                error "wrong # args: should be \"output string\""
631            }
632            if {[string length $_queue(outputcmd)] > 0} {
633                uplevel #0 $_queue(outputcmd) add $_queue(running) $args
634            }
635        }
636        default {
637            error "bad option \"$option\": should be add, clear, status, output, next"
638        }
639    }
640}
Note: See TracBrowser for help on using the repository browser.