sqlite-3.40.0/test/testrunner.tcl

#-------------------------------------------------------------------------
# Usage:
#
proc usage {} {
  set a0 testrunner.tcl

  puts stderr "Usage: $a0 ?SWITCHES? ?all|veryquick? ?PATTERNS?"
  puts stderr ""
  puts stderr "where SWITCHES are:"
  puts stderr "    --jobs NUMBER-OF-JOBS"
  puts stderr ""
  puts stderr "Examples:"
  puts stderr "    $a0                    # Run veryquick.test tests"
  puts stderr "    $a0 all                # Run all tests"
  puts stderr "    $a0 veryquick rtree%   # Run all test scripts from veryquick.test that match 'rtree%'"
  puts stderr "    $a0 alter% fts5%       # Run all test scripts that match 'alter%' or 'rtree%'"

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

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

  CREATE TABLE script(
    filename TEXT PRIMARY KEY,    -- full path to test script
    state TEXT CHECK( state IN ('ready', 'running', 'done') ),
    testfixtureid,                -- Id of process that ran script
    time INTEGER,                 -- Time in ms
    nerr INTEGER,                 -- if 'done', the number of errors
    ntest INTEGER,                -- if 'done', the number of tests
    output TEXT                   -- full output of test script
  );

  CREATE TABLE malloc(
    id INTEGER PRIMARY KEY,
    nmalloc INTEGER,
    nbyte INTEGER,
    leaker TEXT
  );

  CREATE TABLE msg(
    id INTEGER PRIMARY KEY,
    msg TEXT
  );
}
#-------------------------------------------------------------------------

#-------------------------------------------------------------------------
# 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 {} {
  set ret 4
  catch {
    set fd [open "|nproc" r]
    set ret [gets $fd]
    close $fd
    set ret [expr $ret]
  }
  return $ret
}

proc default_njob {} {
  set nCore [guess_number_of_cores]
  set nHelper [expr int($nCore*0.75)]
  expr $nHelper>0 ? $nHelper : 1
}
#-------------------------------------------------------------------------


set R(dbname) [file normalize testrunner.db]
set R(logname) [file normalize testrunner.log]
set R(info_script) [file normalize [info script]]
set R(timeout) 10000              ;# Default busy-timeout for testrunner.
set R(nJob)    [default_njob]     ;# Default number of helper processes
set R(leaker)  ""                 ;# Name of first script to leak memory

set R(patternlist) [list]

set testdir [file dirname $argv0]
source $testdir/testset.tcl

# Parse the command line options. There are two ways to invoke this
# script - to create a helper or coordinator process. If there are
# no helper processes, the coordinator runs test scripts.
#
# To create a helper process:
#
#    testrunner.tcl helper ID
#
# where ID is an integer greater than 0. The process will create and
# run tests in the "testdir$ID" directory. Helper processes are only
# created by coordinators - there is no need for a user to create
# helper processes manually.
#
# If the first argument is anything other than "helper", then a coordinator
# process is started. See the implementation of the [usage] proc above for
# details.
#
switch -- [lindex $argv 0] {
  helper {
    set R(helper) 1
    set R(helper_id) [lindex $argv 1]
    set argv [list --testdir=testdir$R(helper_id)]
  }

  default {
    set R(helper) 0
    set R(helper_id) 0

  }
}
if {$R(helper)==0} {
  for {set ii 0} {$ii < [llength $argv]} {incr ii} {
    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 R(nJob) [lindex $argv $ii]
      } else {
        usage
      }
    } else {
      lappend R(patternlist) [string map {% * _ .} $a]
    }
  }

  set argv [list]
}

source $testdir/tester.tcl
db close


proc r_write_db {tcl} {
  global R
  sqlite3 db $R(dbname)
  db timeout $R(timeout)
  db eval { BEGIN EXCLUSIVE }

  uplevel $tcl

  db eval { COMMIT }
  db close
}

proc make_new_testset {} {
  global R

  set scripts [testset_patternlist $R(patternlist)]
  r_write_db {
    db eval $R(schema)
    foreach s $scripts {
      db eval { INSERT INTO script(filename, state) VALUES ($s, 'ready') }
    }
  }
}

proc get_next_test {} {
  global R
  set myid $R(helper_id)

  r_write_db {
    set f [db one {
      SELECT filename FROM script WHERE state='ready' ORDER BY 1 LIMIT 1
    }]
    if {$f!=""} {
      db eval {
        UPDATE script SET state='running', testfixtureid=$myid WHERE filename=$f
      }
    }
  }

  return $f
}

proc r_set_test_result {filename ms nerr ntest output} {
  global R

  set f [file tail $filename]
  if {$nerr==0} {
    set msg "$f... Ok"
  } else {
    set msg "$f... FAILED - $nerr errors of $ntest tests"
  }
  append msg " (${ms}ms)"
  if {$R(helper)} {
    append msg " (helper $R(helper_id))"
  }

  sqlite3_shutdown
  set nMalloc [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]
  set nByte   [sqlite3_memory_used]
  if {($nByte>0 || $nMalloc>0) && $R(leaker)==""} {
    set R(leaker) $filename
  }

  r_write_db {
    db eval {
      UPDATE script
        SET state='done', output=$output, nerr=$nerr, ntest=$ntest, time=$ms
      WHERE filename=$filename;

      INSERT INTO msg(msg) VALUES ($msg);
    }
  }
}

set R(iNextMsg) 1
proc r_get_messages {{db ""}} {
  global R

  if {$db==""} {
    sqlite3 rgmhandle $R(dbname)
    set dbhandle rgmhandle
    $dbhandle timeout $R(timeout)
  } else {
    set dbhandle $db
  }

  $dbhandle transaction {
    set next $R(iNextMsg)
    set ret [$dbhandle eval {SELECT msg FROM msg WHERE id>=$next}]
    set R(iNextMsg) [$dbhandle one {SELECT COALESCE(max(id), 0)+1 FROM msg}]
  }

  if {$db==""} {
    rgmhandle close
  }

  set ret
}

# This is called after all tests have been run to write the leaked memory
# report into the malloc table of testrunner.db.
#
proc r_memory_report {} {
  global R

  sqlite3_shutdown

  set nMalloc [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]
  set nByte   [sqlite3_memory_used]
  set id $R(helper_id)
  set leaker $R(leaker)

  r_write_db {
    db eval {
      INSERT INTO malloc(id, nMalloc, nByte, leaker)
        VALUES($id, $nMalloc, $nByte, $leaker)
    }
  }
}


#--------------------------------------------------------------------------
#
set ::R_INSTALL_PUTS_WRAPPER {
  proc puts_sts_wrapper {args} {
    set n [llength $args]
    if {$n==1 || ($n==2 && [string first [lindex $args 0] -nonewline]==0)} {
      uplevel puts_into_caller $args
    } else {
      # A channel was explicitly specified.
      uplevel puts_sts_original $args
    }
  }
  rename puts puts_sts_original
  proc puts {args} { uplevel puts_sts_wrapper $args }
}

proc r_install_puts_wrapper {} $::R_INSTALL_PUTS_WRAPPER
proc r_uninstall_puts_wrapper {} {
  rename puts ""
  rename puts_sts_original puts
}

proc slave_test_script {script} {

  # Create the interpreter used to run the test script.
  interp create tinterp

  # Populate some global variables that tester.tcl expects to see.
  foreach {var value} [list              \
    ::argv0 $::argv0                     \
    ::argv  {}                           \
    ::SLAVE 1                            \
  ] {
    interp eval tinterp [list set $var $value]
  }

  # The alias used to access the global test counters.
  tinterp alias set_test_counter set_test_counter

  # Set up an empty ::cmdlinearg array in the slave.
  interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]]

  # Set up the ::G array in the slave.
  interp eval tinterp [list array set ::G [array get ::G]]
  interp eval tinterp [list set ::G(runner.tcl) 1]

  interp eval tinterp $::R_INSTALL_PUTS_WRAPPER
  tinterp alias puts_into_caller puts_into_caller

  # Load the various test interfaces implemented in C.
  load_testfixture_extensions tinterp

  # Run the test script.
  set rc [catch { interp eval tinterp $script } msg opt]
  if {$rc} {
    puts_into_caller $msg
    puts_into_caller [dict get $opt -errorinfo]
    incr ::TC(errors)
  }

  # Check if the interpreter call [run_thread_tests]
  if { [interp eval tinterp {info exists ::run_thread_tests_called}] } {
    set ::run_thread_tests_called 1
  }

  # Delete the interpreter used to run the test script.
  interp delete tinterp
}

proc slave_test_file {zFile} {
  set tail [file tail $zFile]

  # Remember the value of the shared-cache setting. So that it is possible
  # to check afterwards that it was not modified by the test script.
  #
  ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] }

  # Run the test script in a slave interpreter.
  #
  unset -nocomplain ::run_thread_tests_called
  reset_prng_state
  set ::sqlite_open_file_count 0
  set time [time { slave_test_script [list source $zFile] }]
  set ms [expr [lindex $time 0] / 1000]

  r_install_puts_wrapper

  # Test that all files opened by the test script were closed. Omit this
  # if the test script has "thread" in its name. The open file counter
  # is not thread-safe.
  #
  if {[info exists ::run_thread_tests_called]==0} {
    do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0}
  }
  set ::sqlite_open_file_count 0

  # Test that the global "shared-cache" setting was not altered by
  # the test script.
  #
  ifcapable shared_cache {
    set res [expr {[sqlite3_enable_shared_cache] == $scs}]
    do_test ${tail}-sharedcachesetting [list set {} $res] 1
  }

  # Add some info to the output.
  #
  output2 "Time: $tail $ms ms"
  show_memstats

  r_uninstall_puts_wrapper
  return $ms
}

proc puts_into_caller {args} {
  global R
  if {[llength $args]==1} {
    append R(output) [lindex $args 0]
    append R(output) "\n"
  } else {
    append R(output) [lindex $args 1]
  }
}

#-------------------------------------------------------------------------
#
proc r_final_report {} {
  global R

  sqlite3 db $R(dbname)
  db timeout $R(timeout)

  set errcode 0

  # Create the text log file. This is just the concatenation of the
  # 'output' column of the database for every script that was run.
  set fd [open $R(logname) w]
  db eval {SELECT output FROM script ORDER BY filename} {
    puts $fd $output
  }
  close $fd

  # Check if any scripts reported errors. If so, print one line noting
  # how many errors, and another identifying the scripts in which they
  # occured. Or, if no errors occurred, print out "no errors at all!".
  sqlite3 db $R(dbname)
  db timeout $R(timeout)
  db eval { SELECT sum(nerr) AS nerr, sum(ntest) AS ntest FROM script } { }
  puts "$nerr errors from $ntest tests."
  if {$nerr>0} {
    db eval { SELECT filename FROM script WHERE nerr>0 } {
      lappend errlist [file tail $filename]
    }
    puts "Errors in: $errlist"
    set errcode 1
  }

  # Check if any scripts were not run or did not finish. Print out a
  # line identifying them if there are any.
  set errlist [list]
  db eval { SELECT filename FROM script WHERE state!='done' } {
    lappend errlist [file tail $filename]
  }
  if {$errlist!=[list]} {
    puts "Tests DID NOT FINISH (crashed?): $errlist"
    set errcode 1
  }

  set bLeak 0
  db eval {
    SELECT id, nmalloc, nbyte, leaker FROM malloc
      WHERE nmalloc>0 OR nbyte>0
  } {
    if {$id==0} {
      set line "This process "
    } else {
      set line "Helper $id "
    }
    append line "leaked $nbyte byte in $nmalloc allocations"
    if {$leaker!=""} { append line " (perhaps in [file tail $leaker])" }
    puts $line
    set bLeak 1
  }
  if {$bLeak==0} {
    puts "No leaks - all allocations freed."
  }

  db close

  puts "Test database is $R(dbname)"
  puts "Test log file is $R(logname)"
  if {$errcode} {
    puts "This test has FAILED."
  }
  return $errcode
}


if {$R(helper)==0} {
  make_new_testset
}

set R(nHelperRunning) 0
if {$R(helper)==0 && $R(nJob)>1} {
  cd $cmdlinearg(TESTFIXTURE_HOME)
  for {set ii 1} {$ii <= $R(nJob)} {incr ii} {
    set cmd "[info nameofexec] $R(info_script) helper $ii 2>@1"
    puts "Launching helper $ii ($cmd)"
    set chan [open "|$cmd" r]
    fconfigure $chan -blocking false
    fileevent $chan readable [list r_helper_readable $ii $chan]
    incr R(nHelperRunning)
  }
  cd $cmdlinearg(testdir)
}

proc r_helper_readable {id chan} {
  set data [gets $chan]
  if {$data!=""} { puts "helper $id:[gets $chan]" }
  if {[eof $chan]} {
    puts "helper $id is finished"
    incr ::R(nHelperRunning) -1
    close $chan
  }
}

if {$R(nHelperRunning)==0} {
  while { ""!=[set f [get_next_test]] } {
    set R(output) ""
    set TC(count) 0
    set TC(errors) 0
    set ms [slave_test_file $f]

    r_set_test_result $f $ms $TC(errors) $TC(count) $R(output)

    if {$R(helper)==0} {
      foreach msg [r_get_messages] { puts $msg }
    }
  }

  # Tests are finished - write a record into testrunner.db describing
  # any memory leaks.
  r_memory_report

} else {
  set TTT 0
  sqlite3 db $R(dbname)
  db timeout $R(timeout)
  while {$R(nHelperRunning)>0} {
    after 250 { incr TTT }
    vwait TTT
    foreach msg [r_get_messages db] { puts $msg }
  }
  db close
}

set errcode 0
if {$R(helper)==0} {
  set errcode [r_final_report]
}

exit $errcode