test/testrunner.tcl

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