niceSOFT/sqlite: Official Git mirror of the SQLite source tree

test/testrunner.tcl
1 968 строк56 KB
drh
Fix a 32-bit integer overflow in sqlite3changegroup_change_blob() that
26 май 2026, 17:23
26 май 2026, 17:23600eb44
#!/bin/sh
# Script to runs tests for SQLite.  Run with option "help" for more info. \
exec tclsh "$0" "$@"

set dir [pwd]
set testdir [file normalize [file dirname $argv0]]
set saved $argv
set argv [list]
source [file join $testdir testrunner_data.tcl]

# Estimated amount of work required by displaytype, relative to 'tcl'
#
set estwork(tcl)    1
set estwork(fuzz)   22
set estwork(bld)    66
set estwork(make)   102

set estworkfile [file join $testdir testrunner_estwork.tcl]
if {[file readable $estworkfile]} {
  source $estworkfile
}
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 {} {
  global dir
  set interpreter [file tail [info nameofexec]]
  set rc [catch { package require sqlite3 }]
  if {$rc} {
    if {[file readable pkgIndex.tcl] && [catch {source pkgIndex.tcl}]==0} {
      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 [trd_get_bin_name testfixture] [info script] {*}$::argv >@ stdout
      } msg]
      exit $status
    }
  }
  if {$rc} {
    puts "Cannot find tcl package sqlite3: Trying to build it now..."
    if {$::tcl_platform(platform) eq "windows"} {
      set bat [open make-tcl-extension.bat w]
      puts $bat "nmake /f Makefile.msc tclextension"
      close $bat
      catch {exec -ignorestderr -- make-tcl-extension.bat}
    } else {
      catch {exec make tclextension}
    }
    if {[file readable pkgIndex.tcl] && [catch {source pkgIndex.tcl}]==0} {
      set rc [catch { package require sqlite3 }]
    }
    if {$rc==0} {
      puts "The SQLite tcl extension was successfully built and loaded."
      puts "Run \"make tclextension-install\" to avoid having to rebuild\
            it in the future."
    } else {
      puts "Unable to build the SQLite tcl extension"
    }
  }
  if {$rc} {
    puts stderr "Cannot find a working instance of the SQLite tcl extension."
    puts stderr "Run \"make tclextension\" or \"make testfixture\" and\
                 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 [string trim [subst -nocommands {
Usage: 
    $a0 ?SWITCHES? ?PERMUTATION? ?PATTERNS?
    $a0 PERMUTATION FILE
    $a0 errors ?-v|--verbose? ?-s|--summary? ?PATTERN?
    $a0 help
    $a0 joblist ?PATTERN?
    $a0 njob ?NJOB?
    $a0 retest
    $a0 script ?-msvc? CONFIG
    $a0 status ?-d SECS? ?--cls?
    $a0 halt
    $a0 estwork

  where SWITCHES are:
    --buildonly              Build test exes but do not run tests
    --cases DISPLAYNAME      Only run test that match DISPLAYNAME
    --config CONFIGS         Only use configs on comma-separate list CONFIGS
    --dryrun                 Write what would have happened to testrunner.log
    --explain                Write summary to stdout
    --fuzzdb FILENAME        Additional external fuzzcheck database
    --jobs NUM               Run tests using NUM separate processes
    --omit CONFIGS           Omit configs on comma-separated list CONFIGS
    --status                 Show the full "status" report while running
    --stop-on-coredump       Stop running if any test segfaults
    --stop-on-error          Stop running after any reported error
    --zipvfs ZIPVFSDIR       ZIPVFS source directory

Special values for PERMUTATION include:

    list      - show allowed PERMUTATION arguments.
    mdevtest  - tests recommended prior to normal development check-ins.
    devtest   - alias for "mdevtest"
    release   - full release test with various builds.
    c         - tests in test/c directory only.
    sdevtest  - like mdevtest but using ASAN and UBSAN.
    all       - all tcl test scripts, plus a subset of test scripts rerun
                with various permutations.
    full      - all tcl test scripts.
    veryquick - a fast subset of the tcl test scripts. This is the default.

The interpreter that runs this script can be an ordinary "tclsh" as long
as "package require sqlite3" works, or it can be "testfixture".

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.  The glob wildcard '*' is prepended
to the pattern if it does not start with '^' and appended to every
pattern that does not end with '$'.  If PATTERN begins with "~", then it
is an anti-pattern that only matches tests that do not match PATTERN.
Tests or only run if they match one or more patterns and match no
anti-patterns.

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.  Use the "-d N" option to have the status display clear the
screen and repeat every N seconds.  The "njob" command may be used to query
or modify the number of sub-processes the test script uses to run tests.

The "script" command outputs the script used to build a configuration.
Add the "-msvc" option for a Windows-compatible script. For a list of
available configurations enter "$a0 script help".

The "errors" commands shows the output of tests that failed in the
most recent run.  Complete output is shown if the -v or --verbose options
are used.  Otherwise, an attempt is made to minimize the output to show
only the parts that contain the error messages.  The --summary option just
shows the jobs that failed.  If PATTERN are provided, the error information
is only provided for jobs that match PATTERN.

The "retest" command reruns tests that failed or were never completed
by a prior invocation of testrunner.tcl.

Full documentation here: https://sqlite.org/src/doc/trunk/doc/testrunner.md
  }]]

  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) eq "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 {} {
  global env
  if {[info exists env(NJOB)] && $env(NJOB)>=1} {
    return $env(NJOB)
  }
  set nCore [guess_number_of_cores]
  if {$nCore<=2} {
    set nHelper 1
  } else {
    set nHelper [expr int($nCore*0.8)]
    if {$nHelper>20} {set nHelper 20}
  }
  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(config) {}                  ;# Only build the named configurations
set TRG(omitconfig) {}              ;# Do not build these configurations
set TRG(dryrun) 0                   ;# True if --dryrun option 
set TRG(explain) 0                  ;# True for the --explain option
set TRG(stopOnError) 0              ;# Stop running at first failure
set TRG(stopOnCore) 0               ;# Stop on a core-dump
set TRG(fullstatus) 0               ;# Full "status" report while running
set TRG(case) {}                    ;# Only run cases matching this GLOB pattern

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(shell)       sqlite3
    set TRG(run)         run.sh
    set TRG(runcmd)      "bash run.sh"
  }
  *linux* - MSYS_NT* - MINGW64_NT* - MINGW32_NT* {
    set TRG(platform)    linux
    set TRG(make)        make.sh
    set TRG(makecmd)     "bash make.sh"
    set TRG(testfixture) testfixture
    set TRG(shell)       sqlite3
    set TRG(run)         run.sh
    set TRG(runcmd)      "bash run.sh"
  }
  *openbsd* {
    set TRG(platform)    linux
    set TRG(make)        make.sh
    set TRG(makecmd)     "sh make.sh"
    set TRG(testfixture) testfixture
    set TRG(shell)       sqlite3
    set TRG(run)         run.sh
    set TRG(runcmd)      "sh run.sh"
  }
  *win* {
    set TRG(platform)    win
    set TRG(make)        make.bat
    set TRG(makecmd)     "call make.bat"
    set TRG(testfixture) testfixture.exe
    set TRG(shell)       sqlite3.exe
    set TRG(run)         run.bat
    set TRG(runcmd)      "run.bat"
    if {"unix" eq $tcl_platform(platform)} {
      # Presumably cygwin. This block gets testrunner.tcl started on
      # Cygwin but then downstream tests all fail, at least in part
      # because of the discrepancies in build target names which need
      # .exe on cygwin but not on other Unix-like platforms.
      set TRG(platform)  cygwin
      set TRG(make)      make.sh
      set TRG(makecmd)   "bash make.sh"
      set TRG(testfixture) testfixture
      set TRG(shell)       sqlite3
      set TRG(run)       run.sh
      set TRG(runcmd)    "bash run.sh"
    }
  }
  default {
    puts "tcl_platform(os)=$::tcl_platform(os)"
    error "cannot determine platform!"
  }
}
set TRG(testfixture-fullpath) [file join $dir $TRG(testfixture)]
set TRG(interp) [info nameofexec]
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# 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,                  -- Start time (milliseconds since 1970)
    endtime INTEGER,                    -- End time
    span INTEGER,                       -- Total run-time in milliseconds
    estwork INTEGER,                    -- Estimated amount of work
    estkey TEXT,                        -- Key used to compute estwork
    state TEXT CHECK( state IN ('','ready','running','done','failed','omit','halt') ),
    ntest INT,                          -- Number of test cases run
    nerr INT,                           -- Number of errors reported
    svers TEXT,                         -- Reported SQLite version
    pltfm TEXT,                         -- Host platform reported
    output TEXT,                        -- test output
    cwd TEXT                            -- working directory for test
  );

  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<0 || $param>128} {
      puts stderr "parameter must be an integer between 0 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 "halt" command:
#
if {[llength $argv]==1
 && [string compare -nocase halt [lindex $argv 0]]==0
} {
  sqlite3 mydb $TRG(dbname)
  mydb eval {UPDATE jobs SET state='halt' WHERE state IN ('ready','')}
  mydb close
  exit
}
#--------------------------------------------------------------------------

#--------------------------------------------------------------------------
# Check if this is the "estwork" command:
#
# Generate (on standard output) a set of estwork() values based on the lastest
# test case, that can be used to replace the test/testrunner_estwork.tcl file.
#
if {[llength $argv]==1
 && [string compare -nocase estwork [lindex $argv 0]]==0
} {
  sqlite3 mydb $TRG(dbname)
  set njob [mydb one {SELECT count(*) FROM jobs WHERE state='done'}]
  if {$njob<1000} {
    puts "Too few completed jobs to do a work estimate."
    puts "Have $njob but not need at least 1000."
    mydb close
    exit 1
  }
  set badjobs [mydb one {SELECT count(*) FROM jobs WHERE state<>'done'}]
  if {$badjobs} {
    puts "Database contains $badjobs incomplete jobs."
    mydb close
    exit 1
  }
  set half [mydb one {SELECT count(*)/2 FROM jobs WHERE displaytype='tcl'}]
  set scale [mydb one {SELECT span FROM jobs WHERE displaytype='tcl'
                        ORDER BY span LIMIT 1 OFFSET $half}]
  mydb eval {
     SELECT estkey, CAST(avg(span)/$scale AS INT) AS cost
       FROM jobs
      GROUP BY estkey
      HAVING cost>=2
  } {
    set estwork($estkey) $cost
  }
  set avgtcl [mydb one {SELECT avg(span) FROM jobs WHERE displaytype='tcl'}]
  set estwork(tcl) 1
  foreach type {bld fuzz make} {
    set avg [mydb one {SELECT avg(span) FROM jobs WHERE displaytype=$type}]
    if {$avg!=""} {
      set estwork($type) [expr {int($avg/$avgtcl)}]
    }
  }
  mydb close
  puts "# Estimated relative cost of various jobs, based on the \"estkey\" field."
  puts "# Computed by the \"test/testrunner.tcl estwork\" command."
  puts "#"
  foreach key [lsort [array names estwork]] {
    puts "set [list estwork($key)] $estwork($key)"
  }
  exit
}
#--------------------------------------------------------------------------

#--------------------------------------------------------------------------
# Check if this is the "help" command:
#
if {[string compare -nocase help [lindex $argv 0]]==0} {
  usage
}
#--------------------------------------------------------------------------

#--------------------------------------------------------------------------
# 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
}

# Compute an elapse time string MM:SS or HH:MM:SS based on the
# number of milliseconds in the argument.
#
proc elapsetime {ms} {
  if {$ms==""} {set ms 0}
  set s [expr {int(($ms+500.0)*0.001)}]
  set hr [expr {$s/3600}]
  set mn [expr {($s/60)%60}]
  set sc [expr {$s%60}]
  if {$hr>0} {
    return [format %02d:%02d:%02d $hr $mn $sc]
  } else {
    return [format %02d:%02d $mn $sc]
  }
}

# Helper routine for show_status
#
proc display_job {jobdict {tm ""}} {
  array set job $jobdict
  if {[string length $job(displayname)]>65} {
    set dfname [format %.65s... $job(displayname)]
  } else {
    set dfname [format %-68s $job(displayname)]
  }
  set dtm ""
  if {$tm!=""} {
    set dtm [expr {$tm-$job(starttime)}]
    set dtm [format %8s [elapsetime $dtm]]
  } else {
    set dtm [format %8s ""]
  }
  puts "  $dfname $dtm"
}

# This procedure shows the "status" page.  It uses the database
# connect passed in as the "db" parameter.  If the "cls" parameter
# is true, then VT100 escape codes are used to format the display.
#
proc show_status {db cls} {
  global TRG
  $db eval BEGIN
  if {[catch {
    set cmdline [$db one { SELECT value FROM config WHERE name='cmdline' }]
    set nJob [$db one { SELECT value FROM config WHERE name='njob' }]
  } msg]} {
    if {$cls} {puts "\033\[H\033\[2J"}
    puts "Cannot read database: $TRG(dbname)"
    return
  }
  set now [clock_milliseconds]
  set tm [$db one {
    SELECT 
      COALESCE((SELECT value FROM config WHERE name='end'), $now) -
      (SELECT value FROM config WHERE name='start')
  }]

  set totalw 0
  foreach s {"" ready running done failed omit} { set S($s) 0; set W($s) 0; }
  set workpending 0
  $db eval {
    SELECT state, count(*) AS cnt, sum(estwork) AS ew FROM jobs GROUP BY 1
  } {
    incr S($state) $cnt
    incr W($state) $ew
    incr totalw $ew
  }
  set nt 0
  set ne 0
  $db eval {
    SELECT sum(ntest) AS nt, sum(nerr) AS ne FROM jobs HAVING nt>0
  } break
  set fin [expr $W(done)+$W(failed)+$W(omit)]
  if {$cmdline!=""} {set cmdline " $cmdline"}

  if {$cls} {
    # Move the cursor to the top-left corner.  Each iteration will simply
    # overwrite.
    puts -nonewline "\033\[H"
    flush stdout
  }
  puts [format %-79.79s "Command: \[testrunner.tcl$cmdline\]"]
  puts [format %-79.79s "Summary: [elapsetime $tm], $fin/$totalw jobs,\
                         $ne errors, $nt tests"]

  set srcdir [file dirname [file dirname $TRG(info_script)]]
  set line "Running: $S(running) (max: $nJob)"
  if {$S(running)>0 && [set pct [expr {int(($fin*100.0)/$totalw)}]]>=4} {
    set tmleft [expr {($tm/double($fin))*($totalw-$fin)}]
    if {$tmleft<0.02*$tm} {
      set tmleft [expr {$tm*0.02}]
    }
    set etc " ETC [elapsetime $tmleft]"
    if {[string length $line]+[string length $etc]<80} {
      append line $etc
    }
    # append line " $pct%"
  }
  puts [format %-79.79s $line]
  if {$S(running)>0} {
    $db eval {
      SELECT * FROM jobs WHERE state='running' ORDER BY starttime 
    } job {
      display_job [array get job] $now
    }
  }
  if {$S(failed)>0} {
    # $toshow is the number of failures to report.  In $cls mode,
    # status tries to limit the number of failure reported so that
    # the status display does not overflow a 24-line terminal.  It will
    # always show at least the most recent 4 failures, even if an overflow
    # is needed.  No limit is imposed for a status within $cls.
    #
    if {$cls && $S(failed)>18-$S(running)} {
      set toshow [expr {18-$S(running)}]
      if {$toshow<4} {set toshow 4}
      set shown " (must recent $toshow shown)"
    } else {
      set toshow $S(failed)
      set shown ""
    }
    puts [format %-79s  "Failed:  $S(failed) $shown"]
    $db eval {
      SELECT * FROM jobs WHERE state='failed'
       ORDER BY endtime DESC LIMIT $toshow
    } job {
      display_job [array get job]
    }
    set nOmit [$db one {SELECT count(*) FROM jobs WHERE state='omit'}]
    if {$nOmit} {
      puts [format %-79s "  ... $nOmit jobs omitted due to failures"]
    }
  }
  if {$cls} {
    # Clear everything else to the bottom of the screen
    puts -nonewline "\033\[0J"
    flush stdout
  }
  $db eval COMMIT
}

  

#--------------------------------------------------------------------------
# Check if this is the "status" command:
#
if {[llength $argv]>=1 
 && [string compare -nocase status [lindex $argv 0]]==0 
} {
  set delay 0
  set cls 0
  for {set ii 1} {$ii<[llength $argv]} {incr ii} {
    set a0 [lindex $argv $ii]
    if {$a0=="-d" && $ii+1<[llength $argv]} {
      incr ii
      set delay [lindex $argv $ii]
      if {![string is integer -strict $delay]} {
        puts "Argument to -d should be an integer"
        exit 1
      }
    } elseif {$a0=="-cls" || $a0=="--cls"} {
      set cls 1
    } else {
      puts "unknown option: \"$a0\""
      exit 1
    }
  }

  set once 1
  while {![file readable $TRG(dbname)]} {
    if {$delay==0} {
      puts "Database missing: $TRG(dbname)"
      exit
    }
    if {$once} {
      set once 0
      puts "Waiting for testing to start...."
      flush stdout
    }
    after [expr {$delay*1000}]
  }
  sqlite3 mydb $TRG(dbname)
  mydb timeout 2000

  # Clear the whole screen initially.
  #
  if {$delay>0 || $cls} {puts -nonewline "\033\[2J"}

  while {1} {
    show_status mydb [expr {$delay>0 || $cls}]
    if {$delay<=0} break
    after [expr {$delay*1000}]
  }
  mydb close
  exit
}

#--------------------------------------------------------------------------
# Check if this is the "joblist" command:
#
if {[llength $argv]>=1 
 && [string compare -nocase "joblist" [lindex $argv 0]]==0 
} {
  set pattern {}
  for {set ii 1} {$ii<[llength $argv]} {incr ii} {
    set a0 [lindex $argv $ii]
    if {$pattern==""} {
      set pattern [string trim $a0 *]
    } else {
      puts "unknown option: \"$a0\""
      exit 1
    }
  }
  set SQL {SELECT displaytype, displayname, state FROM jobs}
  if {$pattern!=""} {
    regsub -all {[^a-zA-Z0-9*.-/]} $pattern ? pattern
    set pattern [string tolower $pattern]
    append SQL \
       " WHERE lower(concat(state,' ',displaytype,' ',displayname)) GLOB '*$pattern*'"
  }
  append SQL " ORDER BY starttime"

  if {![file readable $TRG(dbname)]} {
    puts "Database missing: $TRG(dbname)"
    exit
  }
  sqlite3 mydb $TRG(dbname)
  mydb timeout 2000

  mydb eval $SQL {
    set label UNKNOWN
    switch -- $state {
      ready {set label READY}
      done {set label DONE}
      failed {set label FAILED}
      omit {set label OMIT}
      running {set label RUNNING}
    }
    puts [format {%-7s %-5s %s} $label $displaytype $displayname]
  }
  mydb close
  exit
}

# Scan the output of all jobs looking for the summary lines that
# report the number of test cases and the number of errors.
# Aggregate these numbers and return them.
#
proc aggregate_test_counts {db} {
  set ne 0
  set nt 0
  $db eval {SELECT sum(nerr) AS ne, sum(ntest) as nt FROM jobs} break
  return [list $ne $nt]
}

#--------------------------------------------------------------------------
# Check if this is the "errors" command:
#
if {[llength $argv]>=1
 && ([string compare -nocase errors [lindex $argv 0]]==0 ||
     [string match err* [lindex $argv 0]]==1)
} {
  set verbose 0
  set pattern {}
  set summary 0
  for {set ii 1} {$ii<[llength $argv]} {incr ii} {
    set a0 [lindex $argv $ii]
    if {$a0=="-v" || $a0=="--verbose" || $a0=="-verbose"} {
      set verbose 1
    } elseif {$a0=="-s" || $a0=="--summary" || $a0=="-summary"} {
      set summary 1
    } elseif {$pattern==""} {
      set pattern *[string trim $a0 *]*
    } else {
      puts "unknown option: \"$a0\"".  Use --help for more info."
      exit 1
    }
  }
  set cnt 0
  sqlite3 mydb $TRG(dbname)
  mydb timeout 5000
  if {$summary} {
    set sql "SELECT displayname FROM jobs WHERE state='failed'"
  } else {
    set sql "SELECT displaytype, displayname, output FROM jobs \
              WHERE state='failed'"
  }
  if {$pattern!=""} {
    regsub -all {[^a-zA-Z0-9*/ ?]} $pattern . pattern
    append sql " AND displayname GLOB '$pattern'"
  }
  mydb eval $sql {
    if {$summary} {
      puts "FAILED: $displayname"
      continue
    }
    puts "**** $displayname ****"
    if {$verbose || $displaytype!="tcl"} {
      puts $output
    } else {
      foreach line [split $output \n] {
        if {[string match {!*} $line] || [string match *failed* $line]} {
          puts $line
        }
      }
    }
    incr cnt
  }
  if {$pattern==""} {
    set summary [aggregate_test_counts mydb]
    mydb close
    puts "Total [lindex $summary 0] errors out of [lindex $summary 1] tests"
  } else {
    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*" --config]) || $a=="-c"} {
      incr ii
      set TRG(config) [lindex $argv $ii]
    } elseif {($n>2 && [string match "$a*" --dryrun]) || $a=="-d"} {
      set TRG(dryrun) 1
    } elseif {($n>2 && [string match "$a*" --explain]) || $a=="-e"} {
      set TRG(explain) 1
    } elseif {$n>2 && [string match "$a*" --omit]} {
      incr ii
      set TRG(omitconfig) [lindex $argv $ii]
    } elseif {$n>2 && [string match "$a*" --cases]} {
      incr ii
      set TRG(case) [lindex $argv $ii]
    } elseif {$n>2 && [string match "$a*" --fuzzdb]} {
      incr ii
      set env(FUZZDB) [lindex $argv $ii]
    } elseif {[string match "$a*" --stop-on-error]} {
      set TRG(stopOnError) 1
    } elseif {[string match "$a*" --stop-on-coredump]} {
      set TRG(stopOnCore) 1
    } elseif {[string match "$a*" --status]} {
      if {$tcl_platform(platform) eq "windows"} {
        puts stdout \
"The --status option is not available on Windows. A suggested work-around"
        puts stdout \
"is to run the following command in a separate window:\n"
        puts stdout "   [info nameofexe] $argv0 status -d 2\n"
      } else {
        set TRG(fullstatus) 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)

      set cwd $job(dirname) 
      if {$cwd==""} {
        set cwd [dirname $iJob]
      }

      trdb eval {
        UPDATE jobs 
        SET starttime=$tm, state='running', cwd=$cwd 
        WHERE jobid=$jobid
      }

      set ret [array get job]
    }
  }

  return $ret
}

# 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} {
  global estwork

  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 }
  set type $A(-displaytype)
  set displayname $A(-displayname)
  switch $type {
    tcl {
      set ek [file tail [lindex $displayname end]]
    }
    bld {
      set ek [lindex $displayname end]
    }
    fuzz {
      set ek [lrange $displayname 1 2]
    }
    make {
      set ek [lindex $displayname end]
    }
  }
  if {[info exists estwork($ek)]} {
    set ew $estwork($ek)
  } else {
    set ew $estwork($type)
  }

  trdb eval {
    INSERT INTO jobs(
      displaytype, displayname, build, dirname, cmd, depid, priority,
      estwork, estkey, state
    ) VALUES (
      $type,
      $A(-displayname),
      $A(-build),
      $A(-dirname),
      $A(-cmd),
      $A(-depid),
      $A(-priority),
      $ew,
      $ek,
      $state
    )
  }

  trdb last_insert_rowid
}

# Look to see if $jobcmd matches any of the glob patterns given in
# $patternlist.  Return true if there is a match.  Return false
# if no match is seen.
#
# An empty patternlist matches everything
#
# Entries of patternlist that begin with "~" mean "match anything that
# does not match the following pattern".  For example, a patternlist
# of {fuzzcheck ~san} will match "fuzzcheck" but not "fuzzcheck-asan".
#
proc job_matches_any_pattern {patternlist jobcmd} {
  set bMatch 0
  set bMiss 0
  if {[llength $patternlist]==0} {return 1}
  foreach p $patternlist {
    if {[string index $p 0] eq "~"} {
      set p [string range $p 1 end]
      set not 1
    } else {
      set not 0
    }
    set p [string trim $p *]
    if {[string index $p 0]=="^"} {
      set p [string range $p 1 end]
    } else {
      set p "*$p"
    }
    if {[string index $p end]=="\$"} {
      set p [string range $p 0 end-1]
    } else {
      set p "$p*"
    }
    if {$not} {
      if {[string match $p $jobcmd]} {return 0}
    } else {
      if {[string match $p $jobcmd]} {
        set bMatch 1
      } else {
        set bMiss 1
      }
    }
  }
  if {!$bMiss} {
    set bMatch 1
  }
  return $bMatch
}
       

# Argument $build is either an empty string, or else a list of length 3 
# describing the job to build testfixture. In the usual form:
#
#    {ID DIRNAME DISPLAYNAME}
# 
# e.g    
#
#    {1 /home/user/sqlite/test/testrunner_bld_xyz All-Debug}
# 
proc add_tcl_jobs {build config patternlist {shelldepid ""}} {
  global TRG
  set ntcljob 0

  set topdir [file dirname $::testdir]
  set testrunner_tcl [file normalize [info script]]

  if {$build==""} {
    set testfixture $TRG(interp)
  } 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 {![job_matches_any_pattern $patternlist "$config [file tail $f]"]} {
      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 }

    set depid [lindex $build 0]
    if {$shelldepid!="" && [lsearch $lProp shell]>=0} { set depid $shelldepid }

    incr ntcljob
    add_job                            \
        -displaytype tcl               \
        -displayname $displayname      \
        -cmd $cmd                      \
        -depid $depid                  \
        -priority $priority
  }
  if {$ntcljob==0 && [llength $build]>0} {
    set bldid [lindex $build 0]
    trdb eval {DELETE FROM jobs WHERE rowid=$bldid}
  }
}

proc add_build_job {buildname target {postcmd ""} {depid ""}} {
  global TRG

  set dirname "[string tolower [string map {- _} $buildname]]_$target"
  set dirname "testrunner_bld_$dirname"

  set cmd "$TRG(makecmd) $target"
  if {$postcmd!=""} {
    append cmd "\n"
    append cmd $postcmd
  }

  set id [add_job                                \
    -displaytype bld                             \
    -displayname "Build $buildname ($target)"    \
    -dirname $dirname                            \
    -build $buildname                            \
    -cmd  $cmd                                   \
    -depid $depid                                \
    -priority 3
  ]

  list $id [file normalize $dirname] $buildname
}

proc add_shell_build_job {buildname dirname depid} {
  global TRG

  if {$TRG(platform)=="win"} {
    set path [string map {/ \\} "$dirname/"]
    set copycmd "xcopy $TRG(shell) $path"
  } else {
    set copycmd "cp $TRG(shell) $dirname/"
  }

  return [
    add_build_job $buildname $TRG(shell) $copycmd $depid
  ]
}


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 patternlist} {
  global env TRG
  # puts buildname=$buildname

  foreach {interpreter scripts} [trd_fuzztest_data $buildname] {
    set bldDone 0
    set subcmd [lrange $interpreter 1 end]
    set interpreter [lindex $interpreter 0]

    # For fuzzcheck-asan and fuzzcheck-ubsan, break up some
    # fuzzdata files into multiple slices, for improved
    # concurrency.
    #
    if {[string match *fuzzcheck-*san $interpreter]} {
      set newscripts {}
      foreach s $scripts {
        if {[string match {*fuzzdata[12].db} $s]
            && ![string match slice $s]} {
          set N 6
          for {set i 0} {$i<$N} {incr i} {
            lappend newscripts [list --slice $i $N $s]
          }
        } else {
          lappend newscripts $s
        }
      }
      set scripts $newscripts
    }

    if {[string match fuzzcheck* $interpreter]
     && [info exists env(FUZZDB)]
     && [file readable $env(FUZZDB)]
     && $buildname ne "Windows-Win32Heap"
     && $buildname ne "Windows-Memdebug"
    } {
      set TRG(FUZZDB) $env(FUZZDB)
      set fname [file normalize $env(FUZZDB)]
      set N [expr {([file size $fname]+4999999)/5000000}]
      for {set i 0} {$i<$N} {incr i} {
        lappend scripts [list --slice $i $N $fname]
      }
    }

    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.
      if {[llength $s]==1} {
        set tail [file tail $s]
      } else {
        set fname [lindex $s end]
        set tail [lrange $s 0 end-1]
        lappend tail [file tail $fname]
      }
      if {![job_matches_any_pattern $patternlist "$interpreter $tail"]} {
        continue
      }
      if {!$bldDone} {
        set bld [add_build_job $buildname $interpreter]
        foreach {depid dirname displayname} $bld {}
        set bldDone 1
      }
      if {[string match ?-slice* $tail]} {
        set priority 15
      } elseif {$tail=="fuzzdata1.db"
          || $tail=="fuzzdata2.db"
          || $tail=="fuzzdata8.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 SHELL
    add_fuzztest_jobs $b $patternlist

    if {[trdb one "SELECT EXISTS (SELECT 1 FROM jobs WHERE depid='SHELL')"]} {
      set sbld [add_shell_build_job $b [lindex $bld 1] [lindex $bld 0]]
      set sbldid [lindex $sbld 0]
      trdb eval {
        UPDATE jobs SET depid=$sbldid WHERE depid='SHELL'
      }
    }

  }
}

# Check to ensure that TRG(interp) is a full-blown "testfixture" and
# not just a "tclsh".
#
# The value of TRG(interp) defaults to whatever interpreter is running
# this script, which might be either tclsh or testfixture.  If tclsh is
# running this script, change $TRG(interp) to be an instance of testfixture.
# If no testfixture exists in the directory from which this script is run,
# attempt to build one.
#
# Do not return unless $TRG(interp) is a valid testfixture.  If unable
# to find and/or construct one, abort with an error message.
#
proc must_be_testfixture {} {
  global TRG
  if {[lsearch [info commands] sqlite3_soft_heap_limit]<0} {
    if {![file exec $TRG(testfixture-fullpath)]} {
      puts "make testfixture"
      catch {exec make testfixture >@stdout 2>@stderr}
    }
    if {![file exec $TRG(testfixture-fullpath)]} {
      puts "Requires testfixture, and I was unable to build it."
      exit 1
    }
    set TRG(interp) $TRG(testfixture-fullpath)
  }
}

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 {
      must_be_testfixture
      set patternlist [lrange $patternlist 1 end]
      set clist [trd_all_configs]
      foreach c $clist {
        add_tcl_jobs "" $c $patternlist
      }
    }

    devtest -
    mdevtest {
      set config_set {
        All-O0
        All-Debug
      }
      add_devtest_jobs $config_set [lrange $patternlist 1 end]
    }

    sdevtest {
      set config_set {
        All-Sanitize
        All-Debug
      }
      add_devtest_jobs $config_set [lrange $patternlist 1 end]
    }

    release {
      set patternlist [lrange $patternlist 1 end]
      foreach b [trd_builds $TRG(platform)] {
        if {$TRG(config)!="" && ![regexp "\\y$b\\y" $TRG(config)]} continue
        if {[regexp "\\y$b\\y" $TRG(omitconfig)]} continue
        set bld [add_build_job $b $TRG(testfixture)]
        foreach c [trd_configs $TRG(platform) $b] {
          add_tcl_jobs $bld $c $patternlist SHELL
        }

        foreach e [trd_extras $TRG(platform) $b] {
          if {$e=="fuzztest"} {
            add_fuzztest_jobs $b $patternlist
          } elseif {[job_matches_any_pattern $patternlist $e]} {
            add_make_job $bld $e
          }
        }

        if {[trdb one "SELECT EXISTS(SELECT 1
                                       FROM jobs WHERE depid='SHELL')"]} {
          set sbld [add_shell_build_job $b [lindex $bld 1] [lindex $bld 0]]
          set sbldid [lindex $sbld 0]
          trdb eval {
            UPDATE jobs SET depid=$sbldid WHERE depid='SHELL'
          }
        }
      }
    }

    c {
      set patternlist [lrange $patternlist 1 end]
      foreach b [trd_builds $TRG(platform)] {
        add_c_jobs $b $patternlist
      }
    }

    list {
      set allperm [array names ::testspec]
      lappend allperm all devtest mdevtest sdevtest release list
      puts "Allowed values for the PERMUTATION argument: [lsort $allperm]"
      exit 0
    }

    retest {
      # no-op
    }

    default {
      must_be_testfixture
      if {[info exists ::testspec($first)]} {
        add_tcl_jobs "" $first [lrange $patternlist 1 end]
      } else {
        add_tcl_jobs "" full $patternlist
      }
    }
  }

  # If the "--case DISPLAYNAME" option appears on the command-line, mark
  # all tests other than DISPLAYNAME as 'omit'.
  #
  if {[info exists TRG(case)] && $TRG(case) ne ""} {
    set jid [trdb one {
      SELECT jobid FROM jobs WHERE displayname GLOB $TRG(case)
    }]
    if {$jid eq ""} {
      puts "ERROR: No jobs match \"$TRG(case)\"."
      puts "The argument to --cases must GLOB match the jobs.displayname column"
      puts "of the testrunner.db database."
      trdb eval {UPDATE jobs SET state='omit'}
    } else {
      trdb eval {
        WITH RECURSIVE keepers(jid,did) AS (
           SELECT jobid,depid FROM jobs
            WHERE displayname GLOB $TRG(case)
           UNION
           SELECT jobid,depid FROM jobs, keepers WHERE jobid=did
        )
        DELETE FROM jobs WHERE jobid NOT IN (SELECT jid FROM keepers);
      }
    }
  }
}

# Initializer, or reinitialize, the testrunner.db database file.
#
proc make_new_testset {} {
  global TRG

  trdb eval {PRAGMA journal_mode=WAL;}
  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} {
  set ntest 1
  set nerr 0
  if {$endtm>0} {
    set re {\y(\d+) errors out of (\d+) tests( on [^\n]+\n)?}
    if {[regexp $re $output all a b pltfm]} {
      set nerr $a
      set ntest $b
    }
    regexp {\ySQLite \d\d\d\d-\d\d-\d\d \d\d:\d\d:\d\d [0-9a-fA-F]+} \
         $output svers
  }
  r_write_db {
    if {$state=="failed"} {
      set childstate omit
      if {$nerr<=0} {set nerr 1}
    } else {
      set childstate ready
    }
    if {[info exists pltfm]} {set pltfm [string trim $pltfm]}
    trdb eval {
      UPDATE jobs 
        SET output=$output, state=$state, endtime=$endtm, span=$endtm-starttime,
            ntest=$ntest, nerr=$nerr, svers=$svers, pltfm=$pltfm
        WHERE jobid=$jobid;
      UPDATE jobs SET state=$childstate
       WHERE depid=$jobid AND state!='halt' AND state!='done';
      UPDATE config SET value=value+$nerr WHERE name='nfail';
      UPDATE config SET value=value+$ntest WHERE name='ntest';
    }
  }
}

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} { 
      puts [format %-79.79s "FAILED: $job(displayname) ($iJob)"]
      set state "failed" 
      if {$TRG(stopOnError)} {
        puts "OUTPUT: $O($iJob)"
        exit 1
      }
      if {$TRG(stopOnCore) && [string first {core dumped} $O($iJob)]>0} {
        puts "OUTPUT: $O($iJob)"
        exit 1
      }
    }

    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 $TRG(interp)
  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
  }

  # Add a batch/shell file command to set the directory used for temp
  # files to the test's working directory. Otherwise, tests that use
  # large numbers of temp files (e.g. zipvfs), might generate temp 
  # filename collisions.
  if {$TRG(platform)=="win"} {
    set set_tmp_dir "SET SQLITE_TMPDIR=[file normalize $dir]"
  } else {
    set set_tmp_dir "export SQLITE_TMPDIR=\"[file normalize $dir]\""
  }

  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 $set_tmp_dir
    puts $fd $job(cmd)
    close $fd
    set fd [open "|$TRG(runcmd) 2>@1" r]
    cd $pwd

    fconfigure $fd -blocking false -translation binary
    fileevent $fd readable [list script_input_ready $fd $iJob $job(jobid)]
  }

  return 1
}

# Show the testing progress report
#
proc progress_report {} {
  global TRG

  if {$TRG(fullstatus)} {
    if {$::tcl_platform(platform) eq "windows"} {
      exec [info nameofexe] $::argv0 status --cls
    } else {
      show_status trdb 1
    }
  } else {
    set tmms [expr [clock_milliseconds] - $TRG(starttime)]
    set tm [format "%d" [expr int($tmms/1000.0 + 0.5)]]
  
    set wtotal 0
    set wdone 0
    r_write_db {
      trdb eval { 
        SELECT displaytype, state, count(*) AS cnt, sum(estwork) AS ew
        FROM jobs 
        GROUP BY 1, 2 
      } {
        set v($state,$displaytype) $cnt
        incr t($displaytype) $cnt
        incr wtotal $ew
        if {$state=="done" || $state=="failed" || $state=="omit"} {
          incr wdone $ew
        }
      }
    }
  
    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)"
      }
    }
    set report "[elapsetime $tmms] [join $text { }]"
    if {$wdone>0 && [set pct [expr {int(($wdone*100.0)/$wtotal)}]]>=4} {
      set tmleft [expr {($tmms/double($wdone))*($wtotal-$wdone)}]
      set etc " ETC [elapsetime $tmleft]"  
      if {[string length $report]+[string length $etc]<80} {
        append report $etc
      }
      # append report " $pct%"
    }
    puts -nonewline [format %-79.79s $report]\r
    flush stdout
  }
  after $TRG(reporttime) progress_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

  if {$TRG(fullstatus)} {puts "\033\[2J"}
  progress_report
  while {[dirs_nHelper]>0} {
    after 500 {incr ::wakeup}
    vwait ::wakeup
  }
  close $TRG(log)
  progress_report
  puts ""

  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"
      }
    }
    set nOmit [trdb one {SELECT count(*) FROM jobs WHERE state='omit'}]
    if {$nOmit>0} {
      puts "$nOmit jobs skipped due to prior failures"
    }
  }

  puts "Test database is $TRG(dbname)"
  puts "Test log is $TRG(logname)"
  if {[info exists TRG(FUZZDB)]} {
    puts "Extra fuzzcheck data taken from $TRG(FUZZDB)"
  }
  trdb eval {
     SELECT sum(ntest) AS totaltest,
            sum(nerr) AS totalerr
       FROM jobs
  } break
  trdb eval {
     SELECT max(endtime)-min(starttime) AS totaltime
       FROM jobs WHERE endtime>0
  } break;
  set et [elapsetime $totaltime]
  set pltfm {}
  trdb eval {
     SELECT pltfm, count(*) FROM jobs WHERE pltfm IS NOT NULL
      ORDER BY 2 DESC LIMIT 1
  } break
  if {$totalerr==""} {set totalerr 0}
  if {$totaltest==""} {set totaltest 0}
  puts "$totalerr errors out of $totaltest tests in $et $pltfm"
  trdb eval {
     SELECT DISTINCT substr(svers,1,79) as v1 FROM jobs WHERE svers IS NOT NULL
  } {puts $v1}

}

# If the argument is "retest", simply rerun all tests from the previous
# run that are marked as one of "ready", "running", "failed", or "omit"
# plus redo any build of dependencies those tests.
#
proc handle_retest {} {
  set cnt 0
  if {[catch {trdb exists {SELECT jobid FROM jobs}} cnt] || $cnt==0} {
    puts "No test available to rerun"
    exit 1
  }
  trdb eval {UPDATE jobs SET state='ready'
              WHERE state IN ('running','failed','omit')}
  for {set kk 0} {$kk<2} {incr kk} {
    trdb eval {
      UPDATE jobs SET state='ready'
       WHERE jobid IN (SELECT depid FROM jobs WHERE state='ready');
      UPDATE jobs SET state='' WHERE state='ready' AND depid<>'';
    }
  }
}

# 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' }
    }
  }
}

# Handle the --explain option.  Provide a human-readable
# explanation of all the tests that are in the trdb database jobs
# table.
#
proc explain_layer {indent depid} {
  global TRG
  if {$TRG(buildonly)} {
    set showtests 0
  } else {
    set showtests 1
  }
  trdb eval {SELECT jobid, displayname, displaytype, dirname
               FROM jobs WHERE depid=$depid ORDER BY displayname} {
    if {$displaytype=="bld"} {
      puts "${indent}$displayname in $dirname"
      explain_layer "${indent}   " $jobid
    } elseif {$showtests} {
      puts "${indent}$displayname"
    }
  }
}
proc explain_tests {} {
  explain_layer "" ""
}

sqlite3 trdb $TRG(dbname)
trdb timeout $TRG(timeout)
if {[llength $TRG(patternlist)]==1 && $TRG(patternlist) eq "retest"} {
  set tm 0
  handle_retest
} else {  
  set tm [lindex [time { make_new_testset }] 0]
}
if {$TRG(explain)} {
  explain_tests
} else {
  if {$TRG(nJob)>1} {
    puts "splitting work across $TRG(nJob) cores"
  }
  if {$tm>0} {
    puts "built testset in [expr $tm/1000]ms.."
  }
  handle_buildonly
  run_testset
}
trdb close