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 14 15namespace eval ::sak::test::run { 16 namespace import ::textutil::repeat::blank 17 namespace import ::sak::color::* 18} 19 20# ### 21 22proc ::sak::test::run {argv} { 23 variable run::valgrind 24 array set config { 25 valgrind 0 raw 0 shells {} stem {} log 0 26 } 27 28 while {[string match -* [set opt [lindex $argv 0]]]} { 29 switch -exact -- $opt { 30 -s - --shell { 31 set sh [lindex $argv 1] 32 if {![fileutil::test $sh efrx msg "Shell"]} { 33 sak::test::usage $msg 34 } 35 lappend config(shells) $sh 36 set argv [lrange $argv 2 end] 37 } 38 -g - --valgrind { 39 if {![llength $valgrind]} { 40 sak::test::usage valgrind not found in the PATH 41 } 42 incr config(valgrind) 43 set argv [lrange $argv 1 end] 44 } 45 -v { 46 set config(raw) 1 47 set argv [lrange $argv 1 end] 48 } 49 -l - --log { 50 set config(log) 1 51 set config(stem) [lindex $argv 1] 52 set argv [lrange $argv 2 end] 53 } 54 default { 55 sak::test::usage Unknown option "\"$opt\"" 56 } 57 } 58 } 59 60 if {$config(log)} {set config(raw) 0} 61 62 if {![sak::util::checkModules argv]} return 63 64 run::Do config $argv 65 return 66} 67 68# ### 69 70proc ::sak::test::run::Do {cv modules} { 71 upvar 1 $cv config 72 variable valgrind 73 variable araw $config(raw) 74 variable alog $config(log) 75 # alog => !araw 76 77 set shells $config(shells) 78 if {![llength $shells]} { 79 catch {set shells [sak::test::shell::list]} 80 } 81 if {![llength $shells]} { 82 set shells [list [info nameofexecutable]] 83 } 84 85 if {$alog} { 86 variable logext [open $config(stem).log w] 87 variable logsum [open $config(stem).summary w] 88 variable logfai [open $config(stem).failures w] 89 variable logski [open $config(stem).skipped w] 90 variable lognon [open $config(stem).none w] 91 } else { 92 variable logext stdout 93 } 94 95 # Preprocessing of module names and shell versions to allows 96 # better formatting of the progress output, i.e. vertically 97 # aligned columns 98 99 if {!$araw} { 100 variable maxml 0 101 variable maxvl 0 102 sak::animate::init 103 foreach m $modules { 104 = "M $m" 105 set l [string length $m] 106 if {$l > $maxml} {set maxml $l} 107 } 108 foreach sh $shells { 109 = "SH $sh" 110 set v [exec $sh << {puts [info patchlevel]; exit}] 111 set l [string length $v] 112 if {$l > $maxvl} {set maxvl $l} 113 } 114 =| "Starting ..." 115 } 116 117 set total 0 118 set pass 0 119 set fail 0 120 set skip 0 121 set err 0 122 123 foreach sh $shells { 124 foreach m $modules { 125 set cmd [Command config $m $sh] 126 sak::animate::init 127 if {$alog || $araw} { 128 puts $logext ============================================================ 129 flush $logext 130 } 131 if {[catch {Close [Process [open |$cmd r+]]} msg]} { 132 incr err 133 =| "~~ [mag]ERR ${msg}[rst]" 134 if {$alog || $araw} { 135 puts $logext [mag]$msg[rst] 136 flush $logext 137 } 138 } 139 #sak::animate::last Ok 140 } 141 } 142 143 puts $logext "Passed [format %6d $pass] of [format %6d $total]" 144 puts $logext "Skipped [format %6d $skip] of [format %6d $total]" 145 146 if {$fail} { 147 puts $logext "Failed [red][format %6d $fail][rst] of [format %6d $total]" 148 } else { 149 puts $logext "Failed [format %6d $fail] of [format %6d $total]" 150 } 151 if {$err} { 152 puts $logext "#Errors [mag][format %6d $err][rst]" 153 } else { 154 puts $logext "#Errors [format %6d $err]" 155 } 156 157 exit [expr {($err || $fail) ? 1 : 0}] 158 return 159} 160 161# ### 162 163if {$::tcl_platform(platform) == "windows"} { 164 165 proc ::sak::test::run::Command {cv m sh} { 166 variable valgrind 167 upvar 1 $cv config 168 169 # Windows. Construction of the pipe to run a specific 170 # testsuite against a single shell. There is no valgrind to 171 # accomodate, and neither can we expect to have unix commands 172 # like 'echo' and 'cat' available. 'echo' we can go without. A 173 # 'cat' however is needed to merge stdout and stderr of the 174 # testsuite for processing here. We use an emuluation written 175 # in Tcl. 176 177 set catfile cat[pid].tcl 178 fileutil::writeFile $catfile { 179 catch {wm withdraw .} 180 while {![eof stdin]} {puts stdout [gets stdin]} 181 exit 182 } 183 184 set cmd "" 185 lappend cmd $sh 186 lappend cmd [Driver] -modules [list $m] 187 lappend cmd |& $sh $catfile 188 #puts <<$cmd>> 189 190 return $cmd 191 } 192 193 proc ::sak::test::run::Close {pipe} { 194 close $pipe 195 file delete cat[pid].tcl 196 return 197 } 198} else { 199 proc ::sak::test::run::Command {cv m sh} { 200 variable valgrind 201 upvar 1 $cv config 202 203 # Unix. Construction of the pipe to run a specific testsuite 204 # against a single shell. The command is constructed to work 205 # when using valgrind, and works when not using it as well. 206 207 set script {} 208 lappend script [list set argv [list -modules [list $m]]] 209 lappend script {set argc 2} 210 lappend script [list source [Driver]] 211 lappend script exit 212 213 set cmd "" 214 lappend cmd echo [join $script \n] 215 lappend cmd | 216 217 if {$config(valgrind)} { 218 foreach e $valgrind {lappend cmd $e} 219 if {$config(valgrind) > 1} { 220 lappend cmd --num-callers=8 221 lappend cmd --leak-resolution=high 222 lappend cmd -v --leak-check=yes 223 lappend cmd --show-reachable=yes 224 } 225 } 226 lappend cmd $sh 227 #lappend cmd >@ stdout 2>@ stderr 228 lappend cmd |& cat 229 #puts <<$cmd>> 230 231 return $cmd 232 } 233 234 proc ::sak::test::run::Close {pipe} { 235 close $pipe 236 return 237 } 238} 239 240# ### 241 242proc ::sak::test::run::Process {pipe} { 243 variable araw 244 variable alog 245 variable logext 246 while {1} { 247 if {[eof $pipe]} break 248 if {[gets $pipe line] < 0} break 249 if {$alog || $araw} {puts $logext $line ; flush $logext} 250 set line [string trim $line] 251 if {[string equal $line ""]} continue 252 Host; Platform 253 Cwd; Shell 254 Tcl; Match||Skip||Sourced 255 Start; End 256 Module; Testsuite 257 NoTestsuite 258 Support;Testing;Other 259 Summary 260 261 TestStart 262 TestSkipped 263 TestPassed 264 TestFailed 265 CaptureFailureSync 266 CaptureFailureCollectBody 267 CaptureFailureCollectActual 268 CaptureFailureCollectExpected 269 CaptureStackStart 270 CaptureStack 271 272 SetupError 273 Aborted 274 AbortCause 275 276 # Unknown lines are printed 277 if {!$araw} {puts !$line} 278 } 279 return $pipe 280} 281 282# ### 283 284proc ::sak::test::run::Driver {} { 285 variable base 286 return [file join $base all.tcl] 287} 288 289# ### 290 291proc ::sak::test::run::Host {} { 292 upvar 1 line line ; variable xhost 293 if {![regexp "^@@ Host (.*)$" $line -> xhost]} return 294 # += $xhost 295 set xhost [list Tests Results $xhost] 296 #sak::registry::local set $xhost 297 return -code continue 298} 299 300proc ::sak::test::run::Platform {} { 301 upvar 1 line line ; variable xplatform 302 if {![regexp "^@@ Platform (.*)$" $line -> xplatform]} return 303 # += ($xplatform) 304 variable xhost 305 #sak::registry::local set $xhost Platform $xplatform 306 return -code continue 307} 308 309proc ::sak::test::run::Cwd {} { 310 upvar 1 line line ; variable xcwd 311 if {![regexp "^@@ CWD (.*)$" $line -> xcwd]} return 312 variable xhost 313 set xcwd [linsert $xhost end $xcwd] 314 #sak::registry::local set $xcwd 315 return -code continue 316} 317 318proc ::sak::test::run::Shell {} { 319 upvar 1 line line ; variable xshell 320 if {![regexp "^@@ Shell (.*)$" $line -> xshell]} return 321 # += [file tail $xshell] 322 variable xcwd 323 set xshell [linsert $xcwd end $xshell] 324 #sak::registry::local set $xshell 325 return -code continue 326} 327 328proc ::sak::test::run::Tcl {} { 329 upvar 1 line line ; variable xtcl 330 if {![regexp "^@@ Tcl (.*)$" $line -> xtcl]} return 331 variable xshell 332 variable maxvl 333 += \[$xtcl\][blank [expr {$maxvl - [string length $xtcl]}]] 334 #sak::registry::local set $xshell Tcl $xtcl 335 return -code continue 336} 337 338proc ::sak::test::run::Match||Skip||Sourced {} { 339 upvar 1 line line 340 if {[string match "@@ Skip*" $line]} {return -code continue} 341 if {[string match "@@ Match*" $line]} {return -code continue} 342 if {[string match "Sourced * Test Files." $line]} {return -code continue} 343 if {[string match "Files with failing tests*" $line]} {return -code continue} 344 if {[string match "Number of tests skipped*" $line]} {return -code continue} 345 if {[string match "\[0-9\]*" $line]} {return -code continue} 346 return 347} 348 349proc ::sak::test::run::Start {} { 350 upvar 1 line line 351 if {![regexp "^@@ Start (.*)$" $line -> start]} return 352 variable xshell 353 #sak::registry::local set $xshell Start $start 354 return -code continue 355} 356 357proc ::sak::test::run::End {} { 358 upvar 1 line line 359 if {![regexp "^@@ End (.*)$" $line -> end]} return 360 variable xshell 361 #sak::registry::local set $xshell End $end 362 return -code continue 363} 364 365proc ::sak::test::run::Module {} { 366 upvar 1 line line ; variable xmodule 367 if {![regexp "^@@ Module (.*)$" $line -> xmodule]} return 368 variable xshell 369 variable xstatus ok 370 variable maxml 371 += ${xmodule}[blank [expr {$maxml - [string length $xmodule]}]] 372 set xmodule [linsert $xshell end $xmodule] 373 #sak::registry::local set $xmodule 374 return -code continue 375} 376 377proc ::sak::test::run::Testsuite {} { 378 upvar 1 line line ; variable xfile 379 if {![regexp "^@@ Testsuite (.*)$" $line -> xfile]} return 380 = <[file tail $xfile]> 381 variable xmodule 382 set xfile [linsert $xmodule end $xfile] 383 #sak::registry::local set $xfile Aborted 0 384 return -code continue 385} 386 387proc ::sak::test::run::NoTestsuite {} { 388 upvar 1 line line 389 if {![string match "Error: No test files remain after*" $line]} return 390 variable xstatus none 391 = {No tests} 392 return -code continue 393} 394 395proc ::sak::test::run::Support {} { 396 upvar 1 line line 397 if {![regexp "^- (.*)$" $line -> package]} return 398 #= "S $package" 399 foreach {pn pv} $package break 400 variable xfile 401 #sak::registry::local set [linsert $xfile end Support] $pn $pv 402 return -code continue 403} 404 405proc ::sak::test::run::Testing {} { 406 upvar 1 line line 407 if {![regexp "^\\* (.*)$" $line -> package]} return 408 #= "T $package" 409 foreach {pn pv} $package break 410 variable xfile 411 #sak::registry::local set [linsert $xfile end Testing] $pn $pv 412 return -code continue 413} 414 415proc ::sak::test::run::Other {} { 416 upvar 1 line line 417 if {![string match ">*" $line]} return 418 return -code continue 419} 420 421proc ::sak::test::run::Summary {} { 422 upvar 1 line line 423 if {![regexp "^all\\.tcl:(.*)$" $line -> line]} return 424 variable xmodule 425 variable xstatus 426 variable xvstatus 427 foreach {_ t _ p _ s _ f} [split [string trim $line]] break 428 #sak::registry::local set $xmodule Total $t ; set t [format %5d $t] 429 #sak::registry::local set $xmodule Passed $p ; set p [format %5d $p] 430 #sak::registry::local set $xmodule Skipped $s ; set s [format %5d $s] 431 #sak::registry::local set $xmodule Failed $f ; set f [format %5d $f] 432 433 upvar 2 total _total ; incr _total $t 434 upvar 2 pass _pass ; incr _pass $p 435 upvar 2 skip _skip ; incr _skip $s 436 upvar 2 fail _fail ; incr _fail $f 437 upvar 2 err _err 438 439 set t [format %5d $t] 440 set p [format %5d $p] 441 set s [format %5d $s] 442 set f [format %5d $f] 443 444 if {$xstatus == "ok" && $t == 0} { 445 set xstatus none 446 } 447 448 set st $xvstatus($xstatus) 449 450 if {$xstatus == "ok"} { 451 # Quick return for ok suite. 452 =| "~~ $st T $t P $p S $s F $f" 453 return -code continue 454 } 455 456 # Clean out progress display using a non-highlighted 457 # string. Prevents the char couint from being off. This is 458 # followed by construction and display of the highlighted version. 459 460 = " $st T $t P $p S $s F $f" 461 switch -exact -- $xstatus { 462 none {=| "~~ [yel]$st T $t[rst] P $p S $s F $f"} 463 aborted {=| "~~ [whi]$st[rst] T $t P $p S $s F $f"} 464 error { 465 =| "~~ [mag]$st[rst] T $t P $p S $s F $f" 466 incr _err 467 } 468 fail {=| "~~ [red]$st[rst] T $t P $p S $s [red]F $f[rst]"} 469 } 470 return -code continue 471} 472 473proc ::sak::test::run::TestStart {} { 474 upvar 1 line line 475 if {![string match {---- * start} $line]} return 476 set testname [string range $line 5 end-6] 477 = "---- $testname" 478 variable xfile 479 variable xtest [linsert $xfile end $testname] 480 return -code continue 481} 482 483proc ::sak::test::run::TestSkipped {} { 484 upvar 1 line line 485 if {![string match {++++ * SKIPPED:*} $line]} return 486 regexp {^[^ ]* (.*)SKIPPED:.*$} $line -> testname 487 set testname [string trim $testname] 488 variable xtest 489 = "SKIP $testname" 490 if {$xtest == {}} { 491 variable xfile 492 set xtest [linsert $xfile end $testname] 493 } 494 #sak::registry::local set $xtest Status Skip 495 set xtest {} 496 return -code continue 497} 498 499proc ::sak::test::run::TestPassed {} { 500 upvar 1 line line 501 if {![string match {++++ * PASSED} $line]} return 502 set testname [string range $line 5 end-7] 503 variable xtest 504 = "PASS $testname" 505 if {$xtest == {}} { 506 variable xfile 507 set xtest [linsert $xfile end $testname] 508 } 509 #sak::registry::local set $xtest Status Pass 510 set xtest {} 511 return -code continue 512} 513 514proc ::sak::test::run::TestFailed {} { 515 upvar 1 line line 516 if {![string match {==== * FAILED} $line]} return 517 set testname [lindex [split [string range $line 5 end-7]] 0] 518 = "FAIL $testname" 519 variable xtest 520 if {$xtest == {}} { 521 variable xfile 522 set xtest [linsert $xfile end $testname] 523 } 524 #sak::registry::local set $xtest Status Fail 525 ## CAPTURE INIT 526 variable xcollect 1 527 variable xbody "" 528 variable xactual "" 529 variable xexpected "" 530 variable xstatus fail 531 # Ignore failed status if we already have it, or an error 532 # status. The latter is more important to show. We do override 533 # status 'aborted'. 534 if {$xstatus == "ok"} {set xstatus fail} 535 if {$xstatus == "aborted"} {set xstatus fail} 536 return -code continue 537} 538 539proc ::sak::test::run::CaptureFailureSync {} { 540 variable xcollect 541 if {$xcollect != 1} return 542 upvar 1 line line 543 if {![string match {==== Contents*} $line]} return 544 set xcollect 2 545 return -code continue 546} 547 548proc ::sak::test::run::CaptureFailureCollectBody {} { 549 variable xcollect 550 if {$xcollect != 2} return 551 upvar 1 line line 552 variable xbody 553 if {![string match {---- Result was*} $line]} { 554 variable xbody 555 append xbody $line \n 556 } else { 557 set xcollect 3 558 } 559 return -code continue 560} 561 562proc ::sak::test::run::CaptureFailureCollectActual {} { 563 variable xcollect 564 if {$xcollect != 3} return 565 upvar 1 line line 566 if {![string match {---- Result should*} $line]} { 567 variable xactual 568 append xactual $line \n 569 } else { 570 set xcollect 4 571 } 572 return -code continue 573} 574 575proc ::sak::test::run::CaptureFailureCollectExpected {} { 576 variable xcollect 577 if {$xcollect != 4} return 578 upvar 1 line line 579 if {![string match {==== *} $line]} { 580 variable xexpected 581 append xexpected $line \n 582 } else { 583 set xcollect 0 584 #sak::registry::local set $xtest Body $xbody 585 #sak::registry::local set $xtest Actual $xactual 586 #sak::registry::local set $xtest Expected $xexpected 587 set xtest {} 588 } 589 return -code continue 590} 591 592proc ::sak::test::run::Aborted {} { 593 upvar 1 line line 594 if {![string match {Aborting the tests found *} $line]} return 595 variable xfile 596 variable xstatus 597 # Ignore aborted status if we already have it, or some other error 598 # status (like error, or fail). These are more important to show. 599 if {$xstatus == "ok"} {set xstatus aborted} 600 = Aborted 601 #sak::registry::local set $xfile Aborted {} 602 return -code continue 603} 604 605proc ::sak::test::run::AbortCause {} { 606 upvar 1 line line 607 if { 608 ![string match {Requiring *} $line] && 609 ![string match {Error in *} $line] 610 } return ; # {} 611 variable xfile 612 = $line 613 #sak::registry::local set $xfile Aborted $line 614 return -code continue 615} 616 617proc ::sak::test::run::CaptureStackStart {} { 618 upvar 1 line line 619 if {![string match {@+*} $line]} return 620 variable xstackcollect 1 621 variable xstack {} 622 variable xstatus error 623 = {Error, capturing stacktrace} 624 return -code continue 625} 626 627proc ::sak::test::run::CaptureStack {} { 628 variable xstackcollect 629 if {!$xstackcollect} return 630 upvar 1 line line 631 variable xstack 632 if {![string match {@-*} $line]} { 633 append xstack [string range $line 2 end] \n 634 } else { 635 set xstackcollect 0 636 variable xfile 637 #sak::registry::local set $xfile Stacktrace $xstack 638 } 639 return -code continue 640} 641 642proc ::sak::test::run::SetupError {} { 643 upvar 1 line line 644 if {![string match {SETUP Error*} $line]} return 645 variable xstatus error 646 = {Setup error} 647 return -code continue 648} 649 650# ### 651 652proc ::sak::test::run::+= {string} { 653 variable araw 654 if {$araw} return 655 variable aprefix 656 append aprefix " " $string 657 sak::animate::next $aprefix 658 return 659} 660 661proc ::sak::test::run::= {string} { 662 variable araw 663 if {$araw} return 664 variable aprefix 665 sak::animate::next "$aprefix $string" 666 return 667} 668 669proc ::sak::test::run::=| {string} { 670 variable araw 671 if {$araw} return 672 variable aprefix 673 sak::animate::last "$aprefix $string" 674 variable alog 675 if {$alog} { 676 variable logsum 677 variable logfai 678 variable logski 679 variable lognon 680 variable xstatus 681 puts $logsum "$aprefix $string" ; flush $logsum 682 switch -exact -- $xstatus { 683 error - 684 fail {puts $logfai "$aprefix $string" ; flush $logfai} 685 none {puts $lognon "$aprefix $string" ; flush $lognon} 686 aborted {puts $logski "$aprefix $string" ; flush $logski} 687 } 688 } 689 set aprefix "" 690 return 691} 692 693# ### 694 695namespace eval ::sak::test::run { 696 variable base [file join $::distribution support devel] 697 variable valgrind [auto_execok valgrind] 698 699 # State of test processing. 700 701 variable xstackcollect 0 702 variable xstack {} 703 variable xcollect 0 704 variable xbody {} 705 variable xactual {} 706 variable xexpected {} 707 variable xhost {} 708 variable xplatform {} 709 variable xcwd {} 710 variable xshell {} 711 variable xmodule {} 712 variable xfile {} 713 variable xtest {} 714 715 variable xstatus ok 716 717 # Animation prefix of test processing, and flag controlling the 718 # nature of logging (raw vs animation). 719 720 variable aprefix {} 721 variable araw 0 722 723 # Max length of module names and patchlevel information. 724 725 variable maxml 0 726 variable maxvl 0 727 728 # Map from internal stati to the displayed human readable 729 # strings. This includes the trailing whitespace needed for 730 # vertical alignment. 731 732 variable xvstatus 733 array set xvstatus { 734 ok { } 735 none {None } 736 aborted {Skip } 737 error {ERR } 738 fail {FAILS} 739 } 740} 741 742## 743# ### 744 745package provide sak::test::run 1.0 746 747if 0 { 748 # Bad valgrind, ok no valgrind 749 if {$config(valgrind)} { 750 foreach e $valgrind {lappend cmd $e} 751 lappend cmd --num-callers=8 752 lappend cmd --leak-resolution=high 753 lappend cmd -v --leak-check=yes 754 lappend cmd --show-reachable=yes 755 } 756 lappend cmd $sh 757 lappend cmd [Driver] -modules $modules 758} 759