1# -*- tcl -*- 2# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> 3## 4# ### 5 6package require sak::test::shell 7package require sak::registry 8package require sak::animate 9package require sak::color 10# TODO: Rework this package to use the sak::feedback package 11 12getpackage textutil::repeat textutil/repeat.tcl 13getpackage fileutil fileutil/fileutil.tcl 14getpackage struct::matrix struct/matrix.tcl 15 16namespace eval ::sak::test::run { 17 namespace import ::textutil::repeat::blank 18 namespace import ::sak::color::* 19} 20 21# ### 22 23proc ::sak::test::run {argv} { 24 variable run::valgrind 25 array set config { 26 valgrind 0 raw 0 shells {} stem {} log 0 27 } 28 29 while {[string match -* [set opt [lindex $argv 0]]]} { 30 switch -exact -- $opt { 31 -s - --shell { 32 set sh [lindex $argv 1] 33 if {![fileutil::test $sh efrx msg "Shell"]} { 34 sak::test::usage $msg 35 } 36 lappend config(shells) $sh 37 set argv [lrange $argv 2 end] 38 } 39 -g - --valgrind { 40 if {![llength $valgrind]} { 41 sak::test::usage valgrind not found in the PATH 42 } 43 incr config(valgrind) 44 set argv [lrange $argv 1 end] 45 } 46 -v { 47 set config(raw) 1 48 set argv [lrange $argv 1 end] 49 } 50 -l - --log { 51 set config(log) 1 52 set config(stem) [lindex $argv 1] 53 set argv [lrange $argv 2 end] 54 } 55 default { 56 sak::test::usage Unknown option "\"$opt\"" 57 } 58 } 59 } 60 61 if {$config(log)} {set config(raw) 0} 62 63 if {![sak::util::checkModules argv]} return 64 65 run::Do config $argv 66 return 67} 68 69# ### 70 71proc ::sak::test::run::Do {cv modules} { 72 upvar 1 $cv config 73 variable valgrind 74 variable araw $config(raw) 75 variable alog $config(log) 76 variable xttimes {} 77 # alog => !araw 78 79 set shells $config(shells) 80 if {![llength $shells]} { 81 catch {set shells [sak::test::shell::list]} 82 } 83 if {![llength $shells]} { 84 set shells [list [info nameofexecutable]] 85 } 86 87 if {$alog} { 88 variable logext [open $config(stem).log w] 89 variable logsum [open $config(stem).summary w] 90 variable logfai [open $config(stem).failures w] 91 variable logski [open $config(stem).skipped w] 92 variable lognon [open $config(stem).none w] 93 variable logerd [open $config(stem).errdetails w] 94 variable logfad [open $config(stem).faildetails w] 95 # Timings per testsuite (sec), average test timings (usec) 96 variable logtim [open $config(stem).timings w] 97 variable logtmt [open $config(stem).timetable w] 98 # Timings per test (usec) 99 variable logtti [open $config(stem).t-timings w] 100 variable logtmi [open $config(stem).t-timetable w] 101 } else { 102 variable logext stdout 103 } 104 105 # Preprocessing of module names and shell versions to allows 106 # better formatting of the progress output, i.e. vertically 107 # aligned columns 108 109 if {!$araw} { 110 variable maxml 0 111 variable maxvl 0 112 sak::animate::init 113 foreach m $modules { 114 = "M $m" 115 set l [string length $m] 116 if {$l > $maxml} {set maxml $l} 117 } 118 foreach sh $shells { 119 = "SH $sh" 120 set v [exec $sh << {puts [info patchlevel]; exit}] 121 set l [string length $v] 122 if {$l > $maxvl} {set maxvl $l} 123 } 124 =| "Starting ..." 125 } 126 127 set total 0 128 set pass 0 129 set fail 0 130 set skip 0 131 set err 0 132 133 foreach sh $shells { 134 foreach m $modules { 135 set cmd [Command config $m $sh] 136 sak::animate::init 137 if {$alog || $araw} { 138 puts $logext ============================================================ 139 flush $logext 140 } 141 if {[catch {Close [Process [open |$cmd r+]]} msg]} { 142 incr err 143 =| "~~ [mag]ERR ${msg}[rst]" 144 if {$alog || $araw} { 145 puts $logext [mag]$msg[rst] 146 flush $logext 147 } 148 } 149 #sak::animate::last Ok 150 } 151 } 152 153 puts $logext "Passed [format %6d $pass] of [format %6d $total]" 154 puts $logext "Skipped [format %6d $skip] of [format %6d $total]" 155 156 if {$fail} { 157 puts $logext "Failed [red][format %6d $fail][rst] of [format %6d $total]" 158 } else { 159 puts $logext "Failed [format %6d $fail] of [format %6d $total]" 160 } 161 if {$err} { 162 puts $logext "#Errors [mag][format %6d $err][rst]" 163 } else { 164 puts $logext "#Errors [format %6d $err]" 165 } 166 167 flush $logext 168 169 =| "... Done" 170 171 if {$alog} { 172 # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 173 # Timings per testsuite 174 =| "... Postprocessing per-testsuite timings ..." 175 176 variable xtimes 177 178 struct::matrix M 179 M add columns 6 180 181 M add row {Shell Module Testsuite Tests Seconds uSec/Test} 182 M add row {===== ====== ========= ===== ======= =========} 183 184 foreach item [lsort -decreasing -int -index 3 [lsort -dict -index 0 $xtimes]] { 185 foreach {k testnum delta score} $item break 186 M add row [linsert $k end $testnum $delta $score] 187 } 188 189 M add row {===== ====== ========= ===== ======= =========} 190 191 puts $logtmt "\nTiming Table..." 192 puts $logtmt [M format 2string] 193 194 # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 195 # Timings per testcase. 196 =| "... Postprocessing per-test timings ..." 197 198 variable xttimes 199 struct::matrix MX 200 MX add columns 5 201 202 MX add row {Shell Module Testsuite Test uSec} 203 MX add row {===== ====== ========= ==== ====} 204 205 foreach item [lsort -index 1 -integer -decreasing [lsort -index 0 -dict $xttimes]] { 206 foreach {k usec} $item break 207 MX add row [linsert $k end $usec] 208 } 209 210 MX add row {===== ====== ========= ==== ====} 211 212 puts $logtmi "\nTiming Table..." 213 puts $logtmi [MX format 2string] 214 215 # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 216 =| "... Postprocessing Done" 217 } 218 219 exit [expr {($err || $fail) ? 1 : 0}] 220 return 221} 222 223# ### 224 225if {$::tcl_platform(platform) == "windows"} { 226 227 proc ::sak::test::run::Command {cv m sh} { 228 variable valgrind 229 upvar 1 $cv config 230 231 # Windows. Construction of the pipe to run a specific 232 # testsuite against a single shell. There is no valgrind to 233 # accomodate, and neither can we expect to have unix commands 234 # like 'echo' and 'cat' available. 'echo' we can go without. A 235 # 'cat' however is needed to merge stdout and stderr of the 236 # testsuite for processing here. We use an emuluation written 237 # in Tcl. 238 239 set catfile cat[pid].tcl 240 fileutil::writeFile $catfile { 241 catch {wm withdraw .} 242 while {![eof stdin]} {puts stdout [gets stdin]} 243 exit 244 } 245 246 set cmd "" 247 lappend cmd $sh 248 lappend cmd [Driver] -modules [list $m] 249 lappend cmd |& $sh $catfile 250 #puts <<$cmd>> 251 252 return $cmd 253 } 254 255 proc ::sak::test::run::Close {pipe} { 256 close $pipe 257 file delete cat[pid].tcl 258 return 259 } 260} else { 261 proc ::sak::test::run::Command {cv m sh} { 262 variable valgrind 263 upvar 1 $cv config 264 265 # Unix. Construction of the pipe to run a specific testsuite 266 # against a single shell. The command is constructed to work 267 # when using valgrind, and works when not using it as well. 268 269 set script {} 270 lappend script [list set argv [list -modules [list $m]]] 271 lappend script {set argc 2} 272 lappend script [list source [Driver]] 273 lappend script exit 274 275 set cmd "" 276 lappend cmd echo [join $script \n] 277 lappend cmd | 278 279 if {$config(valgrind)} { 280 foreach e $valgrind {lappend cmd $e} 281 if {$config(valgrind) > 1} { 282 lappend cmd --num-callers=8 283 lappend cmd --leak-resolution=high 284 lappend cmd -v --leak-check=yes 285 lappend cmd --show-reachable=yes 286 } 287 } 288 lappend cmd $sh 289 #lappend cmd >@ stdout 2>@ stderr 290 lappend cmd |& cat 291 #puts <<$cmd>> 292 293 return $cmd 294 } 295 296 proc ::sak::test::run::Close {pipe} { 297 close $pipe 298 return 299 } 300} 301 302# ### 303 304proc ::sak::test::run::Process {pipe} { 305 variable araw 306 variable alog 307 variable logext 308 while {1} { 309 if {[eof $pipe]} break 310 if {[gets $pipe line] < 0} break 311 if {$alog || $araw} {puts $logext $line ; flush $logext} 312 set rline $line 313 set line [string trim $line] 314 if {[string equal $line ""]} continue 315 Host; Platform 316 Cwd; Shell 317 Tcl 318 Start; End ; StartFile ; EndFile 319 Module; Testsuite 320 NoTestsuite 321 Support;Testing;Other 322 Summary 323 CaptureFailureSync ; # xcollect 1 => 2 324 CaptureFailureCollectBody ; # xcollect 2 => 3 => 5 325 CaptureFailureCollectActual ; # xcollect 3 => 4 326 CaptureFailureCollectExpected ; # xcollect 4 => 0 327 CaptureFailureCollectError ; # xcollect 5 => 0 328 CaptureStackStart 329 CaptureStack 330 331 TestStart 332 TestTook 333 TestSkipped 334 TestPassed 335 TestFailed ; # xcollect => 1 336 337 SetupError 338 Aborted 339 AbortCause 340 341 Match||Skip||Sourced 342 # Unknown lines are printed 343 if {!$araw} {puts !$line} 344 } 345 return $pipe 346} 347 348# ### 349 350proc ::sak::test::run::Driver {} { 351 variable base 352 return [file join $base all.tcl] 353} 354 355# ### 356 357proc ::sak::test::run::Host {} { 358 upvar 1 line line ; variable xhost 359 if {![regexp "^@@ Host (.*)$" $line -> xhost]} return 360 # += $xhost 361 set xhost [list Tests Results $xhost] 362 #sak::registry::local set $xhost 363 return -code continue 364} 365 366proc ::sak::test::run::Platform {} { 367 upvar 1 line line ; variable xplatform 368 if {![regexp "^@@ Platform (.*)$" $line -> xplatform]} return 369 # += ($xplatform) 370 variable xhost 371 #sak::registry::local set $xhost Platform $xplatform 372 return -code continue 373} 374 375proc ::sak::test::run::Cwd {} { 376 upvar 1 line line ; variable xcwd 377 if {![regexp "^@@ CWD (.*)$" $line -> xcwd]} return 378 variable xhost 379 set xcwd [linsert $xhost end $xcwd] 380 #sak::registry::local set $xcwd 381 return -code continue 382} 383 384proc ::sak::test::run::Shell {} { 385 upvar 1 line line ; variable xshell 386 if {![regexp "^@@ Shell (.*)$" $line -> xshell]} return 387 # += [file tail $xshell] 388 variable xcwd 389 set xshell [linsert $xcwd end $xshell] 390 #sak::registry::local set $xshell 391 return -code continue 392} 393 394proc ::sak::test::run::Tcl {} { 395 upvar 1 line line ; variable xtcl 396 if {![regexp "^@@ Tcl (.*)$" $line -> xtcl]} return 397 variable xshell 398 variable maxvl 399 += \[$xtcl\][blank [expr {$maxvl - [string length $xtcl]}]] 400 #sak::registry::local set $xshell Tcl $xtcl 401 return -code continue 402} 403 404proc ::sak::test::run::Match||Skip||Sourced {} { 405 upvar 1 line line 406 if {[string match "@@ Skip*" $line]} {return -code continue} 407 if {[string match "@@ Match*" $line]} {return -code continue} 408 if {[string match "Sourced * Test Files." $line]} {return -code continue} 409 if {[string match "Files with failing tests*" $line]} {return -code continue} 410 if {[string match "Number of tests skipped*" $line]} {return -code continue} 411 if {[string match "\[0-9\]*" $line]} {return -code continue} 412 return 413} 414 415proc ::sak::test::run::Start {} { 416 upvar 1 line line 417 if {![regexp "^@@ Start (.*)$" $line -> start]} return 418 variable xshell 419 #sak::registry::local set $xshell Start $start 420 return -code continue 421} 422 423proc ::sak::test::run::End {} { 424 upvar 1 line line 425 if {![regexp "^@@ End (.*)$" $line -> end]} return 426 variable xshell 427 #sak::registry::local set $xshell End $end 428 return -code continue 429} 430 431proc ::sak::test::run::StartFile {} { 432 upvar 1 line line 433 if {![regexp "^@@ StartFile (.*)$" $line -> start]} return 434 variable xstartfile $start 435 variable xtestnum 0 436 #sak::registry::local set $xshell Start $start 437 return -code continue 438} 439 440proc ::sak::test::run::EndFile {} { 441 upvar 1 line line 442 if {![regexp "^@@ EndFile (.*)$" $line -> end]} return 443 variable xfile 444 variable xstartfile 445 variable xtimes 446 variable xtestnum 447 variable xduration 448 449 set k [lreplace $xfile 0 3] 450 set k [lreplace $k 2 2 [file tail [lindex $k 2]]] 451 set delta [expr {$end - $xstartfile}] 452 incr xduration $delta 453 454 if {$xtestnum == 0} { 455 set score $delta 456 } else { 457 # average number of microseconds per test. 458 set score [expr {int(($delta/double($xtestnum))*1000000)}] 459 #set score [expr {$delta/double($xtestnum)}] 460 } 461 462 lappend xtimes [list $k $xtestnum $delta $score] 463 464 variable alog 465 if {$alog} { 466 variable logtim 467 puts $logtim [linsert [linsert $k end $xtestnum $delta $score] 0 TIME] 468 } 469 470 #sak::registry::local set $xshell End $end 471 return -code continue 472} 473 474proc ::sak::test::run::Module {} { 475 upvar 1 line line ; variable xmodule 476 if {![regexp "^@@ Module (.*)$" $line -> xmodule]} return 477 variable xshell 478 variable xstatus ok 479 variable maxml 480 variable xduration 0 481 += ${xmodule}[blank [expr {$maxml - [string length $xmodule]}]] 482 set xmodule [linsert $xshell end $xmodule] 483 #sak::registry::local set $xmodule 484 return -code continue 485} 486 487proc ::sak::test::run::Testsuite {} { 488 upvar 1 line line ; variable xfile 489 if {![regexp "^@@ Testsuite (.*)$" $line -> xfile]} return 490 = <[file tail $xfile]> 491 variable xmodule 492 set xfile [linsert $xmodule end $xfile] 493 #sak::registry::local set $xfile Aborted 0 494 return -code continue 495} 496 497proc ::sak::test::run::NoTestsuite {} { 498 upvar 1 line line 499 if {![string match "Error: No test files remain after*" $line]} return 500 variable xstatus none 501 = {No tests} 502 return -code continue 503} 504 505proc ::sak::test::run::Support {} { 506 upvar 1 line line 507 if {![regexp "^- (.*)$" $line -> package]} return 508 #= "S $package" 509 foreach {pn pv} $package break 510 variable xfile 511 #sak::registry::local set [linsert $xfile end Support] $pn $pv 512 return -code continue 513} 514 515proc ::sak::test::run::Testing {} { 516 upvar 1 line line 517 if {![regexp "^\\* (.*)$" $line -> package]} return 518 #= "T $package" 519 foreach {pn pv} $package break 520 variable xfile 521 #sak::registry::local set [linsert $xfile end Testing] $pn $pv 522 return -code continue 523} 524 525proc ::sak::test::run::Other {} { 526 upvar 1 line line 527 if {![string match ">*" $line]} return 528 return -code continue 529} 530 531proc ::sak::test::run::Summary {} { 532 upvar 1 line line 533 if {![regexp "^all\\.tcl:(.*)$" $line -> line]} return 534 variable xmodule 535 variable xstatus 536 variable xvstatus 537 538 foreach {_ t _ p _ s _ f} [split [string trim $line]] break 539 #sak::registry::local set $xmodule Total $t ; set t [format %5d $t] 540 #sak::registry::local set $xmodule Passed $p ; set p [format %5d $p] 541 #sak::registry::local set $xmodule Skipped $s ; set s [format %5d $s] 542 #sak::registry::local set $xmodule Failed $f ; set f [format %5d $f] 543 544 upvar 2 total _total ; incr _total $t 545 upvar 2 pass _pass ; incr _pass $p 546 upvar 2 skip _skip ; incr _skip $s 547 upvar 2 fail _fail ; incr _fail $f 548 upvar 2 err _err 549 550 set t [format %5d $t] 551 set p [format %5d $p] 552 set s [format %5d $s] 553 set f [format %5d $f] 554 555 if {$xstatus == "ok" && $t == 0} { 556 set xstatus none 557 set spent "" 558 } else { 559 # Time spent on all the files in the module. 560 variable xduration 561 #set sec $xduration 562 #set min [expr {$sec / 60}] 563 #set sec [expr {$sec % 60}] 564 #set hor [expr {$min / 60}] 565 #set min [expr {$min % 60}] 566 #set spent " :[format %02d $hor]h[format %02d $min]m[format %02d $sec]s" 567 set spent " @${xduration}s" 568 } 569 570 set st $xvstatus($xstatus) 571 572 if {$xstatus == "ok"} { 573 # Quick return for ok suite. 574 =| "~~ $st T $t P $p S $s F $f$spent" 575 return -code continue 576 } 577 578 # Clean out progress display using a non-highlighted 579 # string. Prevents the char count from being off. This is 580 # followed by construction and display of the highlighted version. 581 582 = " $st T $t P $p S $s F $f$spent" 583 switch -exact -- $xstatus { 584 none {=| "~~ [yel]$st T $t[rst] P $p S $s F $f"} 585 aborted {=| "~~ [whi]$st[rst] T $t P $p S $s F $f$spent"} 586 error {=| "~~ [mag]$st[rst] T $t P $p S $s F $f$spent" ; incr _err } 587 fail {=| "~~ [red]$st[rst] T $t P $p S $s [red]F $f[rst]$spent"} 588 } 589 return -code continue 590} 591 592proc ::sak::test::run::TestStart {} { 593 upvar 1 line line 594 if {![string match {---- * start} $line]} return 595 set testname [string range $line 5 end-6] 596 = "---- $testname" 597 variable xfile 598 variable xtesttime -1 599 variable xtest [linsert $xfile end $testname] 600 variable xtestnum 601 incr xtestnum 602 return -code continue 603} 604 605proc ::sak::test::run::TestTook {} { 606 upvar 1 line line 607 if {![string match {++++ * took *} $line]} return 608 # Dynamic search for the marker because the name of the test may 609 # contain spaces, causing the field position to vary. 610 set pos [lsearch -exact $line took] 611 incr pos 612 set usec [lindex $line $pos] 613 variable xtesttime $usec 614 return -code continue 615} 616 617proc ::sak::test::run::TestSkipped {} { 618 upvar 1 line line 619 if {![string match {++++ * SKIPPED:*} $line]} return 620 regexp {^[^ ]* (.*)SKIPPED:.*$} $line -> testname 621 set testname [string trim $testname] 622 variable xtest 623 = "SKIP $testname" 624 if {$xtest == {}} { 625 variable xfile 626 set xtest [linsert $xfile end $testname] 627 } 628 #sak::registry::local set $xtest Status Skip 629 set xtest {} 630 return -code continue 631} 632 633proc ::sak::test::run::TestPassed {} { 634 upvar 1 line line 635 if {![string match {++++ * PASSED} $line]} return 636 set testname [string range $line 5 end-7] 637 variable xtesttime 638 variable xtest 639 if {$xtesttime < 0} { set xtesttime "" } 640 = [string trimright "PASS $testname $xtesttime"] 641 if {$xtest == {}} { 642 variable xfile 643 set xtest [linsert $xfile end $testname] 644 } 645 #sak::registry::local set $xtest Status Pass 646 variable alog 647 if {$alog && ($xtesttime ne {})} { 648 variable xttimes 649 variable logtti 650 set k [lreplace $xtest 0 3] 651 set k [lreplace $k 2 2 [file tail [lindex $k 2]]] 652 # k = shell module testfile testname 653 puts $logtti [linsert [linsert $k 0 TIME] end $xtesttime] 654 655 lappend xttimes [list $k $xtesttime] 656 } 657 set xtest {} 658 return -code continue 659} 660 661proc ::sak::test::run::TestFailed {} { 662 upvar 1 line line 663 if {![string match {==== * FAILED} $line]} return 664 set testname [lindex [split [string range $line 5 end-7]] 0] 665 = "FAIL $testname" 666 variable xtest 667 if {$xtest == {}} { 668 variable xfile 669 set xtest [linsert $xfile end $testname] 670 } 671 #sak::registry::local set $xtest Status Fail 672 ## CAPTURE INIT 673 variable xcollect 1 674 variable xbody "" 675 variable xactual "" 676 variable xexpected "" 677 variable xstatus fail 678 # Ignore failed status if we already have it, or an error 679 # status. The latter is more important to show. We do override 680 # status 'aborted'. 681 if {$xstatus == "ok"} {set xstatus fail} 682 if {$xstatus == "aborted"} {set xstatus fail} 683 return -code continue 684} 685 686proc ::sak::test::run::CaptureFailureSync {} { 687 variable xcollect 688 if {$xcollect != 1} return 689 upvar 1 line line 690 if {![string match {==== Contents*} $line]} return 691 set xcollect 2 692 return -code continue 693} 694 695proc ::sak::test::run::CaptureFailureCollectBody {} { 696 variable xcollect 697 if {$xcollect != 2} return 698 upvar 1 rline line 699 variable xbody 700 if {[string match {---- Result was*} $line]} { 701 set xcollect 3 702 return -code continue 703 } elseif {[string match {---- Test generated error*} $line]} { 704 set xcollect 5 705 return -code continue 706 } 707 708 variable xbody 709 append xbody $line \n 710 return -code continue 711} 712 713proc ::sak::test::run::CaptureFailureCollectActual {} { 714 variable xcollect 715 if {$xcollect != 3} return 716 upvar 1 rline line 717 if {![string match {---- Result should*} $line]} { 718 variable xactual 719 append xactual $line \n 720 } else { 721 set xcollect 4 722 } 723 return -code continue 724} 725 726proc ::sak::test::run::CaptureFailureCollectExpected {} { 727 variable xcollect 728 if {$xcollect != 4} return 729 upvar 1 rline line 730 if {![string match {==== *} $line]} { 731 variable xexpected 732 append xexpected $line \n 733 } else { 734 variable alog 735 if {$alog} { 736 variable logfad 737 variable xtest 738 variable xbody 739 variable xactual 740 variable xexpected 741 742 puts $logfad "==== [lrange $xtest end-1 end] FAILED =========" 743 puts $logfad "==== Contents of test case:\n" 744 puts $logfad $xbody 745 746 puts $logfad "---- Result was:" 747 puts $logfad [string range $xactual 0 end-1] 748 749 puts $logfad "---- Result should have been:" 750 puts $logfad [string range $xexpected 0 end-1] 751 752 puts $logfad "==== [lrange $xtest end-1 end] ====\n\n" 753 flush $logfad 754 } 755 set xcollect 0 756 #sak::registry::local set $xtest Body $xbody 757 #sak::registry::local set $xtest Actual $xactual 758 #sak::registry::local set $xtest Expected $xexpected 759 set xtest {} 760 } 761 return -code continue 762} 763 764proc ::sak::test::run::CaptureFailureCollectError {} { 765 variable xcollect 766 if {$xcollect != 5} return 767 upvar 1 rline line 768 variable xbody 769 if {[string match {---- errorCode*} $line]} { 770 set xcollect 4 771 return -code continue 772 } 773 774 variable xactual 775 append xactual $line \n 776 return -code continue 777} 778 779proc ::sak::test::run::Aborted {} { 780 upvar 1 line line 781 if {![string match {Aborting the tests found *} $line]} return 782 variable xfile 783 variable xstatus 784 # Ignore aborted status if we already have it, or some other error 785 # status (like error, or fail). These are more important to show. 786 if {$xstatus == "ok"} {set xstatus aborted} 787 = Aborted 788 #sak::registry::local set $xfile Aborted {} 789 return -code continue 790} 791 792proc ::sak::test::run::AbortCause {} { 793 upvar 1 line line 794 if { 795 ![string match {Requiring *} $line] && 796 ![string match {Error in *} $line] 797 } return ; # {} 798 variable xfile 799 = $line 800 #sak::registry::local set $xfile Aborted $line 801 return -code continue 802} 803 804proc ::sak::test::run::CaptureStackStart {} { 805 upvar 1 line line 806 if {![string match {@+*} $line]} return 807 variable xstackcollect 1 808 variable xstack {} 809 variable xstatus error 810 = {Error, capturing stacktrace} 811 return -code continue 812} 813 814proc ::sak::test::run::CaptureStack {} { 815 variable xstackcollect 816 if {!$xstackcollect} return 817 upvar 1 line line 818 variable xstack 819 if {![string match {@-*} $line]} { 820 append xstack [string range $line 2 end] \n 821 } else { 822 set xstackcollect 0 823 variable xfile 824 variable alog 825 #sak::registry::local set $xfile Stacktrace $xstack 826 if {$alog} { 827 variable logerd 828 puts $logerd "[lindex $xfile end] StackTrace" 829 puts $logerd "========================================" 830 puts $logerd $xstack 831 puts $logerd "========================================\n\n" 832 flush $logerd 833 } 834 } 835 return -code continue 836} 837 838proc ::sak::test::run::SetupError {} { 839 upvar 1 line line 840 if {![string match {SETUP Error*} $line]} return 841 variable xstatus error 842 = {Setup error} 843 return -code continue 844} 845 846# ### 847 848proc ::sak::test::run::+= {string} { 849 variable araw 850 if {$araw} return 851 variable aprefix 852 append aprefix " " $string 853 sak::animate::next $aprefix 854 return 855} 856 857proc ::sak::test::run::= {string} { 858 variable araw 859 if {$araw} return 860 variable aprefix 861 sak::animate::next "$aprefix $string" 862 return 863} 864 865proc ::sak::test::run::=| {string} { 866 variable araw 867 if {$araw} return 868 variable aprefix 869 sak::animate::last "$aprefix $string" 870 variable alog 871 if {$alog} { 872 variable logsum 873 variable logfai 874 variable logski 875 variable lognon 876 variable xstatus 877 puts $logsum "$aprefix $string" ; flush $logsum 878 switch -exact -- $xstatus { 879 error - 880 fail {puts $logfai "$aprefix $string" ; flush $logfai} 881 none {puts $lognon "$aprefix $string" ; flush $lognon} 882 aborted {puts $logski "$aprefix $string" ; flush $logski} 883 } 884 } 885 set aprefix "" 886 return 887} 888 889# ### 890 891namespace eval ::sak::test::run { 892 variable base [file join $::distribution support devel] 893 variable valgrind [auto_execok valgrind] 894 895 # State of test processing. 896 897 variable xstackcollect 0 898 variable xstack {} 899 variable xcollect 0 900 variable xbody {} 901 variable xactual {} 902 variable xexpected {} 903 variable xhost {} 904 variable xplatform {} 905 variable xcwd {} 906 variable xshell {} 907 variable xmodule {} 908 variable xfile {} 909 variable xtest {} 910 variable xstartfile {} 911 variable xtimes {} 912 913 variable xstatus ok 914 915 # Animation prefix of test processing, and flag controlling the 916 # nature of logging (raw vs animation). 917 918 variable aprefix {} 919 variable araw 0 920 921 # Max length of module names and patchlevel information. 922 923 variable maxml 0 924 variable maxvl 0 925 926 # Map from internal stati to the displayed human readable 927 # strings. This includes the trailing whitespace needed for 928 # vertical alignment. 929 930 variable xvstatus 931 array set xvstatus { 932 ok { } 933 none {None } 934 aborted {Skip } 935 error {ERR } 936 fail {FAILS} 937 } 938} 939 940## 941# ### 942 943package provide sak::test::run 1.0 944 945if 0 { 946 # Bad valgrind, ok no valgrind 947 if {$config(valgrind)} { 948 foreach e $valgrind {lappend cmd $e} 949 lappend cmd --num-callers=8 950 lappend cmd --leak-resolution=high 951 lappend cmd -v --leak-check=yes 952 lappend cmd --show-reachable=yes 953 } 954 lappend cmd $sh 955 lappend cmd [Driver] -modules $modules 956} 957