source: branches/blt4/tester/scripts/test.tcl @ 2168

Last change on this file since 2168 was 2168, checked in by gah, 11 years ago
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.