AryaWu/sqlite
0
1#!/bin/sh2# Script to runs tests for SQLite. Run with option "help" for more info. \3exec tclsh "$0" "$@"4 5set dir [pwd]6set testdir [file normalize [file dirname $argv0]]7set saved $argv8set argv [list]9source [file join $testdir testrunner_data.tcl]10 11# Estimated amount of work required by displaytype, relative to 'tcl'12#13set estwork(tcl) 114set estwork(fuzz) 2215set estwork(bld) 6616set estwork(make) 10217 18set estworkfile [file join $testdir testrunner_estwork.tcl]19if {[file readable $estworkfile]} {20 source $estworkfile21}22source [file join $testdir permutations.test]23set argv $saved24cd $dir25 26# This script requires an interpreter that supports [package require sqlite3]27# to run. If this is not such an intepreter, see if there is a [testfixture]28# in the current directory. If so, run the command using it. If not, 29# recommend that the user build one.30#31proc find_interpreter {} {32 global dir33 set interpreter [file tail [info nameofexec]]34 set rc [catch { package require sqlite3 }]35 if {$rc} {36 if {[file readable pkgIndex.tcl] && [catch {source pkgIndex.tcl}]==0} {37 set rc [catch { package require sqlite3 }]38 }39 }40 if {$rc} {41 if { [string match -nocase testfixture* $interpreter]==042 && [file executable ./testfixture]43 } {44 puts "Failed to find tcl package sqlite3. Restarting with ./testfixture.."45 set status [catch {46 exec [trd_get_bin_name testfixture] [info script] {*}$::argv >@ stdout47 } msg]48 exit $status49 }50 }51 if {$rc} {52 puts "Cannot find tcl package sqlite3: Trying to build it now..."53 if {$::tcl_platform(platform) eq "windows"} {54 set bat [open make-tcl-extension.bat w]55 puts $bat "nmake /f Makefile.msc tclextension"56 close $bat57 catch {exec -ignorestderr -- make-tcl-extension.bat}58 } else {59 catch {exec make tclextension}60 }61 if {[file readable pkgIndex.tcl] && [catch {source pkgIndex.tcl}]==0} {62 set rc [catch { package require sqlite3 }]63 }64 if {$rc==0} {65 puts "The SQLite tcl extension was successfully built and loaded."66 puts "Run \"make tclextension-install\" to avoid having to rebuild\67 it in the future."68 } else {69 puts "Unable to build the SQLite tcl extension"70 }71 }72 if {$rc} {73 puts stderr "Cannot find a working instance of the SQLite tcl extension."74 puts stderr "Run \"make tclextension\" or \"make testfixture\" and\75 try again..."76 exit 177 }78}79find_interpreter80 81# Usually this script is run by [testfixture]. But it can also be run82# by a regular [tclsh]. For these cases, emulate the [clock_milliseconds] 83# command.84if {[info commands clock_milliseconds]==""} {85 proc clock_milliseconds {} {86 clock milliseconds87 }88}89 90#-------------------------------------------------------------------------91# Usage:92#93proc usage {} {94 set a0 [file tail $::argv0]95 96 puts [string trim [subst -nocommands {97Usage: 98 $a0 ?SWITCHES? ?PERMUTATION? ?PATTERNS?99 $a0 PERMUTATION FILE100 $a0 errors ?-v|--verbose? ?-s|--summary? ?PATTERN?101 $a0 help102 $a0 joblist ?PATTERN?103 $a0 njob ?NJOB?104 $a0 script ?-msvc? CONFIG105 $a0 status ?-d SECS? ?--cls?106 $a0 halt107 $a0 estwork108 109 where SWITCHES are:110 --buildonly Build test exes but do not run tests111 --cases DISPLAYNAME Only run test that match DISPLAYNAME112 --config CONFIGS Only use configs on comma-separate list CONFIGS113 --dryrun Write what would have happened to testrunner.log114 --explain Write summary to stdout115 --fuzzdb FILENAME Additional external fuzzcheck database116 --jobs NUM Run tests using NUM separate processes117 --omit CONFIGS Omit configs on comma-separated list CONFIGS118 --status Show the full "status" report while running119 --stop-on-coredump Stop running if any test segfaults120 --stop-on-error Stop running after any reported error121 --zipvfs ZIPVFSDIR ZIPVFS source directory122 123Special values for PERMUTATION that work with plain tclsh:124 125 list - show all allowed PERMUTATION arguments.126 mdevtest - tests recommended prior to normal development check-ins.127 release - full release test with various builds.128 sdevtest - like mdevtest but using ASAN and UBSAN.129 130Other PERMUTATION arguments must be run using testfixture, not tclsh:131 132 all - all tcl test scripts, plus a subset of test scripts rerun133 with various permutations.134 full - all tcl test scripts.135 veryquick - a fast subset of the tcl test scripts. This is the default.136 137If no PATTERN arguments are present, all tests specified by the PERMUTATION138are run. Otherwise, each pattern is interpreted as a glob pattern. Only139those tcl tests for which the final component of the filename matches at140least one specified pattern are run. The glob wildcard '*' is prepended141to the pattern if it does not start with '^' and appended to every142pattern that does not end with '$'.143 144If no PATTERN arguments are present, then various fuzztest, threadtest145and other tests are run as part of the "release" permutation. These are146omitted if any PATTERN arguments are specified on the command line.147 148If a PERMUTATION is specified and is followed by the path to a Tcl script149instead of a list of patterns, then that single Tcl test script is run150with the specified permutation.151 152The "status" and "njob" commands are designed to be run from the same153directory as a running testrunner.tcl script that is running tests. The154"status" command prints a report describing the current state and progress 155of the tests. Use the "-d N" option to have the status display clear the156screen and repeat every N seconds. The "njob" command may be used to query157or modify the number of sub-processes the test script uses to run tests.158 159The "script" command outputs the script used to build a configuration.160Add the "-msvc" option for a Windows-compatible script. For a list of161available configurations enter "$a0 script help".162 163The "errors" commands shows the output of tests that failed in the164most recent run. Complete output is shown if the -v or --verbose options165are used. Otherwise, an attempt is made to minimize the output to show166only the parts that contain the error messages. The --summary option just167shows the jobs that failed. If PATTERN are provided, the error information168is only provided for jobs that match PATTERN.169 170Full documentation here: https://sqlite.org/src/doc/trunk/doc/testrunner.md171 }]]172 173 exit 1174}175#-------------------------------------------------------------------------176 177#-------------------------------------------------------------------------178# Try to estimate a the number of processes to use.179#180# Command [guess_number_of_cores] attempts to glean the number of logical181# cores. Command [default_njob] returns the default value for the --jobs182# switch.183#184proc guess_number_of_cores {} {185 if {[catch {number_of_cores} ret]} {186 set ret 4187 if {$::tcl_platform(platform) eq "windows"} {188 catch { set ret $::env(NUMBER_OF_PROCESSORS) }189 } else {190 if {$::tcl_platform(os)=="Darwin"} {191 set cmd "sysctl -n hw.logicalcpu"192 } else {193 set cmd "nproc"194 }195 catch {196 set fd [open "|$cmd" r]197 set ret [gets $fd]198 close $fd199 set ret [expr $ret]200 }201 }202 }203 return $ret204}205 206proc default_njob {} {207 global env208 if {[info exists env(NJOB)] && $env(NJOB)>=1} {209 return $env(NJOB)210 }211 set nCore [guess_number_of_cores]212 if {$nCore<=2} {213 set nHelper 1214 } else {215 set nHelper [expr int($nCore*0.8)]216 if {$nHelper>20} {set nHelper 20}217 }218 return $nHelper219}220#-------------------------------------------------------------------------221 222#-------------------------------------------------------------------------223# Setup various default values in the global TRG() array.224# 225set TRG(dbname) [file normalize testrunner.db]226set TRG(logname) [file normalize testrunner.log]227set TRG(build.logname) [file normalize testrunner_build.log]228set TRG(info_script) [file normalize [info script]]229set TRG(timeout) 10000 ;# Default busy-timeout for testrunner.db 230set TRG(nJob) [default_njob] ;# Default number of helper processes231set TRG(patternlist) [list]232set TRG(cmdline) $argv233set TRG(reporttime) 2000234set TRG(fuzztest) 0 ;# is the fuzztest option present.235set TRG(zipvfs) "" ;# -zipvfs option, if any236set TRG(buildonly) 0 ;# True if --buildonly option 237set TRG(config) {} ;# Only build the named configurations238set TRG(omitconfig) {} ;# Do not build these configurations239set TRG(dryrun) 0 ;# True if --dryrun option 240set TRG(explain) 0 ;# True for the --explain option241set TRG(stopOnError) 0 ;# Stop running at first failure242set TRG(stopOnCore) 0 ;# Stop on a core-dump243set TRG(fullstatus) 0 ;# Full "status" report while running244set TRG(case) {} ;# Only run cases matching this GLOB pattern245 246switch -nocase -glob -- $tcl_platform(os) {247 *darwin* {248 set TRG(platform) osx249 set TRG(make) make.sh250 set TRG(makecmd) "bash make.sh"251 set TRG(testfixture) testfixture252 set TRG(shell) sqlite3253 set TRG(run) run.sh254 set TRG(runcmd) "bash run.sh"255 }256 *linux* - MSYS_NT* - MINGW64_NT* - MINGW32_NT* {257 set TRG(platform) linux258 set TRG(make) make.sh259 set TRG(makecmd) "bash make.sh"260 set TRG(testfixture) testfixture261 set TRG(shell) sqlite3262 set TRG(run) run.sh263 set TRG(runcmd) "bash run.sh"264 }265 *openbsd* {266 set TRG(platform) linux267 set TRG(make) make.sh268 set TRG(makecmd) "sh make.sh"269 set TRG(testfixture) testfixture270 set TRG(shell) sqlite3271 set TRG(run) run.sh272 set TRG(runcmd) "sh run.sh"273 }274 *win* {275 set TRG(platform) win276 set TRG(make) make.bat277 set TRG(makecmd) "call make.bat"278 set TRG(testfixture) testfixture.exe279 set TRG(shell) sqlite3.exe280 set TRG(run) run.bat281 set TRG(runcmd) "run.bat"282 if {"unix" eq $tcl_platform(platform)} {283 # Presumably cygwin. This block gets testrunner.tcl started on284 # Cygwin but then downstream tests all fail, at least in part285 # because of the discrepancies in build target names which need286 # .exe on cygwin but not on other Unix-like platforms.287 set TRG(platform) cygwin288 set TRG(make) make.sh289 set TRG(makecmd) "bash make.sh"290 set TRG(testfixture) testfixture291 set TRG(shell) sqlite3292 set TRG(run) run.sh293 set TRG(runcmd) "bash run.sh"294 }295 }296 default {297 puts "tcl_platform(os)=$::tcl_platform(os)"298 error "cannot determine platform!"299 }300}301#-------------------------------------------------------------------------302 303#-------------------------------------------------------------------------304# The database schema used by the testrunner.db database.305#306set TRG(schema) {307 DROP TABLE IF EXISTS jobs;308 DROP TABLE IF EXISTS config;309 310 /*311 ** This table contains one row for each job that testrunner.tcl must run312 ** before the entire test run is finished.313 **314 ** jobid:315 ** Unique identifier for each job. Must be a +ve non-zero number.316 **317 ** displaytype:318 ** 3 or 4 letter mnemonic for the class of tests this belongs to e.g.319 ** "fuzz", "tcl", "make" etc.320 **321 ** displayname:322 ** Name/description of job. For display purposes.323 **324 ** build:325 ** If the job requires a make.bat/make.sh make wrapper (i.e. to build326 ** something), the name of the build configuration it uses. See 327 ** testrunner_data.tcl for a list of build configs. e.g. "Win32-MemDebug".328 **329 ** dirname:330 ** If the job should use a well-known directory name for its 331 ** sub-directory instead of an anonymous "testdir[1234...]" sub-dir332 ** that is deleted after the job is finished.333 **334 ** cmd:335 ** Bash or batch script to run the job.336 **337 ** depid:338 ** The jobid value of a job that this job depends on. This job may not339 ** be run before its depid job has finished successfully.340 **341 ** priority:342 ** Higher values run first. Sometimes.343 */344 CREATE TABLE jobs(345 /* Fields populated when db is initialized */346 jobid INTEGER PRIMARY KEY, -- id to identify job347 displaytype TEXT NOT NULL, -- Type of test (for one line report)348 displayname TEXT NOT NULL, -- Human readable job name349 build TEXT NOT NULL DEFAULT '', -- make.sh/make.bat file request, if any350 dirname TEXT NOT NULL DEFAULT '', -- directory name, if required351 cmd TEXT NOT NULL, -- shell command to run352 depid INTEGER, -- identifier of dependency (or '')353 priority INTEGER NOT NULL, -- higher priority jobs may run earlier354 355 /* Fields updated as jobs run */356 starttime INTEGER, -- Start time (milliseconds since 1970)357 endtime INTEGER, -- End time358 span INTEGER, -- Total run-time in milliseconds359 estwork INTEGER, -- Estimated amount of work360 estkey TEXT, -- Key used to compute estwork361 state TEXT CHECK( state IN ('','ready','running','done','failed','omit','halt') ),362 ntest INT, -- Number of test cases run363 nerr INT, -- Number of errors reported364 svers TEXT, -- Reported SQLite version365 pltfm TEXT, -- Host platform reported366 output TEXT, -- test output367 cwd TEXT -- working directory for test368 );369 370 CREATE TABLE config(371 name TEXT COLLATE nocase PRIMARY KEY,372 value 373 ) WITHOUT ROWID;374 375 CREATE INDEX i1 ON jobs(state, priority);376 CREATE INDEX i2 ON jobs(depid);377}378#-------------------------------------------------------------------------379 380#--------------------------------------------------------------------------381# Check if this script is being invoked to run a single file. If so,382# run it.383#384if {[llength $argv]==2385 && ([lindex $argv 0]=="" || [info exists ::testspec([lindex $argv 0])])386 && [file exists [lindex $argv 1]]387} {388 set permutation [lindex $argv 0]389 set script [file normalize [lindex $argv 1]]390 set ::argv [list]391 392 set testdir [file dirname $argv0]393 source $::testdir/tester.tcl394 395 if {$permutation=="full"} {396 397 unset -nocomplain ::G(isquick)398 reset_db399 400 } elseif {$permutation!="default" && $permutation!=""} {401 402 if {[info exists ::testspec($permutation)]==0} {403 error "no such permutation: $permutation"404 }405 406 array set O $::testspec($permutation)407 set ::G(perm:name) $permutation408 set ::G(perm:prefix) $O(-prefix)409 set ::G(isquick) 1410 set ::G(perm:dbconfig) $O(-dbconfig)411 set ::G(perm:presql) $O(-presql)412 413 rename finish_test helper_finish_test414 proc finish_test {} "415 uplevel {416 $O(-shutdown)417 }418 helper_finish_test419 "420 421 eval $O(-initialize)422 }423 424 reset_db425 source $script426 exit427}428#--------------------------------------------------------------------------429 430#--------------------------------------------------------------------------431# Check if this is the "njob" command:432#433if {([llength $argv]==2 || [llength $argv]==1) 434 && [string compare -nocase njob [lindex $argv 0]]==0435} {436 sqlite3 mydb $TRG(dbname)437 if {[llength $argv]==2} {438 set param [lindex $argv 1]439 if {[string is integer $param]==0 || $param<0 || $param>128} {440 puts stderr "parameter must be an integer between 0 and 128"441 exit 1442 }443 444 mydb eval { REPLACE INTO config VALUES('njob', $param); }445 }446 set res [mydb one { SELECT value FROM config WHERE name='njob' }]447 mydb close448 puts "$res"449 exit450}451#--------------------------------------------------------------------------452 453#--------------------------------------------------------------------------454# Check if this is the "halt" command:455#456if {[llength $argv]==1457 && [string compare -nocase halt [lindex $argv 0]]==0458} {459 sqlite3 mydb $TRG(dbname)460 mydb eval {UPDATE jobs SET state='halt' WHERE state IN ('ready','')}461 mydb close462 exit463}464#--------------------------------------------------------------------------465 466#--------------------------------------------------------------------------467# Check if this is the "estwork" command:468#469# Generate (on standard output) a set of estwork() values based on the lastest470# test case, that can be used to replace the test/testrunner_estwork.tcl file.471#472if {[llength $argv]==1473 && [string compare -nocase estwork [lindex $argv 0]]==0474} {475 sqlite3 mydb $TRG(dbname)476 set njob [mydb one {SELECT count(*) FROM jobs WHERE state='done'}]477 if {$njob<1000} {478 puts "Too few completed jobs to do a work estimate."479 puts "Have $njob but not need at least 1000."480 mydb close481 exit 1482 }483 set badjobs [mydb one {SELECT count(*) FROM jobs WHERE state<>'done'}]484 if {$badjobs} {485 puts "Database contains $badjobs incomplete jobs."486 mydb close487 exit 1488 }489 set half [mydb one {SELECT count(*)/2 FROM jobs WHERE displaytype='tcl'}]490 set scale [mydb one {SELECT span FROM jobs WHERE displaytype='tcl'491 ORDER BY span LIMIT 1 OFFSET $half}]492 mydb eval {493 SELECT estkey, CAST(avg(span)/$scale AS INT) AS cost494 FROM jobs495 GROUP BY estkey496 HAVING cost>=2497 } {498 set estwork($estkey) $cost499 }500 set avgtcl [mydb one {SELECT avg(span) FROM jobs WHERE displaytype='tcl'}]501 set estwork(tcl) 1502 foreach type {bld fuzz make} {503 set avg [mydb one {SELECT avg(span) FROM jobs WHERE displaytype=$type}]504 if {$avg!=""} {505 set estwork($type) [expr {int($avg/$avgtcl)}]506 }507 }508 mydb close509 puts "# Estimated relative cost of various jobs, based on the \"estkey\" field."510 puts "# Computed by the \"test/testrunner.tcl estwork\" command."511 puts "#"512 foreach key [lsort [array names estwork]] {513 puts "set [list estwork($key)] $estwork($key)"514 }515 exit516}517#--------------------------------------------------------------------------518 519#--------------------------------------------------------------------------520# Check if this is the "help" command:521#522if {[string compare -nocase help [lindex $argv 0]]==0} {523 usage524}525#--------------------------------------------------------------------------526 527#--------------------------------------------------------------------------528# Check if this is the "script" command:529#530if {[string compare -nocase script [lindex $argv 0]]==0} {531 if {[llength $argv]!=2 && !([llength $argv]==3&&[lindex $argv 1]=="-msvc")} {532 usage533 }534 535 set bMsvc [expr ([llength $argv]==3)]536 set config [lindex $argv [expr [llength $argv]-1]]537 538 puts [trd_buildscript $config [file dirname $testdir] $bMsvc]539 exit540}541 542# Compute an elapse time string MM:SS or HH:MM:SS based on the543# number of milliseconds in the argument.544#545proc elapsetime {ms} {546 if {$ms==""} {set ms 0}547 set s [expr {int(($ms+500.0)*0.001)}]548 set hr [expr {$s/3600}]549 set mn [expr {($s/60)%60}]550 set sc [expr {$s%60}]551 if {$hr>0} {552 return [format %02d:%02d:%02d $hr $mn $sc]553 } else {554 return [format %02d:%02d $mn $sc]555 }556}557 558# Helper routine for show_status559#560proc display_job {jobdict {tm ""}} {561 array set job $jobdict562 if {[string length $job(displayname)]>65} {563 set dfname [format %.65s... $job(displayname)]564 } else {565 set dfname [format %-68s $job(displayname)]566 }567 set dtm ""568 if {$tm!=""} {569 set dtm [expr {$tm-$job(starttime)}]570 set dtm [format %8s [elapsetime $dtm]]571 } else {572 set dtm [format %8s ""]573 }574 puts " $dfname $dtm"575}576 577# This procedure shows the "status" page. It uses the database578# connect passed in as the "db" parameter. If the "cls" parameter579# is true, then VT100 escape codes are used to format the display.580#581proc show_status {db cls} {582 global TRG583 $db eval BEGIN584 if {[catch {585 set cmdline [$db one { SELECT value FROM config WHERE name='cmdline' }]586 set nJob [$db one { SELECT value FROM config WHERE name='njob' }]587 } msg]} {588 if {$cls} {puts "\033\[H\033\[2J"}589 puts "Cannot read database: $TRG(dbname)"590 return591 }592 set now [clock_milliseconds]593 set tm [$db one {594 SELECT 595 COALESCE((SELECT value FROM config WHERE name='end'), $now) -596 (SELECT value FROM config WHERE name='start')597 }]598 599 set totalw 0600 foreach s {"" ready running done failed omit} { set S($s) 0; set W($s) 0; }601 set workpending 0602 $db eval {603 SELECT state, count(*) AS cnt, sum(estwork) AS ew FROM jobs GROUP BY 1604 } {605 incr S($state) $cnt606 incr W($state) $ew607 incr totalw $ew608 }609 set nt 0610 set ne 0611 $db eval {612 SELECT sum(ntest) AS nt, sum(nerr) AS ne FROM jobs HAVING nt>0613 } break614 set fin [expr $W(done)+$W(failed)+$W(omit)]615 if {$cmdline!=""} {set cmdline " $cmdline"}616 617 if {$cls} {618 # Move the cursor to the top-left corner. Each iteration will simply619 # overwrite.620 puts -nonewline "\033\[H"621 flush stdout622 }623 puts [format %-79.79s "Command: \[testrunner.tcl$cmdline\]"]624 puts [format %-79.79s "Summary: [elapsetime $tm], $fin/$totalw jobs,\625 $ne errors, $nt tests"]626 627 set srcdir [file dirname [file dirname $TRG(info_script)]]628 set line "Running: $S(running) (max: $nJob)"629 if {$S(running)>0 && [set pct [expr {int(($fin*100.0)/$totalw)}]]>=4} {630 set tmleft [expr {($tm/double($fin))*($totalw-$fin)}]631 if {$tmleft<0.02*$tm} {632 set tmleft [expr {$tm*0.02}]633 }634 set etc " ETC [elapsetime $tmleft]"635 if {[string length $line]+[string length $etc]<80} {636 append line $etc637 }638 # append line " $pct%"639 }640 puts [format %-79.79s $line]641 if {$S(running)>0} {642 $db eval {643 SELECT * FROM jobs WHERE state='running' ORDER BY starttime 644 } job {645 display_job [array get job] $now646 }647 }648 if {$S(failed)>0} {649 # $toshow is the number of failures to report. In $cls mode,650 # status tries to limit the number of failure reported so that651 # the status display does not overflow a 24-line terminal. It will652 # always show at least the most recent 4 failures, even if an overflow653 # is needed. No limit is imposed for a status within $cls.654 #655 if {$cls && $S(failed)>18-$S(running)} {656 set toshow [expr {18-$S(running)}]657 if {$toshow<4} {set toshow 4}658 set shown " (must recent $toshow shown)"659 } else {660 set toshow $S(failed)661 set shown ""662 }663 puts [format %-79s "Failed: $S(failed) $shown"]664 $db eval {665 SELECT * FROM jobs WHERE state='failed'666 ORDER BY endtime DESC LIMIT $toshow667 } job {668 display_job [array get job]669 }670 set nOmit [$db one {SELECT count(*) FROM jobs WHERE state='omit'}]671 if {$nOmit} {672 puts [format %-79s " ... $nOmit jobs omitted due to failures"]673 }674 }675 if {$cls} {676 # Clear everything else to the bottom of the screen677 puts -nonewline "\033\[0J"678 flush stdout679 }680 $db eval COMMIT681}682 683 684 685#--------------------------------------------------------------------------686# Check if this is the "status" command:687#688if {[llength $argv]>=1 689 && [string compare -nocase status [lindex $argv 0]]==0 690} {691 set delay 0692 set cls 0693 for {set ii 1} {$ii<[llength $argv]} {incr ii} {694 set a0 [lindex $argv $ii]695 if {$a0=="-d" && $ii+1<[llength $argv]} {696 incr ii697 set delay [lindex $argv $ii]698 if {![string is integer -strict $delay]} {699 puts "Argument to -d should be an integer"700 exit 1701 }702 } elseif {$a0=="-cls" || $a0=="--cls"} {703 set cls 1704 } else {705 puts "unknown option: \"$a0\""706 exit 1707 }708 }709 710 set once 1711 while {![file readable $TRG(dbname)]} {712 if {$delay==0} {713 puts "Database missing: $TRG(dbname)"714 exit715 }716 if {$once} {717 set once 0718 puts "Waiting for testing to start...."719 flush stdout720 }721 after [expr {$delay*1000}]722 }723 sqlite3 mydb $TRG(dbname)724 mydb timeout 2000725 726 # Clear the whole screen initially.727 #728 if {$delay>0 || $cls} {puts -nonewline "\033\[2J"}729 730 while {1} {731 show_status mydb [expr {$delay>0 || $cls}]732 if {$delay<=0} break733 after [expr {$delay*1000}]734 }735 mydb close736 exit737}738 739#--------------------------------------------------------------------------740# Check if this is the "joblist" command:741#742if {[llength $argv]>=1 743 && [string compare -nocase "joblist" [lindex $argv 0]]==0 744} {745 set pattern {}746 for {set ii 1} {$ii<[llength $argv]} {incr ii} {747 set a0 [lindex $argv $ii]748 if {$pattern==""} {749 set pattern [string trim $a0 *]750 } else {751 puts "unknown option: \"$a0\""752 exit 1753 }754 }755 set SQL {SELECT displaytype, displayname, state FROM jobs}756 if {$pattern!=""} {757 regsub -all {[^a-zA-Z0-9*.-/]} $pattern ? pattern758 set pattern [string tolower $pattern]759 append SQL \760 " WHERE lower(concat(state,' ',displaytype,' ',displayname)) GLOB '*$pattern*'"761 }762 append SQL " ORDER BY starttime"763 764 if {![file readable $TRG(dbname)]} {765 puts "Database missing: $TRG(dbname)"766 exit767 }768 sqlite3 mydb $TRG(dbname)769 mydb timeout 2000770 771 mydb eval $SQL {772 set label UNKNOWN773 switch -- $state {774 ready {set label READY}775 done {set label DONE}776 failed {set label FAILED}777 omit {set label OMIT}778 running {set label RUNNING}779 }780 puts [format {%-7s %-5s %s} $label $displaytype $displayname]781 }782 mydb close783 exit784}785 786# Scan the output of all jobs looking for the summary lines that787# report the number of test cases and the number of errors.788# Aggregate these numbers and return them.789#790proc aggregate_test_counts {db} {791 set ne 0792 set nt 0793 $db eval {SELECT sum(nerr) AS ne, sum(ntest) as nt FROM jobs} break794 return [list $ne $nt]795}796 797#--------------------------------------------------------------------------798# Check if this is the "errors" command:799#800if {[llength $argv]>=1801 && ([string compare -nocase errors [lindex $argv 0]]==0 ||802 [string match err* [lindex $argv 0]]==1)803} {804 set verbose 0805 set pattern {}806 set summary 0807 for {set ii 1} {$ii<[llength $argv]} {incr ii} {808 set a0 [lindex $argv $ii]809 if {$a0=="-v" || $a0=="--verbose" || $a0=="-verbose"} {810 set verbose 1811 } elseif {$a0=="-s" || $a0=="--summary" || $a0=="-summary"} {812 set summary 1813 } elseif {$pattern==""} {814 set pattern *[string trim $a0 *]*815 } else {816 puts "unknown option: \"$a0\"". Use --help for more info."817 exit 1818 }819 }820 set cnt 0821 sqlite3 mydb $TRG(dbname)822 mydb timeout 5000823 if {$summary} {824 set sql "SELECT displayname FROM jobs WHERE state='failed'"825 } else {826 set sql "SELECT displaytype, displayname, output FROM jobs \827 WHERE state='failed'"828 }829 if {$pattern!=""} {830 regsub -all {[^a-zA-Z0-9*/ ?]} $pattern . pattern831 append sql " AND displayname GLOB '$pattern'"832 }833 mydb eval $sql {834 if {$summary} {835 puts "FAILED: $displayname"836 continue837 }838 puts "**** $displayname ****"839 if {$verbose || $displaytype!="tcl"} {840 puts $output841 } else {842 foreach line [split $output \n] {843 if {[string match {!*} $line] || [string match *failed* $line]} {844 puts $line845 }846 }847 }848 incr cnt849 }850 if {$pattern==""} {851 set summary [aggregate_test_counts mydb]852 mydb close853 puts "Total [lindex $summary 0] errors out of [lindex $summary 1] tests"854 } else {855 mydb close856 }857 exit858}859 860#-------------------------------------------------------------------------861# Parse the command line.862#863for {set ii 0} {$ii < [llength $argv]} {incr ii} {864 set isLast [expr $ii==([llength $argv]-1)]865 set a [lindex $argv $ii]866 set n [string length $a]867 868 if {[string range $a 0 0]=="-"} {869 if {($n>2 && [string match "$a*" --jobs]) || $a=="-j"} {870 incr ii871 set TRG(nJob) [lindex $argv $ii]872 if {$isLast} { usage }873 } elseif {($n>2 && [string match "$a*" --zipvfs]) || $a=="-z"} {874 incr ii875 set TRG(zipvfs) [file normalize [lindex $argv $ii]]876 if {$isLast} { usage }877 } elseif {($n>2 && [string match "$a*" --buildonly]) || $a=="-b"} {878 set TRG(buildonly) 1879 } elseif {($n>2 && [string match "$a*" --config]) || $a=="-c"} {880 incr ii881 set TRG(config) [lindex $argv $ii]882 } elseif {($n>2 && [string match "$a*" --dryrun]) || $a=="-d"} {883 set TRG(dryrun) 1884 } elseif {($n>2 && [string match "$a*" --explain]) || $a=="-e"} {885 set TRG(explain) 1886 } elseif {$n>2 && [string match "$a*" --omit]} {887 incr ii888 set TRG(omitconfig) [lindex $argv $ii]889 } elseif {$n>2 && [string match "$a*" --cases]} {890 incr ii891 set TRG(case) [lindex $argv $ii]892 } elseif {$n>2 && [string match "$a*" --fuzzdb]} {893 incr ii894 set env(FUZZDB) [lindex $argv $ii]895 } elseif {[string match "$a*" --stop-on-error]} {896 set TRG(stopOnError) 1897 } elseif {[string match "$a*" --stop-on-coredump]} {898 set TRG(stopOnCore) 1899 } elseif {[string match "$a*" --status]} {900 if {$tcl_platform(platform) eq "windows"} {901 puts stdout \902"The --status option is not available on Windows. A suggested work-around"903 puts stdout \904"is to run the following command in a separate window:\n"905 puts stdout " [info nameofexe] $argv0 status -d 2\n"906 } else {907 set TRG(fullstatus) 1908 }909 } else {910 usage911 }912 } else {913 lappend TRG(patternlist) [string map {% *} $a]914 }915}916set argv [list]917 918# This script runs individual tests - tcl scripts or [make xyz] commands -919# in directories named "testdir$N", where $N is an integer. This variable920# contains a list of integers indicating the directories in use.921#922# This variable is accessed only via the following commands:923#924# dirs_nHelper925# Return the number of entries currently in the list.926#927# dirs_freeDir IDIR928# Remove value IDIR from the list. It is an error if it is not present.929#930# dirs_allocDir931# Select a value that is not already in the list. Add it to the list932# and return it.933#934set TRG(dirs_in_use) [list]935 936proc dirs_nHelper {} {937 global TRG938 llength $TRG(dirs_in_use)939}940proc dirs_freeDir {iDir} {941 global TRG942 set out [list]943 foreach d $TRG(dirs_in_use) {944 if {$iDir!=$d} { lappend out $d }945 }946 if {[llength $out]!=[llength $TRG(dirs_in_use)]-1} {947 error "dirs_freeDir could not find $iDir"948 }949 set TRG(dirs_in_use) $out950}951proc dirs_allocDir {} {952 global TRG953 array set inuse [list]954 foreach d $TRG(dirs_in_use) {955 set inuse($d) 1956 }957 for {set iRet 0} {[info exists inuse($iRet)]} {incr iRet} { }958 lappend TRG(dirs_in_use) $iRet959 return $iRet960}961 962# Check that directory $dir exists. If it does not, create it. If 963# it does, delete its contents.964#965proc create_or_clear_dir {dir} {966 set dir [file normalize $dir]967 catch { file mkdir $dir }968 foreach f [glob -nocomplain [file join $dir *]] {969 catch { file delete -force $f }970 }971}972 973proc build_to_dirname {bname} {974 set fold [string tolower [string map {- _} $bname]]975 return "testrunner_build_$fold"976}977 978#-------------------------------------------------------------------------979 980proc r_write_db {tcl} {981 trdb eval { BEGIN EXCLUSIVE }982 uplevel $tcl983 trdb eval { COMMIT }984}985 986# Obtain a new job to be run by worker $iJob (an integer). A job is987# returned as a three element list:988#989# {$build $config $file}990#991proc r_get_next_job {iJob} {992 global T993 994 if {($iJob%2)} {995 set orderby "ORDER BY priority ASC"996 } else {997 set orderby "ORDER BY priority DESC"998 }999 1000 set ret [list]1001 1002 r_write_db {1003 set query "1004 SELECT * FROM jobs AS j WHERE state='ready' $orderby LIMIT 11005 " 1006 trdb eval $query job {1007 set tm [clock_milliseconds]1008 set T($iJob) $tm1009 set jobid $job(jobid)1010 1011 set cwd $job(dirname) 1012 if {$cwd==""} {1013 set cwd [dirname $iJob]1014 }1015 1016 trdb eval {1017 UPDATE jobs 1018 SET starttime=$tm, state='running', cwd=$cwd 1019 WHERE jobid=$jobid1020 }1021 1022 set ret [array get job]1023 }1024 }1025 1026 return $ret1027}1028 1029# Usage:1030#1031# add_job OPTION ARG OPTION ARG...1032#1033# where available OPTIONS are:1034#1035# -displaytype1036# -displayname1037# -build1038# -dirname 1039# -cmd 1040# -depid 1041# -priority 1042#1043# Returns the jobid value for the new job.1044# 1045proc add_job {args} {1046 global estwork1047 1048 set options {1049 -displaytype -displayname -build -dirname 1050 -cmd -depid -priority1051 }1052 1053 # Set default values of options.1054 set A(-dirname) ""1055 set A(-depid) ""1056 set A(-priority) 01057 set A(-build) ""1058 1059 array set A $args1060 1061 # Check all required options are present. And that no extras are present.1062 foreach o $options {1063 if {[info exists A($o)]==0} { error "missing required option $o" }1064 }1065 foreach o [array names A] {1066 if {[lsearch -exact $options $o]<0} { error "unrecognized option: $o" }1067 }1068 1069 set state ""1070 if {$A(-depid)==""} { set state ready }1071 set type $A(-displaytype)1072 set displayname $A(-displayname)1073 switch $type {1074 tcl {1075 set ek [file tail [lindex $displayname end]]1076 }1077 bld {1078 set ek [lindex $displayname end]1079 }1080 fuzz {1081 set ek [lrange $displayname 1 2]1082 }1083 make {1084 set ek [lindex $displayname end]1085 }1086 }1087 if {[info exists estwork($ek)]} {1088 set ew $estwork($ek)1089 } else {1090 set ew $estwork($type)1091 }1092 1093 trdb eval {1094 INSERT INTO jobs(1095 displaytype, displayname, build, dirname, cmd, depid, priority,1096 estwork, estkey, state1097 ) VALUES (1098 $type,1099 $A(-displayname),1100 $A(-build),1101 $A(-dirname),1102 $A(-cmd),1103 $A(-depid),1104 $A(-priority),1105 $ew,1106 $ek,1107 $state1108 )1109 }1110 1111 trdb last_insert_rowid1112}1113 1114# Look to see if $jobcmd matches any of the glob patterns given in1115# $patternlist. Return true if there is a match. Return false1116# if no match is seen.1117#1118# An empty patternlist matches everything1119#1120proc job_matches_any_pattern {patternlist jobcmd} {1121 set bMatch 01122 if {[llength $patternlist]==0} {return 1}1123 foreach p $patternlist {1124 set p [string trim $p *]1125 if {[string index $p 0]=="^"} {1126 set p [string range $p 1 end]1127 } else {1128 set p "*$p"1129 }1130 if {[string index $p end]=="\$"} {1131 set p [string range $p 0 end-1]1132 } else {1133 set p "$p*"1134 }1135 if {[string match $p $jobcmd]} {1136 set bMatch 11137 break1138 }1139 }1140 return $bMatch1141}1142 1143 1144# Argument $build is either an empty string, or else a list of length 3 1145# describing the job to build testfixture. In the usual form:1146#1147# {ID DIRNAME DISPLAYNAME}1148# 1149# e.g 1150#1151# {1 /home/user/sqlite/test/testrunner_bld_xyz All-Debug}1152# 1153proc add_tcl_jobs {build config patternlist {shelldepid ""}} {1154 global TRG1155 set ntcljob 01156 1157 set topdir [file dirname $::testdir]1158 set testrunner_tcl [file normalize [info script]]1159 1160 if {$build==""} {1161 set testfixture [info nameofexec]1162 } else {1163 set testfixture [file join [lindex $build 1] $TRG(testfixture)]1164 }1165 if {[lindex $build 2]=="Valgrind"} {1166 set setvar "export OMIT_MISUSE=1\n"1167 set testfixture "${setvar}valgrind -v --error-exitcode=1 $testfixture"1168 }1169 1170 # The ::testspec array is populated by permutations.test1171 foreach f [dict get $::testspec($config) -files] {1172 1173 if {![job_matches_any_pattern $patternlist "$config [file tail $f]"]} {1174 continue1175 }1176 1177 if {[file pathtype $f]!="absolute"} { set f [file join $::testdir $f] }1178 set f [file normalize $f]1179 1180 set displayname [string map [list $topdir/ {}] $f]1181 if {$config=="full" || $config=="veryquick"} {1182 set cmd "$testfixture $f"1183 } else {1184 set cmd "$testfixture $testrunner_tcl $config $f"1185 set displayname "config=$config $displayname"1186 }1187 if {$build!=""} {1188 set displayname "[lindex $build 2] $displayname"1189 }1190 1191 set lProp [trd_test_script_properties $f]1192 set priority 01193 if {[lsearch $lProp slow]>=0} { set priority 2 }1194 if {[lsearch $lProp superslow]>=0} { set priority 4 }1195 1196 set depid [lindex $build 0]1197 if {$shelldepid!="" && [lsearch $lProp shell]>=0} { set depid $shelldepid }1198 1199 incr ntcljob1200 add_job \