test/testrunner.tcl

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

#-------------------------------------------------------------------------
# Usage:
#
proc usage {} {
  set a0 [file tail $::argv0]

  puts stderr [string trim [subst -nocommands {
Usage: 
    $a0 ?SWITCHES? ?PERMUTATION? ?PATTERNS?
    $a0 PERMUTATION FILE
    $a0 njob ?NJOB?
    $a0 status

  where SWITCHES are:
    --jobs NUMBER-OF-JOBS
    --fuzztest
    --zipvfs ZIPVFS-SOURCE-DIR

Interesting values for PERMUTATION are:

    veryquick - a fast subset of the tcl test scripts. This is the default.
    full      - all tcl test scripts.
    all       - all tcl test scripts, plus a subset of test scripts rerun
                with various permutations.
    release   - full release test with various builds.

If no PATTERN arguments are present, all tests specified by the PERMUTATION
are run. Otherwise, each pattern is interpreted as a glob pattern. Only
those tcl tests for which the final component of the filename matches at
least one specified pattern are run.

If no PATTERN arguments are present, then various fuzztest, threadtest
and other tests are run as part of the "release" permutation. These are
omitted if any PATTERN arguments are specified on the command line.

If a PERMUTATION is specified and is followed by the path to a Tcl script
instead of a list of patterns, then that single Tcl test script is run
with the specified permutation.

The --fuzztest option is ignored if the PERMUTATION is "release". Otherwise,
if it is present, then "make -C <dir> fuzztest" is run as part of the tests,
where <dir> is the directory containing the testfixture binary used to
run the script.

The "status" and "njob" commands are designed to be run from the same
directory as a running testrunner.tcl script that is running tests. The
"status" command prints a report describing the current state and progress 
of the tests. The "njob" command may be used to query or modify the number
of sub-processes the test script uses to run tests.
  }]]

  exit 1
}
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# Try to estimate a the number of processes to use.
#
# Command [guess_number_of_cores] attempts to glean the number of logical
# cores. Command [default_njob] returns the default value for the --jobs
# switch.
#
proc guess_number_of_cores {} {
  if {[catch {number_of_cores} ret]} {
    set ret 4
  
    if {$::tcl_platform(os)=="Darwin"} {
      set cmd "sysctl -n hw.logicalcpu"
    } else {
      set cmd "nproc"
    }
    catch {
      set fd [open "|$cmd" r]
      set ret [gets $fd]
      close $fd
      set ret [expr $ret]
    }
  }
  return $ret
}

proc default_njob {} {
  set nCore [guess_number_of_cores]
  if {$nCore<=2} {
    set nHelper 1
  } else {
    set nHelper [expr int($nCore*0.5)]
  }
  return $nHelper
}
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# Setup various default values in the global TRG() array.
# 
set TRG(dbname) [file normalize testrunner.db]
set TRG(logname) [file normalize testrunner.log]
set TRG(build.logname) [file normalize testrunner_build.log]
set TRG(info_script) [file normalize [info script]]
set TRG(timeout) 10000              ;# Default busy-timeout for testrunner.db 
set TRG(nJob)    [default_njob]     ;# Default number of helper processes
set TRG(patternlist) [list]
set TRG(cmdline) $argv
set TRG(reporttime) 2000
set TRG(fuzztest) 0                 ;# is the fuzztest option present.
set TRG(zipvfs) ""                  ;# -zipvfs option, if any

switch -nocase -glob -- $tcl_platform(os) {
  *darwin* {
    set TRG(platform) osx
    set TRG(make)     make.sh
    set TRG(makecmd)  "bash make.sh"
  }
  *linux* {
    set TRG(platform) linux
    set TRG(make)     make.sh
    set TRG(makecmd)  "bash make.sh"
  }
  *win* {
    set TRG(platform) win
    set TRG(make)     make.bat
    set TRG(makecmd)  make.bat
  }
  default {
    error "cannot determine platform!"
  }
} 
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# The database schema used by the testrunner.db database.
#
set TRG(schema) {
  DROP TABLE IF EXISTS script;
  DROP TABLE IF EXISTS config;

  CREATE TABLE script(
    build TEXT DEFAULT '',
    config TEXT,
    filename TEXT,                -- full path to test script
    slow BOOLEAN,                 -- true if script is "slow"
    state TEXT CHECK( state IN ('', 'ready', 'running', 'done', 'failed') ),
    time INTEGER,                 -- Time in ms
    output TEXT,                  -- full output of test script
    priority AS ((config='make') + ((config='build')*2) + (slow*4)),
    jobtype AS (
      CASE WHEN config IN ('build', 'make') THEN config ELSE 'script' END
    ),
    PRIMARY KEY(build, config, filename)
  );

  CREATE TABLE config(
    name TEXT COLLATE nocase PRIMARY KEY,
    value 
  ) WITHOUT ROWID;

  CREATE INDEX i1 ON script(state, jobtype);
  CREATE INDEX i2 ON script(state, priority);
}
#-------------------------------------------------------------------------

#--------------------------------------------------------------------------
# Check if this script is being invoked to run a single file. If so,
# run it.
#
if {[llength $argv]==2
 && ([lindex $argv 0]=="" || [info exists ::testspec([lindex $argv 0])])
 && [file exists [lindex $argv 1]]
} {
  set permutation [lindex $argv 0]
  set script [file normalize [lindex $argv 1]]
  set ::argv [list]

  if {$permutation=="full"} {

    set testdir [file dirname $argv0]
    source $::testdir/tester.tcl
    unset -nocomplain ::G(isquick)
    reset_db

  } elseif {$permutation!="default" && $permutation!=""} {

    if {[info exists ::testspec($permutation)]==0} {
      error "no such permutation: $permutation"
    }

    array set O $::testspec($permutation)
    set ::G(perm:name)         $permutation
    set ::G(perm:prefix)       $O(-prefix)
    set ::G(isquick)           1
    set ::G(perm:dbconfig)     $O(-dbconfig)
    set ::G(perm:presql)       $O(-presql)

    rename finish_test helper_finish_test
    proc finish_test {} "
      uplevel {
        $O(-shutdown)
      }
      helper_finish_test
    "

    eval $O(-initialize)
  }

  reset_db
  source $script
  exit
}
#--------------------------------------------------------------------------

#--------------------------------------------------------------------------
# Check if this is the "njob" command:
#
if {([llength $argv]==2 || [llength $argv]==1) 
 && [string compare -nocase njob [lindex $argv 0]]==0
} {
  sqlite3 mydb $TRG(dbname)
  if {[llength $argv]==2} {
    set param [lindex $argv 1]
    if {[string is integer $param]==0 || $param<1 || $param>128} {
      puts stderr "parameter must be an integer between 1 and 128"
      exit 1
    }

    mydb eval { REPLACE INTO config VALUES('njob', $param); }
  }
  set res [mydb one { SELECT value FROM config WHERE name='njob' }]
  mydb close
  puts "$res"
  exit
}
#--------------------------------------------------------------------------

#--------------------------------------------------------------------------
# Check if this is the "status" command:
#
if {[llength $argv]==1 
 && [string compare -nocase status [lindex $argv 0]]==0 
} {

  proc display_job {build config filename {tm ""}} {
    if {$config=="build"} {
      set fname "build: $filename"
      set config ""
    } elseif {$config=="make"} {
      set fname "make: $filename"
      set config ""
    } else {
      set fname [file normalize $filename]
      if {[string first $::srcdir $fname]==0} {
        set fname [string range $fname [string length $::srcdir]+1 end]
      }
    }
    set dfname [format %-33s $fname]

    set dbuild ""
    set dconfig ""
    set dparams ""
    set dtm ""
    if {$build!=""} { set dbuild $build }
    if {$config!="" && $config!="full"} { set dconfig $config }
    if {$dbuild!="" || $dconfig!=""} {
      append dparams "("
      if {$dbuild!=""}                 {append dparams "build=$dbuild"}
      if {$dbuild!="" && $dconfig!=""} {append dparams " "}
      if {$dconfig!=""}                {append dparams "config=$dconfig"}
      append dparams ")"
      set dparams [format %-33s $dparams]
    }
    if {$tm!=""} {
      set dtm "\[${tm}ms\]"
    }
    puts "  $dfname $dparams $dtm"
  }

  sqlite3 mydb $TRG(dbname)
  mydb timeout 1000
  mydb eval BEGIN

  set cmdline [mydb one { SELECT value FROM config WHERE name='cmdline' }]
  set nJob [mydb one { SELECT value FROM config WHERE name='njob' }]
  set tm [expr [clock_milliseconds] - [mydb one {
    SELECT value FROM config WHERE name='start'
  }]]

  set total 0
  foreach s {"" ready running done failed} { set S($s) 0 }
  mydb eval {
    SELECT state, count(*) AS cnt FROM script GROUP BY 1
  } {
    incr S($state) $cnt
    incr total $cnt
  }
  set fin [expr $S(done)+$S(failed)]
  if {$cmdline!=""} {set cmdline " $cmdline"}

  set f ""
  if {$S(failed)>0} {
    set f "$S(failed) FAILED, "
  }
  puts "Command line: \[testrunner.tcl$cmdline\]"
  puts "Jobs:         $nJob"
  puts "Summary:      ${tm}ms, ($fin/$total) finished, ${f}$S(running) running"

  set srcdir [file dirname [file dirname $TRG(info_script)]]
  if {$S(running)>0} {
    puts "Running: "
    set now [clock_milliseconds]
    mydb eval {
      SELECT build, config, filename, time FROM script WHERE state='running'
      ORDER BY time 
    } {
      display_job $build $config $filename [expr $now-$time]
    }
  }
  if {$S(failed)>0} {
    puts "Failures: "
    mydb eval {
      SELECT build, config, filename FROM script WHERE state='failed'
      ORDER BY 3
    } {
      display_job $build $config $filename
    }
  }
 
  mydb close
  exit
}

#-------------------------------------------------------------------------
# Parse the command line.
#
for {set ii 0} {$ii < [llength $argv]} {incr ii} {
  set isLast [expr $ii==([llength $argv]-1)]
  set a [lindex $argv $ii]
  set n [string length $a]

  if {[string range $a 0 0]=="-"} {
    if {($n>2 && [string match "$a*" --jobs]) || $a=="-j"} {
      incr ii
      set TRG(nJob) [lindex $argv $ii]
      if {$isLast} { usage }
    } elseif {($n>2 && [string match "$a*" --fuzztest]) || $a=="-f"} {
      set TRG(fuzztest) 1
    } elseif {($n>2 && [string match "$a*" --zipvfs]) || $a=="-z"} {
      incr ii
      set TRG(zipvfs) [lindex $argv $ii]
      if {$isLast} { usage }
    } else {
      usage
    }
  } else {
    lappend TRG(patternlist) [string map {% *} $a]
  }
}
set argv [list]



# This script runs individual tests - tcl scripts or [make xyz] commands -
# in directories named "testdir$N", where $N is an integer. This variable
# contains a list of integers indicating the directories in use.
#
# This variable is accessed only via the following commands:
#
#   dirs_nHelper
#     Return the number of entries currently in the list.
#
#   dirs_freeDir IDIR
#     Remove value IDIR from the list. It is an error if it is not present.
#
#   dirs_allocDir
#     Select a value that is not already in the list. Add it to the list
#     and return it.
#
set TRG(dirs_in_use) [list]

proc dirs_nHelper {} {
  global TRG
  llength $TRG(dirs_in_use)
}
proc dirs_freeDir {iDir} {
  global TRG
  set out [list]
  foreach d $TRG(dirs_in_use) {
    if {$iDir!=$d} { lappend out $d }
  }
  if {[llength $out]!=[llength $TRG(dirs_in_use)]-1} {
    error "dirs_freeDir could not find $iDir"
  }
  set TRG(dirs_in_use) $out
}
proc dirs_allocDir {} {
  global TRG
  array set inuse [list]
  foreach d $TRG(dirs_in_use) {
    set inuse($d) 1
  }
  for {set iRet 0} {[info exists inuse($iRet)]} {incr iRet} { }
  lappend TRG(dirs_in_use) $iRet
  return $iRet
}

set testdir [file dirname $argv0]

# Check that directory $dir exists. If it does not, create it. If 
# it does, delete its contents.
#
proc create_or_clear_dir {dir} {
  set dir [file normalize $dir]
  catch { file mkdir $dir }
  foreach f [glob -nocomplain [file join $dir *]] {
    catch { file delete -force $f }
  }
}

proc copy_dir {from to} {
  foreach f [glob -nocomplain [file join $from *]] {
    catch { file copy -force $f $to }
  }
}

proc build_to_dirname {bname} {
  set fold [string tolower [string map {- _} $bname]]
  return "testrunner_build_$fold"
}

#-------------------------------------------------------------------------
# Return a list of tests to run. Each element of the list is itself a
# list of two elements - the name of a permuations.test configuration
# followed by the full path to a test script. i.e.:
#
#    {BUILD CONFIG FILENAME} {BUILD CONFIG FILENAME} ...
#
proc testset_patternlist {patternlist} {
  global TRG

  set testset [list]              ;# return value

  set first [lindex $patternlist 0]

  if {$first=="release"} {
    set platform $::TRG(platform)

    set patternlist [lrange $patternlist 1 end]
    foreach b [trd_builds $platform] {
      foreach c [trd_configs $platform $b] {
        testset_append testset $b $c $patternlist
      }

      if {[llength $patternlist]==0 || $b=="User-Auth"} {
        set target testfixture
      } else {
        set target coretestprogs
      }
      lappend testset [list $b build $target]
    }

    if {[llength $patternlist]==0} {
      foreach b [trd_builds $platform] {
        foreach e [trd_extras $platform $b] {
          lappend testset [list $b make $e]
        }
      }
    }

    set TRG(fuzztest) 0           ;# ignore --fuzztest option in this case

  } elseif {$first=="all"} {

    set clist [trd_all_configs]
    set patternlist [lrange $patternlist 1 end]
    foreach c $clist {
      testset_append testset "" $c $patternlist
    }

  } elseif {[info exists ::testspec($first)]} {
    set clist $first
    testset_append testset "" $first [lrange $patternlist 1 end]
  } elseif { [llength $patternlist]==0 } {
    testset_append testset "" veryquick $patternlist
  } else {
    testset_append testset "" full $patternlist
  }
  if {$TRG(fuzztest)} {
    if {$TRG(platform)=="win"} { error "todo" }
    lappend testset [list "" make fuzztest]
  }

  set testset
}

proc testset_append {listvar build config patternlist} {
  upvar $listvar lvar

  catch { array unset O }
  array set O $::testspec($config)

  foreach f $O(-files) {
    if {[llength $patternlist]>0} {
      set bMatch 0
      foreach p $patternlist {
        if {[string match $p [file tail $f]]} {
          set bMatch 1
          break
        }
      }
      if {$bMatch==0} continue
    }

    if {[file pathtype $f]!="absolute"} {
      set f [file join $::testdir $f]
    }
    lappend lvar [list $build $config $f]
  }
}

#--------------------------------------------------------------------------


proc r_write_db {tcl} {
  trdb eval { BEGIN EXCLUSIVE }
  uplevel $tcl
  trdb eval { COMMIT }
}

# Obtain a new job to be run by worker $iJob (an integer). A job is
# returned as a three element list:
#
#    {$build $config $file}
#
proc r_get_next_job {iJob} {
  global T

  if {($iJob%2)} {
    set orderby "ORDER BY priority ASC"
  } else {
    set orderby "ORDER BY priority DESC"
  }

  r_write_db {
    set f ""
    set c ""
    trdb eval "
      SELECT build, config, filename 
        FROM script 
        WHERE state='ready' 
        $orderby LIMIT 1
    " {
      set b $build
      set c $config
      set f $filename
    }
    if {$f!=""} {
      set tm [clock_milliseconds]
      set T($iJob) $tm
      trdb eval { 
        UPDATE script SET state='running', time=$tm
        WHERE (build, config, filename) = ($b, $c, $f)
      }
    }
  }

  if {$f==""} { return "" }
  list $b $c $f
}

#rename r_get_next_job r_get_next_job_r
#proc r_get_next_job {iJob} {
#  puts [time { set res [r_get_next_job_r $iJob] }]
#  set res
#}

proc make_new_testset {} {
  global TRG

  set tests [testset_patternlist $TRG(patternlist)]

  if {$TRG(zipvfs)!=""} {
    source [file join $TRG(zipvfs) test zipvfs_testrunner.tcl]
    set tests [concat $tests [zipvfs_testrunner_testset]]
  }

  r_write_db {

    trdb eval $TRG(schema)
    set nJob $TRG(nJob)
    set cmdline $TRG(cmdline)
    set tm [clock_milliseconds]
    trdb eval { REPLACE INTO config VALUES('njob', $nJob ); }
    trdb eval { REPLACE INTO config VALUES('cmdline', $cmdline ); }
    trdb eval { REPLACE INTO config VALUES('start', $tm ); }

    foreach t $tests {
      foreach {b c s} $t {}
      set slow 0

      if {$c!="make" && $c!="build"} {
        set fd [open $s]
        for {set ii 0} {$ii<100 && ![eof $fd]} {incr ii} {
          set line [gets $fd]
          if {[string match -nocase *testrunner:* $line]} {
            regexp -nocase {.*testrunner:(.*)} $line -> properties
            foreach p $properties {
              if {$p=="slow"} { set slow 1 }
              if {$p=="superslow"} { set slow 2 }
            }
          }
        }
        close $fd
      }

      if {$c=="make" && $b==""} {
        # --fuzztest option
        set slow 1
      }

      if {$c=="veryquick"} {
        set c ""
      }

      set state ready
      if {$b!="" && $c!="build"} {
        set state ""
      }

      trdb eval { 
        INSERT INTO script(build, config, filename, slow, state) 
            VALUES ($b, $c, $s, $slow, $state) 
      }
    }
  }
}

proc script_input_ready {fd iJob b c f} {
  global TRG
  global O
  global T

  if {[eof $fd]} {
    set ::done 1
    fconfigure $fd -blocking 1
    set state "done"
    set rc [catch { close $fd } msg]
    if {$rc} { 
      puts "FAILED: $b $c $f"
      set state "failed" 
    }

    set tm [expr [clock_milliseconds] - $T($iJob)]

    puts $TRG(log) "### $b ### $c ### $f ${tm}ms ($state)"
    puts $TRG(log) [string trim $O($iJob)]

    r_write_db {
      set output $O($iJob)
      trdb eval {
        UPDATE script SET output = $output, state=$state, time=$tm
        WHERE (build, config, filename) = ($b, $c, $f)
      }
      if {$state=="done" && $c=="build"} {
        trdb eval {
          UPDATE script SET state = 'ready' WHERE (build, state)==($b, '')
        }
      }
    }

    dirs_freeDir $iJob
    launch_some_jobs
    incr ::wakeup
  } else {
    set rc [catch { gets $fd line } res]
    if {$rc} {
      puts "ERROR $res"
    } 
    if {$res>=0} {
      append O($iJob) "$line\n"
    }
  }

}

proc dirname {ii} {
  return "testdir$ii"
}

proc launch_another_job {iJob} {
  global TRG
  global O
  global T

  set testfixture [info nameofexec]
  set script $TRG(info_script)

  set dir [dirname $iJob]
  create_or_clear_dir $dir

  set O($iJob) ""
  
  set job [r_get_next_job $iJob]
  if {$job==""} { return 0 }

  foreach {b c f} $job {}

  if {$c=="build"} {
    set testdir [file dirname $TRG(info_script)]
    set srcdir [file dirname $testdir]
    set builddir [build_to_dirname $b]
    create_or_clear_dir $builddir

    if {$b=="Zipvfs"} {
      set script [zipvfs_testrunner_script]
    } else {
      set     cmd [info nameofexec]
      lappend cmd [file join $testdir releasetest_data.tcl]
      lappend cmd trscript
      if {$TRG(platform)=="win"} { lappend cmd -msvc }
      lappend cmd $b $srcdir
      set script [exec {*}$cmd]
    }

    set fd [open [file join $builddir $TRG(make)] w]
    puts $fd $script
    close $fd

    puts "Launching build \"$b\" in directory $builddir..."
    set target coretestprogs
    if {$b=="User-Auth"}  { set target testfixture }

    set cmd "$TRG(makecmd) $target"
    set dir $builddir

  } elseif {$c=="make"} {
    if {$b==""} {
      if {$f!="fuzztest"} { error "corruption in testrunner.db!" }
      # Special case - run [make fuzztest] 
      set makedir [file dirname $testfixture]
      if {$TRG(platform)=="win"} {
        error "how?"
      } else {
        set cmd [list make -C $makedir fuzztest]
      }
    } else {
      set builddir [build_to_dirname $b]
      copy_dir $builddir $dir
      set cmd "$TRG(makecmd) $f"
    }
  } else {
    if {$b==""} {
      set testfixture [info nameofexec]
    } else {
      set tail testfixture
      if {$TRG(platform)=="win"} { set tail testfixture.exe }
      set testfixture [file normalize [file join [build_to_dirname $b] $tail]]
    }

    if {$c=="valgrind"} {
      set testfixture "valgrind -v --error-exitcode=1 $testfixture"
      set ::env(OMIT_MISUSE) 1
    }
    set cmd [concat $testfixture [list $script $c $f]]
  }

  set pwd [pwd]
  cd $dir
  set fd [open "|$cmd 2>@1" r]
  cd $pwd
  set pid [pid $fd]

  fconfigure $fd -blocking false
  fileevent $fd readable [list script_input_ready $fd $iJob $b $c $f]
  unset -nocomplain ::env(OMIT_MISUSE)

  return 1
}

proc one_line_report {} {
  global TRG

  set tm [expr [clock_milliseconds] - $TRG(starttime)]
  set tm [format "%d" [expr int($tm/1000.0 + 0.5)]]

  foreach s {ready running done failed} {
    set v($s,build) 0
    set v($s,make) 0
    set v($s,script) 0
  }

  r_write_db {
    trdb eval {
      SELECT state, jobtype, count(*) AS cnt 
      FROM script 
      GROUP BY state, jobtype
    } {
      set v($state,$jobtype) $cnt
      if {[info exists t($jobtype)]} {
        incr t($jobtype) $cnt
      } else {
        set t($jobtype) $cnt
      }
    }
  }

  set text ""
  foreach j [array names t] {
    set fin [expr $v(done,$j) + $v(failed,$j)]
    lappend text "$j ($fin/$t($j)) f=$v(failed,$j) r=$v(running,$j)"
  }

  if {[info exists TRG(reportlength)]} {
    puts -nonewline "[string repeat " " $TRG(reportlength)]\r"
  }
  set report "${tm}s: [join $text { }]"
  set TRG(reportlength) [string length $report]
  if {[string length $report]<80} {
    puts -nonewline "$report\r"
    flush stdout
  } else {
    puts $report
  }

  after $TRG(reporttime) one_line_report
}

proc launch_some_jobs {} {
  global TRG
  r_write_db {
    set nJob [trdb one { SELECT value FROM config WHERE name='njob' }]
  }
  while {[dirs_nHelper]<$nJob} {
    set iDir [dirs_allocDir]
    if {0==[launch_another_job $iDir]} {
      dirs_freeDir $iDir
      break;
    }
  }
}

proc run_testset {} {
  global TRG
  set ii 0

  set TRG(starttime) [clock_milliseconds]
  set TRG(log) [open $TRG(logname) w]

  launch_some_jobs
    # launch_another_job $ii

  one_line_report
  while {[dirs_nHelper]>0} {
    after 500 {incr ::wakeup}
    vwait ::wakeup
  }
  close $TRG(log)
  one_line_report

  r_write_db {
    set nErr [trdb one {SELECT count(*) FROM script WHERE state='failed'}]
    if {$nErr>0} {
      puts "$nErr failures:"
      trdb eval {
        SELECT build, config, filename FROM script WHERE state='failed'
      } {
        puts "FAILED: $build $config $filename"
      }
    }
  }

  puts "\nTest database is $TRG(dbname)"
  puts "Test log is $TRG(logname)"
}


sqlite3 trdb $TRG(dbname)
trdb timeout $TRG(timeout)
set tm [lindex [time { make_new_testset }] 0]
if {$TRG(nJob)>1} {
  puts "splitting work across $TRG(nJob) cores"
}
puts "built testset in [expr $tm/1000]ms.."
run_testset
trdb close
#puts [pwd]