Adding upstream version 3.45.1.upstream/3.45.1

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 1092 insertions, 0 deletions

diff --git a/test/testrunner.tcl b/test/testrunner.tcl
new file mode 100644
index 0000000..0c704da
--- /dev/null
+++ b/test/testrunner.tcl
@@ -0,0 +1,1092 @@
+
+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:
+    --buildonly
+    --dryrun
+    --jobs NUMBER-OF-JOBS
+    --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 "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
+set TRG(buildonly) 0                ;# True if --buildonly option 
+set TRG(dryrun) 0                   ;# True if --dryrun option 
+
+switch -nocase -glob -- $tcl_platform(os) {
+  *darwin* {
+    set TRG(platform)    osx
+    set TRG(make)        make.sh
+    set TRG(makecmd)     "bash make.sh"
+    set TRG(testfixture) testfixture
+    set TRG(run)         run.sh
+    set TRG(runcmd)      "bash run.sh"
+  }
+  *linux* {
+    set TRG(platform)    linux
+    set TRG(make)        make.sh
+    set TRG(makecmd)     "bash make.sh"
+    set TRG(testfixture) testfixture
+    set TRG(run)         run.sh
+    set TRG(runcmd)      "bash run.sh"
+  }
+  *win* {
+    set TRG(platform)    win
+    set TRG(make)        make.bat
+    set TRG(makecmd)     make.bat
+    set TRG(testfixture) testfixture.exe
+    set TRG(run)         run.bat
+    set TRG(runcmd)      "run.bat"
+  }
+  default {
+    error "cannot determine platform!"
+  }
+} 
+#-------------------------------------------------------------------------
+
+#-------------------------------------------------------------------------
+# The database schema used by the testrunner.db database.
+#
+set TRG(schema) {
+  DROP TABLE IF EXISTS jobs;
+  DROP TABLE IF EXISTS config;
+
+  /*
+  ** This table contains one row for each job that testrunner.tcl must run
+  ** before the entire test run is finished.
+  **
+  ** jobid:
+  **   Unique identifier for each job. Must be a +ve non-zero number.
+  **
+  ** displaytype:
+  **   3 or 4 letter mnemonic for the class of tests this belongs to e.g.
+  **   "fuzz", "tcl", "make" etc.
+  **
+  ** displayname:
+  **   Name/description of job. For display purposes.
+  **
+  ** build:
+  **   If the job requires a make.bat/make.sh make wrapper (i.e. to build
+  **   something), the name of the build configuration it uses. See 
+  **   testrunner_data.tcl for a list of build configs. e.g. "Win32-MemDebug".
+  **
+  ** dirname:
+  **   If the job should use a well-known directory name for its 
+  **   sub-directory instead of an anonymous "testdir[1234...]" sub-dir
+  **   that is deleted after the job is finished.
+  **
+  ** cmd:
+  **   Bash or batch script to run the job.
+  **
+  ** depid:
+  **   The jobid value of a job that this job depends on. This job may not
+  **   be run before its depid job has finished successfully.
+  **
+  ** priority:
+  **   Higher values run first. Sometimes.
+  */
+  CREATE TABLE jobs(
+    /* Fields populated when db is initialized */
+    jobid INTEGER PRIMARY KEY,          -- id to identify job
+    displaytype TEXT NOT NULL,          -- Type of test (for one line report)
+    displayname TEXT NOT NULL,          -- Human readable job name
+    build TEXT NOT NULL DEFAULT '',     -- make.sh/make.bat file request, if any
+    dirname TEXT NOT NULL DEFAULT '',   -- directory name, if required
+    cmd TEXT NOT NULL,                  -- shell command to run
+    depid INTEGER,                      -- identifier of dependency (or '')
+    priority INTEGER NOT NULL,          -- higher priority jobs may run earlier
+  
+    /* Fields updated as jobs run */
+    starttime INTEGER, 
+    endtime INTEGER,
+    state TEXT CHECK( state IN ('', 'ready', 'running', 'done', 'failed') ),
+    output TEXT
+  );
+
+  CREATE TABLE config(
+    name TEXT COLLATE nocase PRIMARY KEY,
+    value 
+  ) WITHOUT ROWID;
+
+  CREATE INDEX i1 ON jobs(state, priority);
+  CREATE INDEX i2 ON jobs(depid);
+}
+#-------------------------------------------------------------------------
+
+#--------------------------------------------------------------------------
+# 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 {jobdict {tm ""}} {
+    array set job $jobdict
+
+    set dfname [format %-60s $job(displayname)]
+
+    set dtm ""
+    if {$tm!=""} { set dtm "\[[expr {$tm-$job(starttime)}]ms\]" }
+    puts "  $dfname $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 jobs 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 * FROM jobs WHERE state='running' ORDER BY starttime 
+    } job {
+      display_job [array get job] $now
+    }
+  }
+  if {$S(failed)>0} {
+    puts "Failures: "
+    mydb eval {
+      SELECT * FROM jobs WHERE state='failed' ORDER BY starttime
+    } job {
+      display_job [array get job]
+    }
+  }
+ 
+  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*" --zipvfs]) || $a=="-z"} {
+      incr ii
+      set TRG(zipvfs) [file normalize [lindex $argv $ii]]
+      if {$isLast} { usage }
+    } elseif {($n>2 && [string match "$a*" --buildonly]) || $a=="-b"} {
+      set TRG(buildonly) 1
+    } elseif {($n>2 && [string match "$a*" --dryrun]) || $a=="-d"} {
+      set TRG(dryrun) 1
+    } 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 build_to_dirname {bname} {
+  set fold [string tolower [string map {- _} $bname]]
+  return "testrunner_build_$fold"
+}
+
+#-------------------------------------------------------------------------
+
+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"
+  }
+
+  set ret [list]
+
+  r_write_db {
+    set query "
+      SELECT * FROM jobs AS j WHERE state='ready' $orderby LIMIT 1
+    " 
+    trdb eval $query job {
+      set tm [clock_milliseconds]
+      set T($iJob) $tm
+      set jobid $job(jobid)
+
+      trdb eval {
+        UPDATE jobs SET starttime=$tm, state='running' WHERE jobid=$jobid
+      }
+
+      set ret [array get job]
+    }
+  }
+
+  return $ret
+}
+
+#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
+#}
+
+# Usage:
+#
+#   add_job OPTION ARG OPTION ARG...
+#
+# where available OPTIONS are:
+#
+#   -displaytype
+#   -displayname
+#   -build
+#   -dirname     
+#   -cmd 
+#   -depid 
+#   -priority 
+#
+# Returns the jobid value for the new job.
+# 
+proc add_job {args} {
+
+  set options {
+      -displaytype -displayname -build -dirname 
+      -cmd -depid -priority
+  }
+
+  # Set default values of options.
+  set A(-dirname) ""
+  set A(-depid)   ""
+  set A(-priority) 0
+  set A(-build)   ""
+
+  array set A $args
+
+  # Check all required options are present. And that no extras are present.
+  foreach o $options {
+    if {[info exists A($o)]==0} { error "missing required option $o" }
+  }
+  foreach o [array names A] {
+    if {[lsearch -exact $options $o]<0} { error "unrecognized option: $o" }
+  }
+
+  set state ""
+  if {$A(-depid)==""} { set state ready }
+
+  trdb eval {
+    INSERT INTO jobs(
+      displaytype, displayname, build, dirname, cmd, depid, priority,
+      state
+    ) VALUES (
+      $A(-displaytype),
+      $A(-displayname),
+      $A(-build),
+      $A(-dirname),
+      $A(-cmd),
+      $A(-depid),
+      $A(-priority),
+      $state
+    )
+  }
+
+  trdb last_insert_rowid
+}
+
+proc add_tcl_jobs {build config patternlist} {
+  global TRG
+
+  set topdir [file dirname $::testdir]
+  set testrunner_tcl [file normalize [info script]]
+
+  if {$build==""} {
+    set testfixture [info nameofexec]
+  } else {
+    set testfixture [file join [lindex $build 1] $TRG(testfixture)]
+  }
+  if {[lindex $build 2]=="Valgrind"} {
+    set setvar "export OMIT_MISUSE=1\n"
+    set testfixture "${setvar}valgrind -v --error-exitcode=1 $testfixture"
+  }
+
+  # The ::testspec array is populated by permutations.test
+  foreach f [dict get $::testspec($config) -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] }
+    set f [file normalize $f]
+
+    set displayname [string map [list $topdir/ {}] $f]
+    if {$config=="full" || $config=="veryquick"} {
+      set cmd "$testfixture $f"
+    } else {
+      set cmd "$testfixture $testrunner_tcl $config $f"
+      set displayname "config=$config $displayname"
+    }
+    if {$build!=""} {
+      set displayname "[lindex $build 2] $displayname"
+    }
+
+    set lProp [trd_test_script_properties $f]
+    set priority 0
+    if {[lsearch $lProp slow]>=0} { set priority 2 }
+    if {[lsearch $lProp superslow]>=0} { set priority 4 }
+
+    add_job                            \
+        -displaytype tcl               \
+        -displayname $displayname      \
+        -cmd $cmd                      \
+        -depid [lindex $build 0]       \
+        -priority $priority
+
+  }
+}
+
+proc add_build_job {buildname target} {
+  global TRG
+
+  set dirname "[string tolower [string map {- _} $buildname]]_$target"
+  set dirname "testrunner_bld_$dirname"
+
+  set id [add_job                                \
+    -displaytype bld                             \
+    -displayname "Build $buildname ($target)"    \
+    -dirname $dirname                            \
+    -build $buildname                            \
+    -cmd  "$TRG(makecmd) $target"                \
+    -priority 3
+  ]
+
+  list $id [file normalize $dirname] $buildname
+}
+
+proc add_make_job {bld target} {
+  global TRG
+
+  if {$TRG(platform)=="win"} {
+    set path [string map {/ \\} [lindex $bld 1]]
+    set cmd "xcopy /S $path\\* ."
+  } else {
+    set cmd "cp -r [lindex $bld 1]/* ."
+  }
+  append cmd "\n$TRG(makecmd) $target"
+
+  add_job                                       \
+    -displaytype make                           \
+    -displayname "[lindex $bld 2] make $target" \
+    -cmd $cmd                                   \
+    -depid [lindex $bld 0]                      \
+    -priority 1
+}
+
+proc add_fuzztest_jobs {buildname} {
+
+  foreach {interpreter scripts} [trd_fuzztest_data] {
+    set subcmd [lrange $interpreter 1 end]
+    set interpreter [lindex $interpreter 0]
+
+    set bld [add_build_job $buildname $interpreter]
+    foreach {depid dirname displayname} $bld {}
+
+    foreach s $scripts {
+
+      # Fuzz data files fuzzdata1.db and fuzzdata2.db are larger than
+      # the others. So ensure that these are run as a higher priority.
+      set tail [file tail $s]
+      if {$tail=="fuzzdata1.db" || $tail=="fuzzdata2.db"} {
+        set priority 5
+      } else {
+        set priority 1
+      }
+
+      add_job                                                   \
+        -displaytype fuzz                                       \
+        -displayname "$buildname $interpreter $tail"            \
+        -depid $depid                                           \
+        -cmd "[file join $dirname $interpreter] $subcmd $s"     \
+        -priority $priority
+    }
+  }
+}
+
+proc add_zipvfs_jobs {} {
+  global TRG
+  source [file join $TRG(zipvfs) test zipvfs_testrunner.tcl]
+
+  set bld [add_build_job Zipvfs $TRG(testfixture)]
+  foreach s [zipvfs_testrunner_files] {
+    set cmd "[file join [lindex $bld 1] $TRG(testfixture)] $s"
+    add_job                                  \
+        -displaytype tcl                     \
+        -displayname "Zipvfs [file tail $s]" \
+        -cmd $cmd                            \
+        -depid [lindex $bld 0]
+  }
+
+  set ::env(SQLITE_TEST_DIR) $::testdir
+}
+
+# Used to add jobs for "mdevtest" and "sdevtest".
+#
+proc add_devtest_jobs {lBld patternlist} {
+  global TRG
+
+  foreach b $lBld {
+    set bld [add_build_job $b $TRG(testfixture)]
+    add_tcl_jobs $bld veryquick $patternlist
+    if {$patternlist==""} {
+      add_fuzztest_jobs $b
+    }
+  }
+}
+
+proc add_jobs_from_cmdline {patternlist} {
+  global TRG
+
+  if {$TRG(zipvfs)!=""} {
+    add_zipvfs_jobs
+    if {[llength $patternlist]==0} return
+  }
+
+  if {[llength $patternlist]==0} {
+    set patternlist [list veryquick]
+  }
+
+  set first [lindex $patternlist 0]
+  switch -- $first {
+    all {
+      set patternlist [lrange $patternlist 1 end]
+      set clist [trd_all_configs]
+      foreach c $clist {
+        add_tcl_jobs "" $c $patternlist
+      }
+    }
+
+    mdevtest {
+      add_devtest_jobs {All-O0 All-Debug} [lrange $patternlist 1 end]
+    }
+
+    sdevtest {
+      add_devtest_jobs {All-Sanitize All-Debug} [lrange $patternlist 1 end]
+    }
+
+    release {
+      set patternlist [lrange $patternlist 1 end]
+      foreach b [trd_builds $TRG(platform)] {
+        set bld [add_build_job $b $TRG(testfixture)]
+        foreach c [trd_configs $TRG(platform) $b] {
+          add_tcl_jobs $bld $c $patternlist
+        }
+
+        if {$patternlist==""} {
+          foreach e [trd_extras $TRG(platform) $b] {
+            if {$e=="fuzztest"} {
+              add_fuzztest_jobs $b
+            } else {
+              add_make_job $bld $e
+            }
+          }
+        }
+      }
+    }
+
+    default {
+      if {[info exists ::testspec($first)]} {
+        add_tcl_jobs "" $first [lrange $patternlist 1 end]
+      } else {
+        add_tcl_jobs "" full $patternlist
+      }
+    }
+  }
+}
+
+proc make_new_testset {} {
+  global TRG
+
+  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 ); }
+
+    add_jobs_from_cmdline $TRG(patternlist)
+  }
+
+}
+
+proc mark_job_as_finished {jobid output state endtm} {
+  r_write_db {
+    trdb eval {
+      UPDATE jobs 
+        SET output=$output, state=$state, endtime=$endtm
+        WHERE jobid=$jobid;
+      UPDATE jobs SET state='ready' WHERE depid=$jobid;
+    }
+  }
+}
+
+proc script_input_ready {fd iJob jobid} {
+  global TRG
+  global O
+  global T
+
+  if {[eof $fd]} {
+    trdb eval { SELECT * FROM jobs WHERE jobid=$jobid } job {}
+
+    # If this job specified a directory name, then delete the run.sh/run.bat
+    # file from it before continuing. This is because the contents of this
+    # directory might be copied by some other job, and we don't want to copy
+    # the run.sh file in this case.
+    if {$job(dirname)!=""} {
+      file delete -force [file join $job(dirname) $TRG(run)]
+    }
+
+    set ::done 1
+    fconfigure $fd -blocking 1
+    set state "done"
+    set rc [catch { close $fd } msg]
+    if {$rc} { 
+      if {[info exists TRG(reportlength)]} {
+        puts -nonewline "[string repeat " " $TRG(reportlength)]\r"
+      }
+      puts "FAILED: $job(displayname) ($iJob)"
+      set state "failed" 
+    }
+
+    set tm [clock_milliseconds]
+    set jobtm [expr {$tm - $job(starttime)}]
+
+    puts $TRG(log) "### $job(displayname) ${jobtm}ms ($state)"
+    puts $TRG(log) [string trim $O($iJob)]
+
+    mark_job_as_finished $jobid $O($iJob) $state $tm
+
+    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 O($iJob) ""
+  
+  set jobdict [r_get_next_job $iJob]
+  if {$jobdict==""} { return 0 }
+  array set job $jobdict
+
+  set dir $job(dirname)
+  if {$dir==""} { set dir [dirname $iJob] }
+  create_or_clear_dir $dir
+
+  if {$job(build)!=""} {
+    set srcdir [file dirname $::testdir]
+    if {$job(build)=="Zipvfs"} {
+      set script [zipvfs_testrunner_script]
+    } else {
+      set bWin [expr {$TRG(platform)=="win"}]
+      set script [trd_buildscript $job(build) $srcdir $bWin]
+    }
+    set fd [open [file join $dir $TRG(make)] w]
+    puts $fd $script
+    close $fd
+  }
+
+  if { $TRG(dryrun) } {
+
+    mark_job_as_finished $job(jobid) "" done 0
+    dirs_freeDir $iJob
+    if {$job(build)!=""} {
+      puts $TRG(log) "(cd $dir ; $job(cmd) )"
+    } else {
+      puts $TRG(log) "$job(cmd)"
+    }
+
+  } else {
+    set pwd [pwd]
+    cd $dir
+    set fd [open $TRG(run) w]
+    puts $fd $job(cmd) 
+    close $fd
+    set fd [open "|$TRG(runcmd) 2>@1" r]
+    cd $pwd
+
+    fconfigure $fd -blocking false
+    fileevent $fd readable [list script_input_ready $fd $iJob $job(jobid)]
+  }
+
+  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)]]
+
+  r_write_db {
+    trdb eval { 
+      SELECT displaytype, state, count(*) AS cnt 
+      FROM jobs 
+      GROUP BY 1, 2 
+    } {
+      set v($state,$displaytype) $cnt
+      incr t($displaytype) $cnt
+    }
+  }
+
+  set text ""
+  foreach j [lsort [array names t]] {
+    foreach k {done failed running} { incr v($k,$j) 0 }
+    set fin [expr $v(done,$j) + $v(failed,$j)]
+    lappend text "${j}($fin/$t($j))"
+    if {$v(failed,$j)>0} {
+      lappend text "f$v(failed,$j)"
+    }
+    if {$v(running,$j)>0} {
+      lappend text "r$v(running,$j)"
+    }
+  }
+
+  if {[info exists TRG(reportlength)]} {
+    puts -nonewline "[string repeat " " $TRG(reportlength)]\r"
+  }
+  set report "${tm} [join $text { }]"
+  set TRG(reportlength) [string length $report]
+  if {[string length $report]<100} {
+    puts -nonewline "$report\r"
+    flush stdout
+  } else {
+    puts $report
+  }
+
+  after $TRG(reporttime) one_line_report
+}
+
+proc launch_some_jobs {} {
+  global TRG
+  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
+
+  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 jobs WHERE state='failed'}]
+    if {$nErr>0} {
+      puts "$nErr failures:"
+      trdb eval {
+        SELECT displayname FROM jobs WHERE state='failed'
+      } {
+        puts "FAILED: $displayname"
+      }
+    }
+  }
+
+  puts "\nTest database is $TRG(dbname)"
+  puts "Test log is $TRG(logname)"
+}
+
+# Handle the --buildonly option, if it was specified.
+#
+proc handle_buildonly {} {
+  global TRG
+  if {$TRG(buildonly)} {
+    r_write_db {
+      trdb eval { DELETE FROM jobs WHERE displaytype!='bld' }
+    }
+  }
+}
+
+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) jobs"
+}
+puts "built testset in [expr $tm/1000]ms.."
+
+handle_buildonly
+run_testset
+trdb close
+#puts [pwd]