969 lines
25 KiB
Tcl
969 lines
25 KiB
Tcl
|
|
set dir [pwd]
|
|
set testdir [file normalize [file dirname $argv0]]
|
|
set saved $argv
|
|
set argv [list]
|
|
source [file join $testdir testrunner_data.tcl]
|
|
source [file join $testdir permutations.test]
|
|
set argv $saved
|
|
cd $dir
|
|
|
|
# This script requires an interpreter that supports [package require sqlite3]
|
|
# to run. If this is not such an intepreter, see if there is a [testfixture]
|
|
# in the current directory. If so, run the command using it. If not,
|
|
# recommend that the user build one.
|
|
#
|
|
proc find_interpreter {} {
|
|
set interpreter [file tail [info nameofexec]]
|
|
set rc [catch { package require sqlite3 }]
|
|
if {$rc} {
|
|
if { [string match -nocase testfixture* $interpreter]==0
|
|
&& [file executable ./testfixture]
|
|
} {
|
|
puts "Failed to find tcl package sqlite3. Restarting with ./testfixture.."
|
|
set status [catch {
|
|
exec ./testfixture [info script] {*}$::argv >@ stdout
|
|
} msg]
|
|
exit $status
|
|
}
|
|
}
|
|
if {$rc} {
|
|
puts stderr "Failed to find tcl package sqlite3"
|
|
puts stderr "Run \"make testfixture\" and then try again..."
|
|
exit 1
|
|
}
|
|
}
|
|
find_interpreter
|
|
|
|
# Usually this script is run by [testfixture]. But it can also be run
|
|
# by a regular [tclsh]. For these cases, emulate the [clock_milliseconds]
|
|
# command.
|
|
if {[info commands clock_milliseconds]==""} {
|
|
proc clock_milliseconds {} {
|
|
clock milliseconds
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------------
|
|
# Usage:
|
|
#
|
|
proc usage {} {
|
|
set a0 [file tail $::argv0]
|
|
|
|
puts stderr [string trim [subst -nocommands {
|
|
Usage:
|
|
$a0 ?SWITCHES? ?PERMUTATION? ?PATTERNS?
|
|
$a0 PERMUTATION FILE
|
|
$a0 njob ?NJOB?
|
|
$a0 status
|
|
|
|
where SWITCHES are:
|
|
--jobs NUMBER-OF-JOBS
|
|
--fuzztest
|
|
--zipvfs ZIPVFS-SOURCE-DIR
|
|
|
|
Interesting values for PERMUTATION are:
|
|
|
|
veryquick - a fast subset of the tcl test scripts. This is the default.
|
|
full - all tcl test scripts.
|
|
all - all tcl test scripts, plus a subset of test scripts rerun
|
|
with various permutations.
|
|
release - full release test with various builds.
|
|
|
|
If no PATTERN arguments are present, all tests specified by the PERMUTATION
|
|
are run. Otherwise, each pattern is interpreted as a glob pattern. Only
|
|
those tcl tests for which the final component of the filename matches at
|
|
least one specified pattern are run.
|
|
|
|
If no PATTERN arguments are present, then various fuzztest, threadtest
|
|
and other tests are run as part of the "release" permutation. These are
|
|
omitted if any PATTERN arguments are specified on the command line.
|
|
|
|
If a PERMUTATION is specified and is followed by the path to a Tcl script
|
|
instead of a list of patterns, then that single Tcl test script is run
|
|
with the specified permutation.
|
|
|
|
The --fuzztest option is ignored if the PERMUTATION is "release". Otherwise,
|
|
if it is present, then "make -C <dir> fuzztest" is run as part of the tests,
|
|
where <dir> is the directory containing the testfixture binary used to
|
|
run the script.
|
|
|
|
The "status" and "njob" commands are designed to be run from the same
|
|
directory as a running testrunner.tcl script that is running tests. The
|
|
"status" command prints a report describing the current state and progress
|
|
of the tests. The "njob" command may be used to query or modify the number
|
|
of sub-processes the test script uses to run tests.
|
|
}]]
|
|
|
|
exit 1
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------
|
|
# Try to estimate a the number of processes to use.
|
|
#
|
|
# Command [guess_number_of_cores] attempts to glean the number of logical
|
|
# cores. Command [default_njob] returns the default value for the --jobs
|
|
# switch.
|
|
#
|
|
proc guess_number_of_cores {} {
|
|
if {[catch {number_of_cores} ret]} {
|
|
set ret 4
|
|
|
|
if {$::tcl_platform(platform)=="windows"} {
|
|
catch { set ret $::env(NUMBER_OF_PROCESSORS) }
|
|
} else {
|
|
if {$::tcl_platform(os)=="Darwin"} {
|
|
set cmd "sysctl -n hw.logicalcpu"
|
|
} else {
|
|
set cmd "nproc"
|
|
}
|
|
catch {
|
|
set fd [open "|$cmd" r]
|
|
set ret [gets $fd]
|
|
close $fd
|
|
set ret [expr $ret]
|
|
}
|
|
}
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
proc default_njob {} {
|
|
set nCore [guess_number_of_cores]
|
|
if {$nCore<=2} {
|
|
set nHelper 1
|
|
} else {
|
|
set nHelper [expr int($nCore*0.5)]
|
|
}
|
|
return $nHelper
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------
|
|
# Setup various default values in the global TRG() array.
|
|
#
|
|
set TRG(dbname) [file normalize testrunner.db]
|
|
set TRG(logname) [file normalize testrunner.log]
|
|
set TRG(build.logname) [file normalize testrunner_build.log]
|
|
set TRG(info_script) [file normalize [info script]]
|
|
set TRG(timeout) 10000 ;# Default busy-timeout for testrunner.db
|
|
set TRG(nJob) [default_njob] ;# Default number of helper processes
|
|
set TRG(patternlist) [list]
|
|
set TRG(cmdline) $argv
|
|
set TRG(reporttime) 2000
|
|
set TRG(fuzztest) 0 ;# is the fuzztest option present.
|
|
set TRG(zipvfs) "" ;# -zipvfs option, if any
|
|
|
|
switch -nocase -glob -- $tcl_platform(os) {
|
|
*darwin* {
|
|
set TRG(platform) osx
|
|
set TRG(make) make.sh
|
|
set TRG(makecmd) "bash make.sh"
|
|
}
|
|
*linux* {
|
|
set TRG(platform) linux
|
|
set TRG(make) make.sh
|
|
set TRG(makecmd) "bash make.sh"
|
|
}
|
|
*win* {
|
|
set TRG(platform) win
|
|
set TRG(make) make.bat
|
|
set TRG(makecmd) make.bat
|
|
}
|
|
default {
|
|
error "cannot determine platform!"
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------
|
|
# The database schema used by the testrunner.db database.
|
|
#
|
|
set TRG(schema) {
|
|
DROP TABLE IF EXISTS script;
|
|
DROP TABLE IF EXISTS config;
|
|
|
|
CREATE TABLE script(
|
|
build TEXT DEFAULT '',
|
|
config TEXT,
|
|
filename TEXT, -- full path to test script
|
|
slow BOOLEAN, -- true if script is "slow"
|
|
state TEXT CHECK( state IN ('', 'ready', 'running', 'done', 'failed') ),
|
|
time INTEGER, -- Time in ms
|
|
output TEXT, -- full output of test script
|
|
priority INTEGER,
|
|
jobtype TEXT CHECK( jobtype IN ('script', 'build', 'make') ),
|
|
PRIMARY KEY(build, config, filename)
|
|
);
|
|
|
|
CREATE TABLE config(
|
|
name TEXT COLLATE nocase PRIMARY KEY,
|
|
value
|
|
) WITHOUT ROWID;
|
|
|
|
CREATE INDEX i1 ON script(state, jobtype);
|
|
CREATE INDEX i2 ON script(state, priority);
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Check if this script is being invoked to run a single file. If so,
|
|
# run it.
|
|
#
|
|
if {[llength $argv]==2
|
|
&& ([lindex $argv 0]=="" || [info exists ::testspec([lindex $argv 0])])
|
|
&& [file exists [lindex $argv 1]]
|
|
} {
|
|
set permutation [lindex $argv 0]
|
|
set script [file normalize [lindex $argv 1]]
|
|
set ::argv [list]
|
|
|
|
set testdir [file dirname $argv0]
|
|
source $::testdir/tester.tcl
|
|
|
|
if {$permutation=="full"} {
|
|
|
|
unset -nocomplain ::G(isquick)
|
|
reset_db
|
|
|
|
} elseif {$permutation!="default" && $permutation!=""} {
|
|
|
|
if {[info exists ::testspec($permutation)]==0} {
|
|
error "no such permutation: $permutation"
|
|
}
|
|
|
|
array set O $::testspec($permutation)
|
|
set ::G(perm:name) $permutation
|
|
set ::G(perm:prefix) $O(-prefix)
|
|
set ::G(isquick) 1
|
|
set ::G(perm:dbconfig) $O(-dbconfig)
|
|
set ::G(perm:presql) $O(-presql)
|
|
|
|
rename finish_test helper_finish_test
|
|
proc finish_test {} "
|
|
uplevel {
|
|
$O(-shutdown)
|
|
}
|
|
helper_finish_test
|
|
"
|
|
|
|
eval $O(-initialize)
|
|
}
|
|
|
|
reset_db
|
|
source $script
|
|
exit
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Check if this is the "njob" command:
|
|
#
|
|
if {([llength $argv]==2 || [llength $argv]==1)
|
|
&& [string compare -nocase njob [lindex $argv 0]]==0
|
|
} {
|
|
sqlite3 mydb $TRG(dbname)
|
|
if {[llength $argv]==2} {
|
|
set param [lindex $argv 1]
|
|
if {[string is integer $param]==0 || $param<1 || $param>128} {
|
|
puts stderr "parameter must be an integer between 1 and 128"
|
|
exit 1
|
|
}
|
|
|
|
mydb eval { REPLACE INTO config VALUES('njob', $param); }
|
|
}
|
|
set res [mydb one { SELECT value FROM config WHERE name='njob' }]
|
|
mydb close
|
|
puts "$res"
|
|
exit
|
|
}
|
|
#--------------------------------------------------------------------------
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Check if this is the "script" command:
|
|
#
|
|
if {[string compare -nocase script [lindex $argv 0]]==0} {
|
|
if {[llength $argv]!=2 && !([llength $argv]==3&&[lindex $argv 1]=="-msvc")} {
|
|
usage
|
|
}
|
|
|
|
set bMsvc [expr ([llength $argv]==3)]
|
|
set config [lindex $argv [expr [llength $argv]-1]]
|
|
|
|
puts [trd_buildscript $config [file dirname $testdir] $bMsvc]
|
|
exit
|
|
}
|
|
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Check if this is the "status" command:
|
|
#
|
|
if {[llength $argv]==1
|
|
&& [string compare -nocase status [lindex $argv 0]]==0
|
|
} {
|
|
|
|
proc display_job {build config filename {tm ""}} {
|
|
if {$config=="build"} {
|
|
set fname "build: $filename"
|
|
set config ""
|
|
} elseif {$config=="make"} {
|
|
set fname "make: $filename"
|
|
set config ""
|
|
} else {
|
|
set fname [file normalize $filename]
|
|
if {[string first $::srcdir $fname]==0} {
|
|
set fname [string range $fname [string length $::srcdir]+1 end]
|
|
}
|
|
}
|
|
set dfname [format %-33s $fname]
|
|
|
|
set dbuild ""
|
|
set dconfig ""
|
|
set dparams ""
|
|
set dtm ""
|
|
if {$build!=""} { set dbuild $build }
|
|
if {$config!="" && $config!="full"} { set dconfig $config }
|
|
if {$dbuild!="" || $dconfig!=""} {
|
|
append dparams "("
|
|
if {$dbuild!=""} {append dparams "build=$dbuild"}
|
|
if {$dbuild!="" && $dconfig!=""} {append dparams " "}
|
|
if {$dconfig!=""} {append dparams "config=$dconfig"}
|
|
append dparams ")"
|
|
set dparams [format %-33s $dparams]
|
|
}
|
|
if {$tm!=""} {
|
|
set dtm "\[${tm}ms\]"
|
|
}
|
|
puts " $dfname $dparams $dtm"
|
|
}
|
|
|
|
sqlite3 mydb $TRG(dbname)
|
|
mydb timeout 1000
|
|
mydb eval BEGIN
|
|
|
|
set cmdline [mydb one { SELECT value FROM config WHERE name='cmdline' }]
|
|
set nJob [mydb one { SELECT value FROM config WHERE name='njob' }]
|
|
|
|
set now [clock_milliseconds]
|
|
set tm [mydb one {
|
|
SELECT
|
|
COALESCE((SELECT value FROM config WHERE name='end'), $now) -
|
|
(SELECT value FROM config WHERE name='start')
|
|
}]
|
|
|
|
set total 0
|
|
foreach s {"" ready running done failed} { set S($s) 0 }
|
|
mydb eval {
|
|
SELECT state, count(*) AS cnt FROM script GROUP BY 1
|
|
} {
|
|
incr S($state) $cnt
|
|
incr total $cnt
|
|
}
|
|
set fin [expr $S(done)+$S(failed)]
|
|
if {$cmdline!=""} {set cmdline " $cmdline"}
|
|
|
|
set f ""
|
|
if {$S(failed)>0} {
|
|
set f "$S(failed) FAILED, "
|
|
}
|
|
puts "Command line: \[testrunner.tcl$cmdline\]"
|
|
puts "Jobs: $nJob"
|
|
puts "Summary: ${tm}ms, ($fin/$total) finished, ${f}$S(running) running"
|
|
|
|
set srcdir [file dirname [file dirname $TRG(info_script)]]
|
|
if {$S(running)>0} {
|
|
puts "Running: "
|
|
mydb eval {
|
|
SELECT build, config, filename, time FROM script WHERE state='running'
|
|
ORDER BY time
|
|
} {
|
|
display_job $build $config $filename [expr $now-$time]
|
|
}
|
|
}
|
|
if {$S(failed)>0} {
|
|
puts "Failures: "
|
|
mydb eval {
|
|
SELECT build, config, filename FROM script WHERE state='failed'
|
|
ORDER BY 3
|
|
} {
|
|
display_job $build $config $filename
|
|
}
|
|
}
|
|
|
|
mydb close
|
|
exit
|
|
}
|
|
|
|
#-------------------------------------------------------------------------
|
|
# Parse the command line.
|
|
#
|
|
for {set ii 0} {$ii < [llength $argv]} {incr ii} {
|
|
set isLast [expr $ii==([llength $argv]-1)]
|
|
set a [lindex $argv $ii]
|
|
set n [string length $a]
|
|
|
|
if {[string range $a 0 0]=="-"} {
|
|
if {($n>2 && [string match "$a*" --jobs]) || $a=="-j"} {
|
|
incr ii
|
|
set TRG(nJob) [lindex $argv $ii]
|
|
if {$isLast} { usage }
|
|
} elseif {($n>2 && [string match "$a*" --fuzztest]) || $a=="-f"} {
|
|
set TRG(fuzztest) 1
|
|
} elseif {($n>2 && [string match "$a*" --zipvfs]) || $a=="-z"} {
|
|
incr ii
|
|
set TRG(zipvfs) [lindex $argv $ii]
|
|
if {$isLast} { usage }
|
|
} else {
|
|
usage
|
|
}
|
|
} else {
|
|
lappend TRG(patternlist) [string map {% *} $a]
|
|
}
|
|
}
|
|
set argv [list]
|
|
|
|
|
|
|
|
# This script runs individual tests - tcl scripts or [make xyz] commands -
|
|
# in directories named "testdir$N", where $N is an integer. This variable
|
|
# contains a list of integers indicating the directories in use.
|
|
#
|
|
# This variable is accessed only via the following commands:
|
|
#
|
|
# dirs_nHelper
|
|
# Return the number of entries currently in the list.
|
|
#
|
|
# dirs_freeDir IDIR
|
|
# Remove value IDIR from the list. It is an error if it is not present.
|
|
#
|
|
# dirs_allocDir
|
|
# Select a value that is not already in the list. Add it to the list
|
|
# and return it.
|
|
#
|
|
set TRG(dirs_in_use) [list]
|
|
|
|
proc dirs_nHelper {} {
|
|
global TRG
|
|
llength $TRG(dirs_in_use)
|
|
}
|
|
proc dirs_freeDir {iDir} {
|
|
global TRG
|
|
set out [list]
|
|
foreach d $TRG(dirs_in_use) {
|
|
if {$iDir!=$d} { lappend out $d }
|
|
}
|
|
if {[llength $out]!=[llength $TRG(dirs_in_use)]-1} {
|
|
error "dirs_freeDir could not find $iDir"
|
|
}
|
|
set TRG(dirs_in_use) $out
|
|
}
|
|
proc dirs_allocDir {} {
|
|
global TRG
|
|
array set inuse [list]
|
|
foreach d $TRG(dirs_in_use) {
|
|
set inuse($d) 1
|
|
}
|
|
for {set iRet 0} {[info exists inuse($iRet)]} {incr iRet} { }
|
|
lappend TRG(dirs_in_use) $iRet
|
|
return $iRet
|
|
}
|
|
|
|
# Check that directory $dir exists. If it does not, create it. If
|
|
# it does, delete its contents.
|
|
#
|
|
proc create_or_clear_dir {dir} {
|
|
set dir [file normalize $dir]
|
|
catch { file mkdir $dir }
|
|
foreach f [glob -nocomplain [file join $dir *]] {
|
|
catch { file delete -force $f }
|
|
}
|
|
}
|
|
|
|
proc copy_dir {from to} {
|
|
foreach f [glob -nocomplain [file join $from *]] {
|
|
catch { file copy -force $f $to }
|
|
}
|
|
}
|
|
|
|
proc build_to_dirname {bname} {
|
|
set fold [string tolower [string map {- _} $bname]]
|
|
return "testrunner_build_$fold"
|
|
}
|
|
|
|
#-------------------------------------------------------------------------
|
|
# Return a list of tests to run. Each element of the list is itself a
|
|
# list of two elements - the name of a permuations.test configuration
|
|
# followed by the full path to a test script. i.e.:
|
|
#
|
|
# {BUILD CONFIG FILENAME} {BUILD CONFIG FILENAME} ...
|
|
#
|
|
proc testset_patternlist {patternlist} {
|
|
global TRG
|
|
|
|
set testset [list] ;# return value
|
|
|
|
set first [lindex $patternlist 0]
|
|
|
|
if {$first=="sdevtest" || $first=="mdevtest"} {
|
|
set CONFIGS(sdevtest) {All-Debug All-Sanitize}
|
|
set CONFIGS(mdevtest) {All-Debug All-O0}
|
|
|
|
set patternlist [lrange $patternlist 1 end]
|
|
|
|
foreach b $CONFIGS($first) {
|
|
lappend testset [list $b build testfixture]
|
|
lappend testset [list $b make fuzztest]
|
|
testset_append testset $b veryquick $patternlist
|
|
}
|
|
} elseif {$first=="release"} {
|
|
set platform $::TRG(platform)
|
|
|
|
set patternlist [lrange $patternlist 1 end]
|
|
foreach b [trd_builds $platform] {
|
|
foreach c [trd_configs $platform $b] {
|
|
testset_append testset $b $c $patternlist
|
|
}
|
|
|
|
if {[llength $patternlist]==0 || $b=="User-Auth"} {
|
|
set target testfixture
|
|
} else {
|
|
set target coretestprogs
|
|
}
|
|
lappend testset [list $b build $target]
|
|
}
|
|
|
|
if {[llength $patternlist]==0} {
|
|
foreach b [trd_builds $platform] {
|
|
foreach e [trd_extras $platform $b] {
|
|
lappend testset [list $b make $e]
|
|
}
|
|
}
|
|
}
|
|
|
|
set TRG(fuzztest) 0 ;# ignore --fuzztest option in this case
|
|
|
|
} elseif {$first=="all"} {
|
|
|
|
set clist [trd_all_configs]
|
|
set patternlist [lrange $patternlist 1 end]
|
|
foreach c $clist {
|
|
testset_append testset "" $c $patternlist
|
|
}
|
|
|
|
} elseif {[info exists ::testspec($first)]} {
|
|
set clist $first
|
|
testset_append testset "" $first [lrange $patternlist 1 end]
|
|
} elseif { [llength $patternlist]==0 } {
|
|
testset_append testset "" veryquick $patternlist
|
|
} else {
|
|
testset_append testset "" full $patternlist
|
|
}
|
|
if {$TRG(fuzztest)} {
|
|
if {$TRG(platform)=="win"} { error "todo" }
|
|
lappend testset [list "" make fuzztest]
|
|
}
|
|
|
|
set testset
|
|
}
|
|
|
|
proc testset_append {listvar build config patternlist} {
|
|
upvar $listvar lvar
|
|
|
|
catch { array unset O }
|
|
array set O $::testspec($config)
|
|
|
|
foreach f $O(-files) {
|
|
if {[llength $patternlist]>0} {
|
|
set bMatch 0
|
|
foreach p $patternlist {
|
|
if {[string match $p [file tail $f]]} {
|
|
set bMatch 1
|
|
break
|
|
}
|
|
}
|
|
if {$bMatch==0} continue
|
|
}
|
|
|
|
if {[file pathtype $f]!="absolute"} {
|
|
set f [file join $::testdir $f]
|
|
}
|
|
lappend lvar [list $build $config $f]
|
|
}
|
|
}
|
|
|
|
#--------------------------------------------------------------------------
|
|
|
|
|
|
proc r_write_db {tcl} {
|
|
trdb eval { BEGIN EXCLUSIVE }
|
|
uplevel $tcl
|
|
trdb eval { COMMIT }
|
|
}
|
|
|
|
# Obtain a new job to be run by worker $iJob (an integer). A job is
|
|
# returned as a three element list:
|
|
#
|
|
# {$build $config $file}
|
|
#
|
|
proc r_get_next_job {iJob} {
|
|
global T
|
|
|
|
if {($iJob%2)} {
|
|
set orderby "ORDER BY priority ASC"
|
|
} else {
|
|
set orderby "ORDER BY priority DESC"
|
|
}
|
|
|
|
r_write_db {
|
|
set f ""
|
|
set c ""
|
|
trdb eval "
|
|
SELECT build, config, filename
|
|
FROM script
|
|
WHERE state='ready'
|
|
$orderby LIMIT 1
|
|
" {
|
|
set b $build
|
|
set c $config
|
|
set f $filename
|
|
}
|
|
if {$f!=""} {
|
|
set tm [clock_milliseconds]
|
|
set T($iJob) $tm
|
|
trdb eval {
|
|
UPDATE script SET state='running', time=$tm
|
|
WHERE (build, config, filename) = ($b, $c, $f)
|
|
}
|
|
}
|
|
}
|
|
|
|
if {$f==""} { return "" }
|
|
list $b $c $f
|
|
}
|
|
|
|
#rename r_get_next_job r_get_next_job_r
|
|
#proc r_get_next_job {iJob} {
|
|
# puts [time { set res [r_get_next_job_r $iJob] }]
|
|
# set res
|
|
#}
|
|
|
|
proc make_new_testset {} {
|
|
global TRG
|
|
|
|
set tests [testset_patternlist $TRG(patternlist)]
|
|
|
|
if {$TRG(zipvfs)!=""} {
|
|
source [file join $TRG(zipvfs) test zipvfs_testrunner.tcl]
|
|
set tests [concat $tests [zipvfs_testrunner_testset]]
|
|
}
|
|
|
|
r_write_db {
|
|
|
|
trdb eval $TRG(schema)
|
|
set nJob $TRG(nJob)
|
|
set cmdline $TRG(cmdline)
|
|
set tm [clock_milliseconds]
|
|
trdb eval { REPLACE INTO config VALUES('njob', $nJob ); }
|
|
trdb eval { REPLACE INTO config VALUES('cmdline', $cmdline ); }
|
|
trdb eval { REPLACE INTO config VALUES('start', $tm ); }
|
|
|
|
foreach t $tests {
|
|
foreach {b c s} $t {}
|
|
set slow 0
|
|
|
|
if {$c!="make" && $c!="build"} {
|
|
set fd [open $s]
|
|
for {set ii 0} {$ii<100 && ![eof $fd]} {incr ii} {
|
|
set line [gets $fd]
|
|
if {[string match -nocase *testrunner:* $line]} {
|
|
regexp -nocase {.*testrunner:(.*)} $line -> properties
|
|
foreach p $properties {
|
|
if {$p=="slow"} { set slow 1 }
|
|
if {$p=="superslow"} { set slow 2 }
|
|
}
|
|
}
|
|
}
|
|
close $fd
|
|
}
|
|
|
|
if {$c=="make" && $b==""} {
|
|
# --fuzztest option
|
|
set slow 1
|
|
}
|
|
|
|
if {$c=="veryquick"} {
|
|
set c ""
|
|
}
|
|
|
|
set state ready
|
|
if {$b!="" && $c!="build"} {
|
|
set state ""
|
|
}
|
|
|
|
set priority [expr {$slow*2}]
|
|
if {$c=="make"} { incr priority 3 }
|
|
if {$c=="build"} { incr priority 1 }
|
|
|
|
if {$c=="make" || $c=="build"} {
|
|
set jobtype $c
|
|
} else {
|
|
set jobtype "script"
|
|
}
|
|
|
|
trdb eval {
|
|
INSERT INTO script
|
|
(build, config, filename, slow, state, priority, jobtype)
|
|
VALUES ($b, $c, $s, $slow, $state, $priority, $jobtype)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc script_input_ready {fd iJob b c f} {
|
|
global TRG
|
|
global O
|
|
global T
|
|
|
|
if {[eof $fd]} {
|
|
set ::done 1
|
|
fconfigure $fd -blocking 1
|
|
set state "done"
|
|
set rc [catch { close $fd } msg]
|
|
if {$rc} {
|
|
puts "FAILED: $b $c $f"
|
|
set state "failed"
|
|
}
|
|
|
|
set tm [expr [clock_milliseconds] - $T($iJob)]
|
|
|
|
puts $TRG(log) "### $b ### $c ### $f ${tm}ms ($state)"
|
|
puts $TRG(log) [string trim $O($iJob)]
|
|
|
|
r_write_db {
|
|
set output $O($iJob)
|
|
trdb eval {
|
|
UPDATE script SET output = $output, state=$state, time=$tm
|
|
WHERE (build, config, filename) = ($b, $c, $f)
|
|
}
|
|
if {$state=="done" && $c=="build"} {
|
|
trdb eval {
|
|
UPDATE script SET state = 'ready' WHERE (build, state)==($b, '')
|
|
}
|
|
}
|
|
}
|
|
|
|
dirs_freeDir $iJob
|
|
launch_some_jobs
|
|
incr ::wakeup
|
|
} else {
|
|
set rc [catch { gets $fd line } res]
|
|
if {$rc} {
|
|
puts "ERROR $res"
|
|
}
|
|
if {$res>=0} {
|
|
append O($iJob) "$line\n"
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
proc dirname {ii} {
|
|
return "testdir$ii"
|
|
}
|
|
|
|
proc launch_another_job {iJob} {
|
|
global TRG
|
|
global O
|
|
global T
|
|
|
|
set testfixture [info nameofexec]
|
|
set script $TRG(info_script)
|
|
|
|
set dir [dirname $iJob]
|
|
create_or_clear_dir $dir
|
|
|
|
set O($iJob) ""
|
|
|
|
set job [r_get_next_job $iJob]
|
|
if {$job==""} { return 0 }
|
|
|
|
foreach {b c f} $job {}
|
|
|
|
if {$c=="build"} {
|
|
set testdir [file dirname $TRG(info_script)]
|
|
set srcdir [file dirname $testdir]
|
|
set builddir [build_to_dirname $b]
|
|
create_or_clear_dir $builddir
|
|
|
|
if {$b=="Zipvfs"} {
|
|
set script [zipvfs_testrunner_script]
|
|
} else {
|
|
set script [trd_buildscript $b $srcdir [expr {$TRG(platform)=="win"}]]
|
|
}
|
|
|
|
set fd [open [file join $builddir $TRG(make)] w]
|
|
puts $fd $script
|
|
close $fd
|
|
|
|
puts "Launching build \"$b\" in directory $builddir..."
|
|
set target coretestprogs
|
|
if {$b=="User-Auth"} { set target testfixture }
|
|
|
|
set cmd "$TRG(makecmd) $target"
|
|
set dir $builddir
|
|
|
|
} elseif {$c=="make"} {
|
|
if {$b==""} {
|
|
if {$f!="fuzztest"} { error "corruption in testrunner.db!" }
|
|
# Special case - run [make fuzztest]
|
|
set makedir [file dirname $testfixture]
|
|
if {$TRG(platform)=="win"} {
|
|
error "how?"
|
|
} else {
|
|
set cmd [list make -C $makedir fuzztest]
|
|
}
|
|
} else {
|
|
set builddir [build_to_dirname $b]
|
|
copy_dir $builddir $dir
|
|
set cmd "$TRG(makecmd) $f"
|
|
}
|
|
} else {
|
|
if {$b==""} {
|
|
set testfixture [info nameofexec]
|
|
} else {
|
|
set tail testfixture
|
|
if {$TRG(platform)=="win"} { set tail testfixture.exe }
|
|
set testfixture [file normalize [file join [build_to_dirname $b] $tail]]
|
|
}
|
|
|
|
if {$c=="valgrind"} {
|
|
set testfixture "valgrind -v --error-exitcode=1 $testfixture"
|
|
set ::env(OMIT_MISUSE) 1
|
|
}
|
|
set cmd [concat $testfixture [list $script $c $f]]
|
|
}
|
|
|
|
set pwd [pwd]
|
|
cd $dir
|
|
set fd [open "|$cmd 2>@1" r]
|
|
cd $pwd
|
|
set pid [pid $fd]
|
|
|
|
fconfigure $fd -blocking false
|
|
fileevent $fd readable [list script_input_ready $fd $iJob $b $c $f]
|
|
unset -nocomplain ::env(OMIT_MISUSE)
|
|
|
|
return 1
|
|
}
|
|
|
|
proc one_line_report {} {
|
|
global TRG
|
|
|
|
set tm [expr [clock_milliseconds] - $TRG(starttime)]
|
|
set tm [format "%d" [expr int($tm/1000.0 + 0.5)]]
|
|
|
|
foreach s {ready running done failed} {
|
|
set v($s,build) 0
|
|
set v($s,make) 0
|
|
set v($s,script) 0
|
|
}
|
|
|
|
r_write_db {
|
|
trdb eval {
|
|
SELECT state, jobtype, count(*) AS cnt
|
|
FROM script
|
|
GROUP BY state, jobtype
|
|
} {
|
|
set v($state,$jobtype) $cnt
|
|
if {[info exists t($jobtype)]} {
|
|
incr t($jobtype) $cnt
|
|
} else {
|
|
set t($jobtype) $cnt
|
|
}
|
|
}
|
|
}
|
|
|
|
set text ""
|
|
foreach j [array names t] {
|
|
set fin [expr $v(done,$j) + $v(failed,$j)]
|
|
lappend text "$j ($fin/$t($j)) f=$v(failed,$j) r=$v(running,$j)"
|
|
}
|
|
|
|
if {[info exists TRG(reportlength)]} {
|
|
puts -nonewline "[string repeat " " $TRG(reportlength)]\r"
|
|
}
|
|
set report "${tm}s: [join $text { }]"
|
|
set TRG(reportlength) [string length $report]
|
|
if {[string length $report]<80} {
|
|
puts -nonewline "$report\r"
|
|
flush stdout
|
|
} else {
|
|
puts $report
|
|
}
|
|
|
|
after $TRG(reporttime) one_line_report
|
|
}
|
|
|
|
proc launch_some_jobs {} {
|
|
global TRG
|
|
r_write_db {
|
|
set nJob [trdb one { SELECT value FROM config WHERE name='njob' }]
|
|
}
|
|
while {[dirs_nHelper]<$nJob} {
|
|
set iDir [dirs_allocDir]
|
|
if {0==[launch_another_job $iDir]} {
|
|
dirs_freeDir $iDir
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
|
|
proc run_testset {} {
|
|
global TRG
|
|
set ii 0
|
|
|
|
set TRG(starttime) [clock_milliseconds]
|
|
set TRG(log) [open $TRG(logname) w]
|
|
|
|
launch_some_jobs
|
|
# launch_another_job $ii
|
|
|
|
one_line_report
|
|
while {[dirs_nHelper]>0} {
|
|
after 500 {incr ::wakeup}
|
|
vwait ::wakeup
|
|
}
|
|
close $TRG(log)
|
|
one_line_report
|
|
|
|
r_write_db {
|
|
set tm [clock_milliseconds]
|
|
trdb eval { REPLACE INTO config VALUES('end', $tm ); }
|
|
set nErr [trdb one {SELECT count(*) FROM script WHERE state='failed'}]
|
|
if {$nErr>0} {
|
|
puts "$nErr failures:"
|
|
trdb eval {
|
|
SELECT build, config, filename FROM script WHERE state='failed'
|
|
} {
|
|
puts "FAILED: $build $config $filename"
|
|
}
|
|
}
|
|
}
|
|
|
|
puts "\nTest database is $TRG(dbname)"
|
|
puts "Test log is $TRG(logname)"
|
|
}
|
|
|
|
|
|
sqlite3 trdb $TRG(dbname)
|
|
trdb timeout $TRG(timeout)
|
|
set tm [lindex [time { make_new_testset }] 0]
|
|
if {$TRG(nJob)>1} {
|
|
puts "splitting work across $TRG(nJob) cores"
|
|
}
|
|
puts "built testset in [expr $tm/1000]ms.."
|
|
run_testset
|
|
trdb close
|
|
#puts [pwd]
|