| 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 | |
|---|
| 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 | } |
|---|
