test/testrunner.tcl

   1
   2 set dir [pwd]
   3 set testdir [file dirname $argv0]
   4 set saved $argv
   5 set argv [list]
   6 source [file join $testdir testrunner_data.tcl]
   7 source [file join $testdir permutations.test]
   8 set argv $saved
   9 cd $dir
  10
  11 #-------------------------------------------------------------------------
  12 # Usage:
  13 #
  14 proc usage {} {
  15   set a0 [file tail $::argv0]
  16
  17   puts stderr [string trim [subst -nocommands {
  18 Usage:
  19     $a0 ?SWITCHES? ?PERMUTATION? ?PATTERNS?
  20     $a0 PERMUTATION FILE
  21     $a0 njob ?NJOB?
  22     $a0 status
  23
  24   where SWITCHES are:
  25     --jobs NUMBER-OF-JOBS
  26     --fuzztest
  27     --zipvfs ZIPVFS-SOURCE-DIR
  28
  29 Interesting values for PERMUTATION are:
  30
  31     veryquick - a fast subset of the tcl test scripts. This is the default.
  32     full      - all tcl test scripts.
  33     all       - all tcl test scripts, plus a subset of test scripts rerun
  34                 with various permutations.
  35     release   - full release test with various builds.
  36
  37 If no PATTERN arguments are present, all tests specified by the PERMUTATION
  38 are run. Otherwise, each pattern is interpreted as a glob pattern. Only
  39 those tcl tests for which the final component of the filename matches at
  40 least one specified pattern are run.
  41
  42 If no PATTERN arguments are present, then various fuzztest, threadtest
  43 and other tests are run as part of the "release" permutation. These are
  44 omitted if any PATTERN arguments are specified on the command line.
  45
  46 If a PERMUTATION is specified and is followed by the path to a Tcl script
  47 instead of a list of patterns, then that single Tcl test script is run
  48 with the specified permutation.
  49
  50 The --fuzztest option is ignored if the PERMUTATION is "release". Otherwise,
  51 if it is present, then "make -C <dir> fuzztest" is run as part of the tests,
  52 where <dir> is the directory containing the testfixture binary used to
  53 run the script.
  54
  55 The "status" and "njob" commands are designed to be run from the same
  56 directory as a running testrunner.tcl script that is running tests. The
  57 "status" command prints a report describing the current state and progress
  58 of the tests. The "njob" command may be used to query or modify the number
  59 of sub-processes the test script uses to run tests.
  60   }]]
  61
  62   exit 1
  63 }
  64 #-------------------------------------------------------------------------
  65
  66 #-------------------------------------------------------------------------
  67 # Try to estimate a the number of processes to use.
  68 #
  69 # Command [guess_number_of_cores] attempts to glean the number of logical
  70 # cores. Command [default_njob] returns the default value for the --jobs
  71 # switch.
  72 #
  73 proc guess_number_of_cores {} {
  74   if {[catch {number_of_cores} ret]} {
  75     set ret 4
  76
  77     if {$::tcl_platform(os)=="Darwin"} {
  78       set cmd "sysctl -n hw.logicalcpu"
  79     } else {
  80       set cmd "nproc"
  81     }
  82     catch {
  83       set fd [open "|$cmd" r]
  84       set ret [gets $fd]
  85       close $fd
  86       set ret [expr $ret]
  87     }
  88   }
  89   return $ret
  90 }
  91
  92 proc default_njob {} {
  93   set nCore [guess_number_of_cores]
  94   if {$nCore<=2} {
  95     set nHelper 1
  96   } else {
  97     set nHelper [expr int($nCore*0.5)]
  98   }
  99   return $nHelper
 100 }
 101 #-------------------------------------------------------------------------
 102
 103 #-------------------------------------------------------------------------
 104 # Setup various default values in the global TRG() array.
 105 #
 106 set TRG(dbname) [file normalize testrunner.db]
 107 set TRG(logname) [file normalize testrunner.log]
 108 set TRG(build.logname) [file normalize testrunner_build.log]
 109 set TRG(info_script) [file normalize [info script]]
 110 set TRG(timeout) 10000              ;# Default busy-timeout for testrunner.db
 111 set TRG(nJob)    [default_njob]     ;# Default number of helper processes
 112 set TRG(patternlist) [list]
 113 set TRG(cmdline) $argv
 114 set TRG(reporttime) 2000
 115 set TRG(fuzztest) 0                 ;# is the fuzztest option present.
 116 set TRG(zipvfs) ""                  ;# -zipvfs option, if any
 117
 118 switch -nocase -glob -- $tcl_platform(os) {
 119   *darwin* {
 120     set TRG(platform) osx
 121     set TRG(make)     make.sh
 122     set TRG(makecmd)  "bash make.sh"
 123   }
 124   *linux* {
 125     set TRG(platform) linux
 126     set TRG(make)     make.sh
 127     set TRG(makecmd)  "bash make.sh"
 128   }
 129   *win* {
 130     set TRG(platform) win
 131     set TRG(make)     make.bat
 132     set TRG(makecmd)  make.bat
 133   }
 134   default {
 135     error "cannot determine platform!"
 136   }
 137 }
 138 #-------------------------------------------------------------------------
 139
 140 #-------------------------------------------------------------------------
 141 # The database schema used by the testrunner.db database.
 142 #
 143 set TRG(schema) {
 144   DROP TABLE IF EXISTS script;
 145   DROP TABLE IF EXISTS config;
 146
 147   CREATE TABLE script(
 148     build TEXT DEFAULT '',
 149     config TEXT,
 150     filename TEXT,                -- full path to test script
 151     slow BOOLEAN,                 -- true if script is "slow"
 152     state TEXT CHECK( state IN ('', 'ready', 'running', 'done', 'failed') ),
 153     time INTEGER,                 -- Time in ms
 154     output TEXT,                  -- full output of test script
 155     priority AS ((config='make') + ((config='build')*2) + (slow*4)),
 156     jobtype AS (
 157       CASE WHEN config IN ('build', 'make') THEN config ELSE 'script' END
 158     ),
 159     PRIMARY KEY(build, config, filename)
 160   );
 161
 162   CREATE TABLE config(
 163     name TEXT COLLATE nocase PRIMARY KEY,
 164     value
 165   ) WITHOUT ROWID;
 166
 167   CREATE INDEX i1 ON script(state, jobtype);
 168   CREATE INDEX i2 ON script(state, priority);
 169 }
 170 #-------------------------------------------------------------------------
 171
 172 #--------------------------------------------------------------------------
 173 # Check if this script is being invoked to run a single file. If so,
 174 # run it.
 175 #
 176 if {[llength $argv]==2
 177  && ([lindex $argv 0]=="" || [info exists ::testspec([lindex $argv 0])])
 178  && [file exists [lindex $argv 1]]
 179 } {
 180   set permutation [lindex $argv 0]
 181   set script [file normalize [lindex $argv 1]]
 182   set ::argv [list]
 183
 184   if {$permutation=="full"} {
 185
 186     set testdir [file dirname $argv0]
 187     source $::testdir/tester.tcl
 188     unset -nocomplain ::G(isquick)
 189     reset_db
 190
 191   } elseif {$permutation!="default" && $permutation!=""} {
 192
 193     if {[info exists ::testspec($permutation)]==0} {
 194       error "no such permutation: $permutation"
 195     }
 196
 197     array set O $::testspec($permutation)
 198     set ::G(perm:name)         $permutation
 199     set ::G(perm:prefix)       $O(-prefix)
 200     set ::G(isquick)           1
 201     set ::G(perm:dbconfig)     $O(-dbconfig)
 202     set ::G(perm:presql)       $O(-presql)
 203
 204     rename finish_test helper_finish_test
 205     proc finish_test {} "
 206       uplevel {
 207         $O(-shutdown)
 208       }
 209       helper_finish_test
 210     "
 211
 212     eval $O(-initialize)
 213   }
 214
 215   reset_db
 216   source $script
 217   exit
 218 }
 219 #--------------------------------------------------------------------------
 220
 221 #--------------------------------------------------------------------------
 222 # Check if this is the "njob" command:
 223 #
 224 if {([llength $argv]==2 || [llength $argv]==1)
 225  && [string compare -nocase njob [lindex $argv 0]]==0
 226 } {
 227   sqlite3 mydb $TRG(dbname)
 228   if {[llength $argv]==2} {
 229     set param [lindex $argv 1]
 230     if {[string is integer $param]==0 || $param<1 || $param>128} {
 231       puts stderr "parameter must be an integer between 1 and 128"
 232       exit 1
 233     }
 234
 235     mydb eval { REPLACE INTO config VALUES('njob', $param); }
 236   }
 237   set res [mydb one { SELECT value FROM config WHERE name='njob' }]
 238   mydb close
 239   puts "$res"
 240   exit
 241 }
 242 #--------------------------------------------------------------------------
 243
 244 #--------------------------------------------------------------------------
 245 # Check if this is the "status" command:
 246 #
 247 if {[llength $argv]==1
 248  && [string compare -nocase status [lindex $argv 0]]==0
 249 } {
 250
 251   proc display_job {build config filename {tm ""}} {
 252     if {$config=="build"} {
 253       set fname "build: $filename"
 254       set config ""
 255     } elseif {$config=="make"} {
 256       set fname "make: $filename"
 257       set config ""
 258     } else {
 259       set fname [file normalize $filename]
 260       if {[string first $::srcdir $fname]==0} {
 261         set fname [string range $fname [string length $::srcdir]+1 end]
 262       }
 263     }
 264     set dfname [format %-33s $fname]
 265
 266     set dbuild ""
 267     set dconfig ""
 268     set dparams ""
 269     set dtm ""
 270     if {$build!=""} { set dbuild $build }
 271     if {$config!="" && $config!="full"} { set dconfig $config }
 272     if {$dbuild!="" || $dconfig!=""} {
 273       append dparams "("
 274       if {$dbuild!=""}                 {append dparams "build=$dbuild"}
 275       if {$dbuild!="" && $dconfig!=""} {append dparams " "}
 276       if {$dconfig!=""}                {append dparams "config=$dconfig"}
 277       append dparams ")"
 278       set dparams [format %-33s $dparams]
 279     }
 280     if {$tm!=""} {
 281       set dtm "\[${tm}ms\]"
 282     }
 283     puts "  $dfname $dparams $dtm"
 284   }
 285
 286   sqlite3 mydb $TRG(dbname)
 287   mydb timeout 1000
 288   mydb eval BEGIN
 289
 290   set cmdline [mydb one { SELECT value FROM config WHERE name='cmdline' }]
 291   set nJob [mydb one { SELECT value FROM config WHERE name='njob' }]
 292   set tm [expr [clock_milliseconds] - [mydb one {
 293     SELECT value FROM config WHERE name='start'
 294   }]]
 295
 296   set total 0
 297   foreach s {"" ready running done failed} { set S($s) 0 }
 298   mydb eval {
 299     SELECT state, count(*) AS cnt FROM script GROUP BY 1
 300   } {
 301     incr S($state) $cnt
 302     incr total $cnt
 303   }
 304   set fin [expr $S(done)+$S(failed)]
 305   if {$cmdline!=""} {set cmdline " $cmdline"}
 306
 307   set f ""
 308   if {$S(failed)>0} {
 309     set f "$S(failed) FAILED, "
 310   }
 311   puts "Command line: \[testrunner.tcl$cmdline\]"
 312   puts "Jobs:         $nJob"
 313   puts "Summary:      ${tm}ms, ($fin/$total) finished, ${f}$S(running) running"
 314
 315   set srcdir [file dirname [file dirname $TRG(info_script)]]
 316   if {$S(running)>0} {
 317     puts "Running: "
 318     set now [clock_milliseconds]
 319     mydb eval {
 320       SELECT build, config, filename, time FROM script WHERE state='running'
 321       ORDER BY time
 322     } {
 323       display_job $build $config $filename [expr $now-$time]
 324     }
 325   }
 326   if {$S(failed)>0} {
 327     puts "Failures: "
 328     mydb eval {
 329       SELECT build, config, filename FROM script WHERE state='failed'
 330       ORDER BY 3
 331     } {
 332       display_job $build $config $filename
 333     }
 334   }
 335
 336   mydb close
 337   exit
 338 }
 339
 340 #-------------------------------------------------------------------------
 341 # Parse the command line.
 342 #
 343 for {set ii 0} {$ii < [llength $argv]} {incr ii} {
 344   set isLast [expr $ii==([llength $argv]-1)]
 345   set a [lindex $argv $ii]
 346   set n [string length $a]
 347
 348   if {[string range $a 0 0]=="-"} {
 349     if {($n>2 && [string match "$a*" --jobs]) || $a=="-j"} {
 350       incr ii
 351       set TRG(nJob) [lindex $argv $ii]
 352       if {$isLast} { usage }
 353     } elseif {($n>2 && [string match "$a*" --fuzztest]) || $a=="-f"} {
 354       set TRG(fuzztest) 1
 355     } elseif {($n>2 && [string match "$a*" --zipvfs]) || $a=="-z"} {
 356       incr ii
 357       set TRG(zipvfs) [lindex $argv $ii]
 358       if {$isLast} { usage }
 359     } else {
 360       usage
 361     }
 362   } else {
 363     lappend TRG(patternlist) [string map {% *} $a]
 364   }
 365 }
 366 set argv [list]
 367
 368
 369
 370 # This script runs individual tests - tcl scripts or [make xyz] commands -
 371 # in directories named "testdir$N", where $N is an integer. This variable
 372 # contains a list of integers indicating the directories in use.
 373 #
 374 # This variable is accessed only via the following commands:
 375 #
 376 #   dirs_nHelper
 377 #     Return the number of entries currently in the list.
 378 #
 379 #   dirs_freeDir IDIR
 380 #     Remove value IDIR from the list. It is an error if it is not present.
 381 #
 382 #   dirs_allocDir
 383 #     Select a value that is not already in the list. Add it to the list
 384 #     and return it.
 385 #
 386 set TRG(dirs_in_use) [list]
 387
 388 proc dirs_nHelper {} {
 389   global TRG
 390   llength $TRG(dirs_in_use)
 391 }
 392 proc dirs_freeDir {iDir} {
 393   global TRG
 394   set out [list]
 395   foreach d $TRG(dirs_in_use) {
 396     if {$iDir!=$d} { lappend out $d }
 397   }
 398   if {[llength $out]!=[llength $TRG(dirs_in_use)]-1} {
 399     error "dirs_freeDir could not find $iDir"
 400   }
 401   set TRG(dirs_in_use) $out
 402 }
 403 proc dirs_allocDir {} {
 404   global TRG
 405   array set inuse [list]
 406   foreach d $TRG(dirs_in_use) {
 407     set inuse($d) 1
 408   }
 409   for {set iRet 0} {[info exists inuse($iRet)]} {incr iRet} { }
 410   lappend TRG(dirs_in_use) $iRet
 411   return $iRet
 412 }
 413
 414 set testdir [file dirname $argv0]
 415
 416 # Check that directory $dir exists. If it does not, create it. If
 417 # it does, delete its contents.
 418 #
 419 proc create_or_clear_dir {dir} {
 420   set dir [file normalize $dir]
 421   catch { file mkdir $dir }
 422   foreach f [glob -nocomplain [file join $dir *]] {
 423     catch { file delete -force $f }
 424   }
 425 }
 426
 427 proc copy_dir {from to} {
 428   foreach f [glob -nocomplain [file join $from *]] {
 429     catch { file copy -force $f $to }
 430   }
 431 }
 432
 433 proc build_to_dirname {bname} {
 434   set fold [string tolower [string map {- _} $bname]]
 435   return "testrunner_build_$fold"
 436 }
 437
 438 #-------------------------------------------------------------------------
 439 # Return a list of tests to run. Each element of the list is itself a
 440 # list of two elements - the name of a permuations.test configuration
 441 # followed by the full path to a test script. i.e.:
 442 #
 443 #    {BUILD CONFIG FILENAME} {BUILD CONFIG FILENAME} ...
 444 #
 445 proc testset_patternlist {patternlist} {
 446   global TRG
 447
 448   set testset [list]              ;# return value
 449
 450   set first [lindex $patternlist 0]
 451
 452   if {$first=="release"} {
 453     set platform $::TRG(platform)
 454
 455     set patternlist [lrange $patternlist 1 end]
 456     foreach b [trd_builds $platform] {
 457       foreach c [trd_configs $platform $b] {
 458         testset_append testset $b $c $patternlist
 459       }
 460
 461       if {[llength $patternlist]==0 || $b=="User-Auth"} {
 462         set target testfixture
 463       } else {
 464         set target coretestprogs
 465       }
 466       lappend testset [list $b build $target]
 467     }
 468
 469     if {[llength $patternlist]==0} {
 470       foreach b [trd_builds $platform] {
 471         foreach e [trd_extras $platform $b] {
 472           lappend testset [list $b make $e]
 473         }
 474       }
 475     }
 476
 477     set TRG(fuzztest) 0           ;# ignore --fuzztest option in this case
 478
 479   } elseif {$first=="all"} {
 480
 481     set clist [trd_all_configs]
 482     set patternlist [lrange $patternlist 1 end]
 483     foreach c $clist {
 484       testset_append testset "" $c $patternlist
 485     }
 486
 487   } elseif {[info exists ::testspec($first)]} {
 488     set clist $first
 489     testset_append testset "" $first [lrange $patternlist 1 end]
 490   } elseif { [llength $patternlist]==0 } {
 491     testset_append testset "" veryquick $patternlist
 492   } else {
 493     testset_append testset "" full $patternlist
 494   }
 495   if {$TRG(fuzztest)} {
 496     if {$TRG(platform)=="win"} { error "todo" }
 497     lappend testset [list "" make fuzztest]
 498   }
 499
 500   set testset
 501 }
 502
 503 proc testset_append {listvar build config patternlist} {
 504   upvar $listvar lvar
 505
 506   catch { array unset O }
 507   array set O $::testspec($config)
 508
 509   foreach f $O(-files) {
 510     if {[llength $patternlist]>0} {
 511       set bMatch 0
 512       foreach p $patternlist {
 513         if {[string match $p [file tail $f]]} {
 514           set bMatch 1
 515           break
 516         }
 517       }
 518       if {$bMatch==0} continue
 519     }
 520
 521     if {[file pathtype $f]!="absolute"} {
 522       set f [file join $::testdir $f]
 523     }
 524     lappend lvar [list $build $config $f]
 525   }
 526 }
 527
 528 #--------------------------------------------------------------------------
 529
 530
 531 proc r_write_db {tcl} {
 532   trdb eval { BEGIN EXCLUSIVE }
 533   uplevel $tcl
 534   trdb eval { COMMIT }
 535 }
 536
 537 # Obtain a new job to be run by worker $iJob (an integer). A job is
 538 # returned as a three element list:
 539 #
 540 #    {$build $config $file}
 541 #
 542 proc r_get_next_job {iJob} {
 543   global T
 544
 545   if {($iJob%2)} {
 546     set orderby "ORDER BY priority ASC"
 547   } else {
 548     set orderby "ORDER BY priority DESC"
 549   }
 550
 551   r_write_db {
 552     set f ""
 553     set c ""
 554     trdb eval "
 555       SELECT build, config, filename
 556         FROM script
 557         WHERE state='ready'
 558         $orderby LIMIT 1
 559     " {
 560       set b $build
 561       set c $config
 562       set f $filename
 563     }
 564     if {$f!=""} {
 565       set tm [clock_milliseconds]
 566       set T($iJob) $tm
 567       trdb eval {
 568         UPDATE script SET state='running', time=$tm
 569         WHERE (build, config, filename) = ($b, $c, $f)
 570       }
 571     }
 572   }
 573
 574   if {$f==""} { return "" }
 575   list $b $c $f
 576 }
 577
 578 #rename r_get_next_job r_get_next_job_r
 579 #proc r_get_next_job {iJob} {
 580 #  puts [time { set res [r_get_next_job_r $iJob] }]
 581 #  set res
 582 #}
 583
 584 proc make_new_testset {} {
 585   global TRG
 586
 587   set tests [testset_patternlist $TRG(patternlist)]
 588
 589   if {$TRG(zipvfs)!=""} {
 590     source [file join $TRG(zipvfs) test zipvfs_testrunner.tcl]
 591     set tests [concat $tests [zipvfs_testrunner_testset]]
 592   }
 593
 594   r_write_db {
 595
 596     trdb eval $TRG(schema)
 597     set nJob $TRG(nJob)
 598     set cmdline $TRG(cmdline)
 599     set tm [clock_milliseconds]
 600     trdb eval { REPLACE INTO config VALUES('njob', $nJob ); }
 601     trdb eval { REPLACE INTO config VALUES('cmdline', $cmdline ); }
 602     trdb eval { REPLACE INTO config VALUES('start', $tm ); }
 603
 604     foreach t $tests {
 605       foreach {b c s} $t {}
 606       set slow 0
 607
 608       if {$c!="make" && $c!="build"} {
 609         set fd [open $s]
 610         for {set ii 0} {$ii<100 && ![eof $fd]} {incr ii} {
 611           set line [gets $fd]
 612           if {[string match -nocase *testrunner:* $line]} {
 613             regexp -nocase {.*testrunner:(.*)} $line -> properties
 614             foreach p $properties {
 615               if {$p=="slow"} { set slow 1 }
 616               if {$p=="superslow"} { set slow 2 }
 617             }
 618           }
 619         }
 620         close $fd
 621       }
 622
 623       if {$c=="make" && $b==""} {
 624         # --fuzztest option
 625         set slow 1
 626       }
 627
 628       if {$c=="veryquick"} {
 629         set c ""
 630       }
 631
 632       set state ready
 633       if {$b!="" && $c!="build"} {
 634         set state ""
 635       }
 636
 637       trdb eval {
 638         INSERT INTO script(build, config, filename, slow, state)
 639             VALUES ($b, $c, $s, $slow, $state)
 640       }
 641     }
 642   }
 643 }
 644
 645 proc script_input_ready {fd iJob b c f} {
 646   global TRG
 647   global O
 648   global T
 649
 650   if {[eof $fd]} {
 651     set ::done 1
 652     fconfigure $fd -blocking 1
 653     set state "done"
 654     set rc [catch { close $fd } msg]
 655     if {$rc} {
 656       puts "FAILED: $b $c $f"
 657       set state "failed"
 658     }
 659
 660     set tm [expr [clock_milliseconds] - $T($iJob)]
 661
 662     puts $TRG(log) "### $b ### $c ### $f ${tm}ms ($state)"
 663     puts $TRG(log) [string trim $O($iJob)]
 664
 665     r_write_db {
 666       set output $O($iJob)
 667       trdb eval {
 668         UPDATE script SET output = $output, state=$state, time=$tm
 669         WHERE (build, config, filename) = ($b, $c, $f)
 670       }
 671       if {$state=="done" && $c=="build"} {
 672         trdb eval {
 673           UPDATE script SET state = 'ready' WHERE (build, state)==($b, '')
 674         }
 675       }
 676     }
 677
 678     dirs_freeDir $iJob
 679     launch_some_jobs
 680     incr ::wakeup
 681   } else {
 682     set rc [catch { gets $fd line } res]
 683     if {$rc} {
 684       puts "ERROR $res"
 685     }
 686     if {$res>=0} {
 687       append O($iJob) "$line\n"
 688     }
 689   }
 690
 691 }
 692
 693 proc dirname {ii} {
 694   return "testdir$ii"
 695 }
 696
 697 proc launch_another_job {iJob} {
 698   global TRG
 699   global O
 700   global T
 701
 702   set testfixture [info nameofexec]
 703   set script $TRG(info_script)
 704
 705   set dir [dirname $iJob]
 706   create_or_clear_dir $dir
 707
 708   set O($iJob) ""
 709
 710   set job [r_get_next_job $iJob]
 711   if {$job==""} { return 0 }
 712
 713   foreach {b c f} $job {}
 714
 715   if {$c=="build"} {
 716     set testdir [file dirname $TRG(info_script)]
 717     set srcdir [file dirname $testdir]
 718     set builddir [build_to_dirname $b]
 719     create_or_clear_dir $builddir
 720
 721     if {$b=="Zipvfs"} {
 722       set script [zipvfs_testrunner_script]
 723     } else {
 724       set     cmd [info nameofexec]
 725       lappend cmd [file join $testdir releasetest_data.tcl]
 726       lappend cmd trscript
 727       if {$TRG(platform)=="win"} { lappend cmd -msvc }
 728       lappend cmd $b $srcdir
 729       set script [exec {*}$cmd]
 730     }
 731
 732     set fd [open [file join $builddir $TRG(make)] w]
 733     puts $fd $script
 734     close $fd
 735
 736     puts "Launching build \"$b\" in directory $builddir..."
 737     set target coretestprogs
 738     if {$b=="User-Auth"}  { set target testfixture }
 739
 740     set cmd "$TRG(makecmd) $target"
 741     set dir $builddir
 742
 743   } elseif {$c=="make"} {
 744     if {$b==""} {
 745       if {$f!="fuzztest"} { error "corruption in testrunner.db!" }
 746       # Special case - run [make fuzztest]
 747       set makedir [file dirname $testfixture]
 748       if {$TRG(platform)=="win"} {
 749         error "how?"
 750       } else {
 751         set cmd [list make -C $makedir fuzztest]
 752       }
 753     } else {
 754       set builddir [build_to_dirname $b]
 755       copy_dir $builddir $dir
 756       set cmd "$TRG(makecmd) $f"
 757     }
 758   } else {
 759     if {$b==""} {
 760       set testfixture [info nameofexec]
 761     } else {
 762       set tail testfixture
 763       if {$TRG(platform)=="win"} { set tail testfixture.exe }
 764       set testfixture [file normalize [file join [build_to_dirname $b] $tail]]
 765     }
 766
 767     if {$c=="valgrind"} {
 768       set testfixture "valgrind -v --error-exitcode=1 $testfixture"
 769       set ::env(OMIT_MISUSE) 1
 770     }
 771     set cmd [concat $testfixture [list $script $c $f]]
 772   }
 773
 774   set pwd [pwd]
 775   cd $dir
 776   set fd [open "|$cmd 2>@1" r]
 777   cd $pwd
 778   set pid [pid $fd]
 779
 780   fconfigure $fd -blocking false
 781   fileevent $fd readable [list script_input_ready $fd $iJob $b $c $f]
 782   unset -nocomplain ::env(OMIT_MISUSE)
 783
 784   return 1
 785 }
 786
 787 proc one_line_report {} {
 788   global TRG
 789
 790   set tm [expr [clock_milliseconds] - $TRG(starttime)]
 791   set tm [format "%d" [expr int($tm/1000.0 + 0.5)]]
 792
 793   foreach s {ready running done failed} {
 794     set v($s,build) 0
 795     set v($s,make) 0
 796     set v($s,script) 0
 797   }
 798
 799   r_write_db {
 800     trdb eval {
 801       SELECT state, jobtype, count(*) AS cnt
 802       FROM script
 803       GROUP BY state, jobtype
 804     } {
 805       set v($state,$jobtype) $cnt
 806       if {[info exists t($jobtype)]} {
 807         incr t($jobtype) $cnt
 808       } else {
 809         set t($jobtype) $cnt
 810       }
 811     }
 812   }
 813
 814   set text ""
 815   foreach j [array names t] {
 816     set fin [expr $v(done,$j) + $v(failed,$j)]
 817     lappend text "$j ($fin/$t($j)) f=$v(failed,$j) r=$v(running,$j)"
 818   }
 819
 820   if {[info exists TRG(reportlength)]} {
 821     puts -nonewline "[string repeat " " $TRG(reportlength)]\r"
 822   }
 823   set report "${tm}s: [join $text { }]"
 824   set TRG(reportlength) [string length $report]
 825   if {[string length $report]<80} {
 826     puts -nonewline "$report\r"
 827     flush stdout
 828   } else {
 829     puts $report
 830   }
 831
 832   after $TRG(reporttime) one_line_report
 833 }
 834
 835 proc launch_some_jobs {} {
 836   global TRG
 837   r_write_db {
 838     set nJob [trdb one { SELECT value FROM config WHERE name='njob' }]
 839   }
 840   while {[dirs_nHelper]<$nJob} {
 841     set iDir [dirs_allocDir]
 842     if {0==[launch_another_job $iDir]} {
 843       dirs_freeDir $iDir
 844       break;
 845     }
 846   }
 847 }
 848
 849 proc run_testset {} {
 850   global TRG
 851   set ii 0
 852
 853   set TRG(starttime) [clock_milliseconds]
 854   set TRG(log) [open $TRG(logname) w]
 855
 856   launch_some_jobs
 857     # launch_another_job $ii
 858
 859   one_line_report
 860   while {[dirs_nHelper]>0} {
 861     after 500 {incr ::wakeup}
 862     vwait ::wakeup
 863   }
 864   close $TRG(log)
 865   one_line_report
 866
 867   r_write_db {
 868     set nErr [trdb one {SELECT count(*) FROM script WHERE state='failed'}]
 869     if {$nErr>0} {
 870       puts "$nErr failures:"
 871       trdb eval {
 872         SELECT build, config, filename FROM script WHERE state='failed'
 873       } {
 874         puts "FAILED: $build $config $filename"
 875       }
 876     }
 877   }
 878
 879   puts "\nTest database is $TRG(dbname)"
 880   puts "Test log is $TRG(logname)"
 881 }
 882
 883
 884 sqlite3 trdb $TRG(dbname)
 885 trdb timeout $TRG(timeout)
 886 set tm [lindex [time { make_new_testset }] 0]
 887 if {$TRG(nJob)>1} {
 888   puts "splitting work across $TRG(nJob) cores"
 889 }
 890 puts "built testset in [expr $tm/1000]ms.."
 891 run_testset
 892 trdb close
 893 #puts [pwd]