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

Last change on this file since 4965 was 3959, checked in by gah, 11 years ago

sync with trunk
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) 2004-2012  HUBzero Foundation, LLC
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    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# ----------------------------------------------------------------------
269itcl::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# ----------------------------------------------------------------------
291itcl::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# ----------------------------------------------------------------------
300itcl::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# ----------------------------------------------------------------------
311itcl::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# ----------------------------------------------------------------------
324itcl::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# ----------------------------------------------------------------------
358itcl::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# ----------------------------------------------------------------------
512itcl::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# ----------------------------------------------------------------------
555itcl::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}
Note: See TracBrowser for help on using the repository browser.