third_party/sqlite/src/test/tester.tcl

   1 # 2001 September 15
   2 #
   3 # The author disclaims copyright to this source code.  In place of
   4 # a legal notice, here is a blessing:
   5 #
   6 #    May you do good and not evil.
   7 #    May you find forgiveness for yourself and forgive others.
   8 #    May you share freely, never taking more than you give.
   9 #
  10 #***********************************************************************
  11 # This file implements some common TCL routines used for regression
  12 # testing the SQLite library
  13 #
  14 # $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $
  15
  16 #-------------------------------------------------------------------------
  17 # The commands provided by the code in this file to help with creating
  18 # test cases are as follows:
  19 #
  20 # Commands to manipulate the db and the file-system at a high level:
  21 #
  22 #      copy_file              FROM TO
  23 #      drop_all_table         ?DB?
  24 #      forcedelete            FILENAME
  25 #
  26 # Test the capability of the SQLite version built into the interpreter to
  27 # determine if a specific test can be run:
  28 #
  29 #      ifcapable              EXPR
  30 #
  31 # Calulate checksums based on database contents:
  32 #
  33 #      dbcksum                DB DBNAME
  34 #      allcksum               ?DB?
  35 #      cksum                  ?DB?
  36 #
  37 # Commands to execute/explain SQL statements:
  38 #
  39 #      stepsql                DB SQL
  40 #      execsql2               SQL
  41 #      explain_no_trace       SQL
  42 #      explain                SQL ?DB?
  43 #      catchsql               SQL ?DB?
  44 #      execsql                SQL ?DB?
  45 #
  46 # Commands to run test cases:
  47 #
  48 #      do_ioerr_test          TESTNAME ARGS...
  49 #      crashsql               ARGS...
  50 #      integrity_check        TESTNAME ?DB?
  51 #      do_test                TESTNAME SCRIPT EXPECTED
  52 #      do_execsql_test        TESTNAME SQL EXPECTED
  53 #      do_catchsql_test       TESTNAME SQL EXPECTED
  54 #
  55 # Commands providing a lower level interface to the global test counters:
  56 #
  57 #      set_test_counter       COUNTER ?VALUE?
  58 #      omit_test              TESTNAME REASON
  59 #      fail_test              TESTNAME
  60 #      incr_ntest
  61 #
  62 # Command run at the end of each test file:
  63 #
  64 #      finish_test
  65 #
  66 # Commands to help create test files that run with the "WAL" and other
  67 # permutations (see file permutations.test):
  68 #
  69 #      wal_is_wal_mode
  70 #      wal_set_journal_mode   ?DB?
  71 #      wal_check_journal_mode TESTNAME?DB?
  72 #      permutation
  73 #      presql
  74 #
  75
  76 # Set the precision of FP arithmatic used by the interpreter. And
  77 # configure SQLite to take database file locks on the page that begins
  78 # 64KB into the database file instead of the one 1GB in. This means
  79 # the code that handles that special case can be tested without creating
  80 # very large database files.
  81 #
  82 set tcl_precision 15
  83 sqlite3_test_control_pending_byte 0x0010000
  84
  85
  86 # If the pager codec is available, create a wrapper for the [sqlite3]
  87 # command that appends "-key {xyzzy}" to the command line. i.e. this:
  88 #
  89 #     sqlite3 db test.db
  90 #
  91 # becomes
  92 #
  93 #     sqlite3 db test.db -key {xyzzy}
  94 #
  95 if {[info command sqlite_orig]==""} {
  96   rename sqlite3 sqlite_orig
  97   proc sqlite3 {args} {
  98     if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} {
  99       # This command is opening a new database connection.
 100       #
 101       if {[info exists ::G(perm:sqlite3_args)]} {
 102         set args [concat $args $::G(perm:sqlite3_args)]
 103       }
 104       if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} {
 105         lappend args -key {xyzzy}
 106       }
 107
 108       set res [uplevel 1 sqlite_orig $args]
 109       if {[info exists ::G(perm:presql)]} {
 110         [lindex $args 0] eval $::G(perm:presql)
 111       }
 112       if {[info exists ::G(perm:dbconfig)]} {
 113         set ::dbhandle [lindex $args 0]
 114         uplevel #0 $::G(perm:dbconfig)
 115       }
 116       set res
 117     } else {
 118       # This command is not opening a new database connection. Pass the
 119       # arguments through to the C implemenation as the are.
 120       #
 121       uplevel 1 sqlite_orig $args
 122     }
 123   }
 124 }
 125
 126 proc execpresql {handle args} {
 127   trace remove execution $handle enter [list execpresql $handle]
 128   if {[info exists ::G(perm:presql)]} {
 129     $handle eval $::G(perm:presql)
 130   }
 131 }
 132
 133 # This command should be called after loading tester.tcl from within
 134 # all test scripts that are incompatible with encryption codecs.
 135 #
 136 proc do_not_use_codec {} {
 137   set ::do_not_use_codec 1
 138   reset_db
 139 }
 140
 141 # The following block only runs the first time this file is sourced. It
 142 # does not run in slave interpreters (since the ::cmdlinearg array is
 143 # populated before the test script is run in slave interpreters).
 144 #
 145 if {[info exists cmdlinearg]==0} {
 146
 147   # Parse any options specified in the $argv array. This script accepts the
 148   # following options:
 149   #
 150   #   --pause
 151   #   --soft-heap-limit=NN
 152   #   --maxerror=NN
 153   #   --malloctrace=N
 154   #   --backtrace=N
 155   #   --binarylog=N
 156   #   --soak=N
 157   #   --start=[$permutation:]$testfile
 158   #
 159   set cmdlinearg(soft-heap-limit)    0
 160   set cmdlinearg(maxerror)        1000
 161   set cmdlinearg(malloctrace)        0
 162   set cmdlinearg(backtrace)         10
 163   set cmdlinearg(binarylog)          0
 164   set cmdlinearg(soak)               0
 165   set cmdlinearg(start)             ""
 166
 167   set leftover [list]
 168   foreach a $argv {
 169     switch -regexp -- $a {
 170       {^-+pause$} {
 171         # Wait for user input before continuing. This is to give the user an
 172         # opportunity to connect profiling tools to the process.
 173         puts -nonewline "Press RETURN to begin..."
 174         flush stdout
 175         gets stdin
 176       }
 177       {^-+soft-heap-limit=.+$} {
 178         foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break
 179       }
 180       {^-+maxerror=.+$} {
 181         foreach {dummy cmdlinearg(maxerror)} [split $a =] break
 182       }
 183       {^-+malloctrace=.+$} {
 184         foreach {dummy cmdlinearg(malloctrace)} [split $a =] break
 185         if {$cmdlinearg(malloctrace)} {
 186           sqlite3_memdebug_log start
 187         }
 188       }
 189       {^-+backtrace=.+$} {
 190         foreach {dummy cmdlinearg(backtrace)} [split $a =] break
 191         sqlite3_memdebug_backtrace $value
 192       }
 193       {^-+binarylog=.+$} {
 194         foreach {dummy cmdlinearg(binarylog)} [split $a =] break
 195       }
 196       {^-+soak=.+$} {
 197         foreach {dummy cmdlinearg(soak)} [split $a =] break
 198         set ::G(issoak) $cmdlinearg(soak)
 199       }
 200       {^-+start=.+$} {
 201         foreach {dummy cmdlinearg(start)} [split $a =] break
 202
 203         set ::G(start:file) $cmdlinearg(start)
 204         if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} {
 205           set ::G(start:permutation) ${s.perm}
 206           set ::G(start:file)        ${s.file}
 207         }
 208         if {$::G(start:file) == ""} {unset ::G(start:file)}
 209       }
 210       default {
 211         lappend leftover $a
 212       }
 213     }
 214   }
 215   set argv $leftover
 216
 217   # Install the malloc layer used to inject OOM errors. And the 'automatic'
 218   # extensions. This only needs to be done once for the process.
 219   #
 220   sqlite3_shutdown
 221   install_malloc_faultsim 1
 222   sqlite3_initialize
 223   autoinstall_test_functions
 224
 225   # If the --binarylog option was specified, create the logging VFS. This
 226   # call installs the new VFS as the default for all SQLite connections.
 227   #
 228   if {$cmdlinearg(binarylog)} {
 229     vfslog new binarylog {} vfslog.bin
 230   }
 231
 232   # Set the backtrace depth, if malloc tracing is enabled.
 233   #
 234   if {$cmdlinearg(malloctrace)} {
 235     sqlite3_memdebug_backtrace $cmdlinearg(backtrace)
 236   }
 237 }
 238
 239 # Update the soft-heap-limit each time this script is run. In that
 240 # way if an individual test file changes the soft-heap-limit, it
 241 # will be reset at the start of the next test file.
 242 #
 243 sqlite3_soft_heap_limit $cmdlinearg(soft-heap-limit)
 244
 245 # Create a test database
 246 #
 247 proc reset_db {} {
 248   catch {db close}
 249   file delete -force test.db
 250   file delete -force test.db-journal
 251   file delete -force test.db-wal
 252   sqlite3 db ./test.db
 253   set ::DB [sqlite3_connection_pointer db]
 254   if {[info exists ::SETUP_SQL]} {
 255     db eval $::SETUP_SQL
 256   }
 257 }
 258 reset_db
 259
 260 # Abort early if this script has been run before.
 261 #
 262 if {[info exists TC(count)]} return
 263
 264 # Make sure memory statistics are enabled.
 265 #
 266 sqlite3_config_memstatus 1
 267
 268 # Initialize the test counters and set up commands to access them.
 269 # Or, if this is a slave interpreter, set up aliases to write the
 270 # counters in the parent interpreter.
 271 #
 272 if {0==[info exists ::SLAVE]} {
 273   set TC(errors)    0
 274   set TC(count)     0
 275   set TC(fail_list) [list]
 276   set TC(omit_list) [list]
 277
 278   proc set_test_counter {counter args} {
 279     if {[llength $args]} {
 280       set ::TC($counter) [lindex $args 0]
 281     }
 282     set ::TC($counter)
 283   }
 284 }
 285
 286 # Record the fact that a sequence of tests were omitted.
 287 #
 288 proc omit_test {name reason} {
 289   set omitList [set_test_counter omit_list]
 290   lappend omitList [list $name $reason]
 291   set_test_counter omit_list $omitList
 292 }
 293
 294 # Record the fact that a test failed.
 295 #
 296 proc fail_test {name} {
 297   set f [set_test_counter fail_list]
 298   lappend f $name
 299   set_test_counter fail_list $f
 300   set_test_counter errors [expr [set_test_counter errors] + 1]
 301
 302   set nFail [set_test_counter errors]
 303   if {$nFail>=$::cmdlinearg(maxerror)} {
 304     puts "*** Giving up..."
 305     finalize_testing
 306   }
 307 }
 308
 309 # Increment the number of tests run
 310 #
 311 proc incr_ntest {} {
 312   set_test_counter count [expr [set_test_counter count] + 1]
 313 }
 314
 315
 316 # Invoke the do_test procedure to run a single test
 317 #
 318 proc do_test {name cmd expected} {
 319
 320   global argv cmdlinearg
 321
 322   fix_testname name
 323
 324   sqlite3_memdebug_settitle $name
 325
 326 #  if {[llength $argv]==0} {
 327 #    set go 1
 328 #  } else {
 329 #    set go 0
 330 #    foreach pattern $argv {
 331 #      if {[string match $pattern $name]} {
 332 #        set go 1
 333 #        break
 334 #      }
 335 #    }
 336 #  }
 337
 338   if {[info exists ::G(perm:prefix)]} {
 339     set name "$::G(perm:prefix)$name"
 340   }
 341
 342   incr_ntest
 343   puts -nonewline $name...
 344   flush stdout
 345   if {[catch {uplevel #0 "$cmd;\n"} result]} {
 346     puts "\nError: $result"
 347     fail_test $name
 348   } elseif {[string compare $result $expected]} {
 349     puts "\nExpected: \[$expected\]\n     Got: \[$result\]"
 350     fail_test $name
 351   } else {
 352     puts " Ok"
 353   }
 354   flush stdout
 355 }
 356
 357 proc fix_testname {varname} {
 358   upvar $varname testname
 359   if {[info exists ::testprefix]
 360    && [string is digit [string range $testname 0 0]]
 361   } {
 362     set testname "${::testprefix}-$testname"
 363   }
 364 }
 365
 366 proc do_execsql_test {testname sql {result {}}} {
 367   fix_testname testname
 368   uplevel do_test $testname [list "execsql {$sql}"] [list [list {*}$result]]
 369 }
 370 proc do_catchsql_test {testname sql result} {
 371   fix_testname testname
 372   uplevel do_test $testname [list "catchsql {$sql}"] [list $result]
 373 }
 374 proc do_eqp_test {name sql res} {
 375   uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res]
 376 }
 377
 378 #-------------------------------------------------------------------------
 379 #   Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST
 380 #
 381 # Where switches are:
 382 #
 383 #   -errorformat FMTSTRING
 384 #   -count
 385 #   -query SQL
 386 #   -tclquery TCL
 387 #   -repair TCL
 388 #
 389 proc do_select_tests {prefix args} {
 390
 391   set testlist [lindex $args end]
 392   set switches [lrange $args 0 end-1]
 393
 394   set errfmt ""
 395   set countonly 0
 396   set tclquery ""
 397   set repair ""
 398
 399   for {set i 0} {$i < [llength $switches]} {incr i} {
 400     set s [lindex $switches $i]
 401     set n [string length $s]
 402     if {$n>=2 && [string equal -length $n $s "-query"]} {
 403       set tclquery [list execsql [lindex $switches [incr i]]]
 404     } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} {
 405       set tclquery [lindex $switches [incr i]]
 406     } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} {
 407       set errfmt [lindex $switches [incr i]]
 408     } elseif {$n>=2 && [string equal -length $n $s "-repair"]} {
 409       set repair [lindex $switches [incr i]]
 410     } elseif {$n>=2 && [string equal -length $n $s "-count"]} {
 411       set countonly 1
 412     } else {
 413       error "unknown switch: $s"
 414     }
 415   }
 416
 417   if {$countonly && $errfmt!=""} {
 418     error "Cannot use -count and -errorformat together"
 419   }
 420   set nTestlist [llength $testlist]
 421   if {$nTestlist%3 || $nTestlist==0 } {
 422     error "SELECT test list contains [llength $testlist] elements"
 423   }
 424
 425   eval $repair
 426   foreach {tn sql res} $testlist {
 427     if {$tclquery != ""} {
 428       execsql $sql
 429       uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]]
 430     } elseif {$countonly} {
 431       set nRow 0
 432       db eval $sql {incr nRow}
 433       uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res]
 434     } elseif {$errfmt==""} {
 435       uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]]
 436     } else {
 437       set res [list 1 [string trim [format $errfmt {*}$res]]]
 438       uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res]
 439     }
 440     eval $repair
 441   }
 442
 443 }
 444
 445 proc delete_all_data {} {
 446   db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} {
 447     db eval "DELETE FROM '[string map {' ''} $t]'"
 448   }
 449 }
 450
 451 # Run an SQL script.
 452 # Return the number of microseconds per statement.
 453 #
 454 proc speed_trial {name numstmt units sql} {
 455   puts -nonewline [format {%-21.21s } $name...]
 456   flush stdout
 457   set speed [time {sqlite3_exec_nr db $sql}]
 458   set tm [lindex $speed 0]
 459   if {$tm == 0} {
 460     set rate [format %20s "many"]
 461   } else {
 462     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
 463   }
 464   set u2 $units/s
 465   puts [format {%12d uS %s %s} $tm $rate $u2]
 466   global total_time
 467   set total_time [expr {$total_time+$tm}]
 468   lappend ::speed_trial_times $name $tm
 469 }
 470 proc speed_trial_tcl {name numstmt units script} {
 471   puts -nonewline [format {%-21.21s } $name...]
 472   flush stdout
 473   set speed [time {eval $script}]
 474   set tm [lindex $speed 0]
 475   if {$tm == 0} {
 476     set rate [format %20s "many"]
 477   } else {
 478     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
 479   }
 480   set u2 $units/s
 481   puts [format {%12d uS %s %s} $tm $rate $u2]
 482   global total_time
 483   set total_time [expr {$total_time+$tm}]
 484   lappend ::speed_trial_times $name $tm
 485 }
 486 proc speed_trial_init {name} {
 487   global total_time
 488   set total_time 0
 489   set ::speed_trial_times [list]
 490   sqlite3 versdb :memory:
 491   set vers [versdb one {SELECT sqlite_source_id()}]
 492   versdb close
 493   puts "SQLite $vers"
 494 }
 495 proc speed_trial_summary {name} {
 496   global total_time
 497   puts [format {%-21.21s %12d uS TOTAL} $name $total_time]
 498
 499   if { 0 } {
 500     sqlite3 versdb :memory:
 501     set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0]
 502     versdb close
 503     puts "CREATE TABLE IF NOT EXISTS time(version, script, test, us);"
 504     foreach {test us} $::speed_trial_times {
 505       puts "INSERT INTO time VALUES('$vers', '$name', '$test', $us);"
 506     }
 507   }
 508 }
 509
 510 # Run this routine last
 511 #
 512 proc finish_test {} {
 513   catch {db close}
 514   catch {db2 close}
 515   catch {db3 close}
 516   if {0==[info exists ::SLAVE]} { finalize_testing }
 517 }
 518 proc finalize_testing {} {
 519   global sqlite_open_file_count
 520
 521   set omitList [set_test_counter omit_list]
 522
 523   catch {db close}
 524   catch {db2 close}
 525   catch {db3 close}
 526
 527   vfs_unlink_test
 528   sqlite3 db {}
 529   # sqlite3_clear_tsd_memdebug
 530   db close
 531   sqlite3_reset_auto_extension
 532
 533   sqlite3_soft_heap_limit 0
 534   set nTest [incr_ntest]
 535   set nErr [set_test_counter errors]
 536
 537   puts "$nErr errors out of $nTest tests"
 538   if {$nErr>0} {
 539     puts "Failures on these tests: [set_test_counter fail_list]"
 540   }
 541   run_thread_tests 1
 542   if {[llength $omitList]>0} {
 543     puts "Omitted test cases:"
 544     set prec {}
 545     foreach {rec} [lsort $omitList] {
 546       if {$rec==$prec} continue
 547       set prec $rec
 548       puts [format {  %-12s %s} [lindex $rec 0] [lindex $rec 1]]
 549     }
 550   }
 551   if {$nErr>0 && ![working_64bit_int]} {
 552     puts "******************************************************************"
 553     puts "N.B.:  The version of TCL that you used to build this test harness"
 554     puts "is defective in that it does not support 64-bit integers.  Some or"
 555     puts "all of the test failures above might be a result from this defect"
 556     puts "in your TCL build."
 557     puts "******************************************************************"
 558   }
 559   if {$::cmdlinearg(binarylog)} {
 560     vfslog finalize binarylog
 561   }
 562   if {$sqlite_open_file_count} {
 563     puts "$sqlite_open_file_count files were left open"
 564     incr nErr
 565   }
 566   if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 ||
 567               [sqlite3_memory_used]>0} {
 568     puts "Unfreed memory: [sqlite3_memory_used] bytes in\
 569          [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations"
 570     incr nErr
 571     ifcapable memdebug||mem5||(mem3&&debug) {
 572       puts "Writing unfreed memory log to \"./memleak.txt\""
 573       sqlite3_memdebug_dump ./memleak.txt
 574     }
 575   } else {
 576     puts "All memory allocations freed - no leaks"
 577     ifcapable memdebug||mem5 {
 578       sqlite3_memdebug_dump ./memusage.txt
 579     }
 580   }
 581   show_memstats
 582   puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
 583   puts "Current memory usage: [sqlite3_memory_highwater] bytes"
 584   if {[info commands sqlite3_memdebug_malloc_count] ne ""} {
 585     puts "Number of malloc()  : [sqlite3_memdebug_malloc_count] calls"
 586   }
 587   if {$::cmdlinearg(malloctrace)} {
 588     puts "Writing mallocs.sql..."
 589     memdebug_log_sql
 590     sqlite3_memdebug_log stop
 591     sqlite3_memdebug_log clear
 592
 593     if {[sqlite3_memory_used]>0} {
 594       puts "Writing leaks.sql..."
 595       sqlite3_memdebug_log sync
 596       memdebug_log_sql leaks.sql
 597     }
 598   }
 599   foreach f [glob -nocomplain test.db-*-journal] {
 600     file delete -force $f
 601   }
 602   foreach f [glob -nocomplain test.db-mj*] {
 603     file delete -force $f
 604   }
 605   exit [expr {$nErr>0}]
 606 }
 607
 608 # Display memory statistics for analysis and debugging purposes.
 609 #
 610 proc show_memstats {} {
 611   set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]
 612   set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]
 613   set val [format {now %10d  max %10d  max-size %10d} \
 614               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
 615   puts "Memory used:          $val"
 616   set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0]
 617   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
 618   puts "Allocation count:     $val"
 619   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]
 620   set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]
 621   set val [format {now %10d  max %10d  max-size %10d} \
 622               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
 623   puts "Page-cache used:      $val"
 624   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]
 625   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
 626   puts "Page-cache overflow:  $val"
 627   set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]
 628   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
 629   puts "Scratch memory used:  $val"
 630   set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]
 631   set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]
 632   set val [format {now %10d  max %10d  max-size %10d} \
 633                [lindex $x 1] [lindex $x 2] [lindex $y 2]]
 634   puts "Scratch overflow:     $val"
 635   ifcapable yytrackmaxstackdepth {
 636     set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]
 637     set val [format {               max %10d} [lindex $x 2]]
 638     puts "Parser stack depth:    $val"
 639   }
 640 }
 641
 642 # A procedure to execute SQL
 643 #
 644 proc execsql {sql {db db}} {
 645   # puts "SQL = $sql"
 646   uplevel [list $db eval $sql]
 647 }
 648
 649 # Execute SQL and catch exceptions.
 650 #
 651 proc catchsql {sql {db db}} {
 652   # puts "SQL = $sql"
 653   set r [catch [list uplevel [list $db eval $sql]] msg]
 654   lappend r $msg
 655   return $r
 656 }
 657
 658 # Do an VDBE code dump on the SQL given
 659 #
 660 proc explain {sql {db db}} {
 661   puts ""
 662   puts "addr  opcode        p1      p2      p3      p4               p5  #"
 663   puts "----  ------------  ------  ------  ------  ---------------  --  -"
 664   $db eval "explain $sql" {} {
 665     puts [format {%-4d  %-12.12s  %-6d  %-6d  %-6d  % -17s %s  %s} \
 666       $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
 667     ]
 668   }
 669 }
 670
 671 # Show the VDBE program for an SQL statement but omit the Trace
 672 # opcode at the beginning.  This procedure can be used to prove
 673 # that different SQL statements generate exactly the same VDBE code.
 674 #
 675 proc explain_no_trace {sql} {
 676   set tr [db eval "EXPLAIN $sql"]
 677   return [lrange $tr 7 end]
 678 }
 679
 680 # Another procedure to execute SQL.  This one includes the field
 681 # names in the returned list.
 682 #
 683 proc execsql2 {sql} {
 684   set result {}
 685   db eval $sql data {
 686     foreach f $data(*) {
 687       lappend result $f $data($f)
 688     }
 689   }
 690   return $result
 691 }
 692
 693 # Use the non-callback API to execute multiple SQL statements
 694 #
 695 proc stepsql {dbptr sql} {
 696   set sql [string trim $sql]
 697   set r 0
 698   while {[string length $sql]>0} {
 699     if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {
 700       return [list 1 $vm]
 701     }
 702     set sql [string trim $sqltail]
 703 #    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
 704 #      foreach v $VAL {lappend r $v}
 705 #    }
 706     while {[sqlite3_step $vm]=="SQLITE_ROW"} {
 707       for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {
 708         lappend r [sqlite3_column_text $vm $i]
 709       }
 710     }
 711     if {[catch {sqlite3_finalize $vm} errmsg]} {
 712       return [list 1 $errmsg]
 713     }
 714   }
 715   return $r
 716 }
 717
 718 # Delete a file or directory
 719 #
 720 proc forcedelete {args} {
 721   foreach filename $args {
 722     # On windows, sometimes even a [file delete -force] can fail just after
 723     # a file is closed. The cause is usually "tag-alongs" - programs like
 724     # anti-virus software, automatic backup tools and various explorer
 725     # extensions that keep a file open a little longer than we expect, causing
 726     # the delete to fail.
 727     #
 728     # The solution is to wait a short amount of time before retrying the
 729     # delete.
 730     #
 731     set nRetry  50                  ;# Maximum number of retries.
 732     set nDelay 100                  ;# Delay in ms before retrying.
 733     for {set i 0} {$i<$nRetry} {incr i} {
 734       set rc [catch {file delete -force $filename} msg]
 735       if {$rc==0} break
 736       after $nDelay
 737     }
 738     if {$rc} { error $msg }
 739   }
 740 }
 741
 742 # Do an integrity check of the entire database
 743 #
 744 proc integrity_check {name {db db}} {
 745   ifcapable integrityck {
 746     do_test $name [list execsql {PRAGMA integrity_check} $db] {ok}
 747   }
 748 }
 749
 750 proc fix_ifcapable_expr {expr} {
 751   set ret ""
 752   set state 0
 753   for {set i 0} {$i < [string length $expr]} {incr i} {
 754     set char [string range $expr $i $i]
 755     set newstate [expr {[string is alnum $char] || $char eq "_"}]
 756     if {$newstate && !$state} {
 757       append ret {$::sqlite_options(}
 758     }
 759     if {!$newstate && $state} {
 760       append ret )
 761     }
 762     append ret $char
 763     set state $newstate
 764   }
 765   if {$state} {append ret )}
 766   return $ret
 767 }
 768
 769 # Evaluate a boolean expression of capabilities.  If true, execute the
 770 # code.  Omit the code if false.
 771 #
 772 proc ifcapable {expr code {else ""} {elsecode ""}} {
 773   #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
 774   set e2 [fix_ifcapable_expr $expr]
 775   if ($e2) {
 776     set c [catch {uplevel 1 $code} r]
 777   } else {
 778     set c [catch {uplevel 1 $elsecode} r]
 779   }
 780   return -code $c $r
 781 }
 782
 783 # This proc execs a seperate process that crashes midway through executing
 784 # the SQL script $sql on database test.db.
 785 #
 786 # The crash occurs during a sync() of file $crashfile. When the crash
 787 # occurs a random subset of all unsynced writes made by the process are
 788 # written into the files on disk. Argument $crashdelay indicates the
 789 # number of file syncs to wait before crashing.
 790 #
 791 # The return value is a list of two elements. The first element is a
 792 # boolean, indicating whether or not the process actually crashed or
 793 # reported some other error. The second element in the returned list is the
 794 # error message. This is "child process exited abnormally" if the crash
 795 # occured.
 796 #
 797 #   crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
 798 #
 799 proc crashsql {args} {
 800
 801   set blocksize ""
 802   set crashdelay 1
 803   set prngseed 0
 804   set tclbody {}
 805   set crashfile ""
 806   set dc ""
 807   set sql [lindex $args end]
 808
 809   for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {
 810     set z [lindex $args $ii]
 811     set n [string length $z]
 812     set z2 [lindex $args [expr $ii+1]]
 813
 814     if     {$n>1 && [string first $z -delay]==0}     {set crashdelay $z2} \
 815     elseif {$n>1 && [string first $z -seed]==0}      {set prngseed $z2} \
 816     elseif {$n>1 && [string first $z -file]==0}      {set crashfile $z2}  \
 817     elseif {$n>1 && [string first $z -tclbody]==0}   {set tclbody $z2}  \
 818     elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \
 819     elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \
 820     else   { error "Unrecognized option: $z" }
 821   }
 822
 823   if {$crashfile eq ""} {
 824     error "Compulsory option -file missing"
 825   }
 826
 827   # $crashfile gets compared to the native filename in
 828   # cfSync(), which can be different then what TCL uses by
 829   # default, so here we force it to the "nativename" format.
 830   set cfile [string map {\\ \\\\} [file nativename [file join [pwd] $crashfile]]]
 831
 832   set f [open crash.tcl w]
 833   puts $f "sqlite3_crash_enable 1"
 834   puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
 835   puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
 836   puts $f "sqlite3 db test.db -vfs crash"
 837
 838   # This block sets the cache size of the main database to 10
 839   # pages. This is done in case the build is configured to omit
 840   # "PRAGMA cache_size".
 841   puts $f {db eval {SELECT * FROM sqlite_master;}}
 842   puts $f {set bt [btree_from_db db]}
 843   puts $f {btree_set_cache_size $bt 10}
 844   if {$prngseed} {
 845     set seed [expr {$prngseed%10007+1}]
 846     # puts seed=$seed
 847     puts $f "db eval {SELECT randomblob($seed)}"
 848   }
 849
 850   if {[string length $tclbody]>0} {
 851     puts $f $tclbody
 852   }
 853   if {[string length $sql]>0} {
 854     puts $f "db eval {"
 855     puts $f   "$sql"
 856     puts $f "}"
 857   }
 858   close $f
 859   set r [catch {
 860     exec [info nameofexec] crash.tcl >@stdout
 861   } msg]
 862
 863   # Windows/ActiveState TCL returns a slightly different
 864   # error message.  We map that to the expected message
 865   # so that we don't have to change all of the test
 866   # cases.
 867   if {$::tcl_platform(platform)=="windows"} {
 868     if {$msg=="child killed: unknown signal"} {
 869       set msg "child process exited abnormally"
 870     }
 871   }
 872
 873   lappend r $msg
 874 }
 875
 876 # Usage: do_ioerr_test <test number> <options...>
 877 #
 878 # This proc is used to implement test cases that check that IO errors
 879 # are correctly handled. The first argument, <test number>, is an integer
 880 # used to name the tests executed by this proc. Options are as follows:
 881 #
 882 #     -tclprep          TCL script to run to prepare test.
 883 #     -sqlprep          SQL script to run to prepare test.
 884 #     -tclbody          TCL script to run with IO error simulation.
 885 #     -sqlbody          TCL script to run with IO error simulation.
 886 #     -exclude          List of 'N' values not to test.
 887 #     -erc              Use extended result codes
 888 #     -persist          Make simulated I/O errors persistent
 889 #     -start            Value of 'N' to begin with (default 1)
 890 #
 891 #     -cksum            Boolean. If true, test that the database does
 892 #                       not change during the execution of the test case.
 893 #
 894 proc do_ioerr_test {testname args} {
 895
 896   set ::ioerropts(-start) 1
 897   set ::ioerropts(-cksum) 0
 898   set ::ioerropts(-erc) 0
 899   set ::ioerropts(-count) 100000000
 900   set ::ioerropts(-persist) 1
 901   set ::ioerropts(-ckrefcount) 0
 902   set ::ioerropts(-restoreprng) 1
 903   array set ::ioerropts $args
 904
 905   # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
 906   # a couple of obscure IO errors that do not return them.
 907   set ::ioerropts(-erc) 0
 908
 909   set ::go 1
 910   #reset_prng_state
 911   save_prng_state
 912   for {set n $::ioerropts(-start)} {$::go} {incr n} {
 913     set ::TN $n
 914     incr ::ioerropts(-count) -1
 915     if {$::ioerropts(-count)<0} break
 916
 917     # Skip this IO error if it was specified with the "-exclude" option.
 918     if {[info exists ::ioerropts(-exclude)]} {
 919       if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
 920     }
 921     if {$::ioerropts(-restoreprng)} {
 922       restore_prng_state
 923     }
 924
 925     # Delete the files test.db and test2.db, then execute the TCL and
 926     # SQL (in that order) to prepare for the test case.
 927     do_test $testname.$n.1 {
 928       set ::sqlite_io_error_pending 0
 929       catch {db close}
 930       catch {db2 close}
 931       catch {file delete -force test.db}
 932       catch {file delete -force test.db-journal}
 933       catch {file delete -force test2.db}
 934       catch {file delete -force test2.db-journal}
 935       set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
 936       sqlite3_extended_result_codes $::DB $::ioerropts(-erc)
 937       if {[info exists ::ioerropts(-tclprep)]} {
 938         eval $::ioerropts(-tclprep)
 939       }
 940       if {[info exists ::ioerropts(-sqlprep)]} {
 941         execsql $::ioerropts(-sqlprep)
 942       }
 943       expr 0
 944     } {0}
 945
 946     # Read the 'checksum' of the database.
 947     if {$::ioerropts(-cksum)} {
 948       set checksum [cksum]
 949     }
 950
 951     # Set the Nth IO error to fail.
 952     do_test $testname.$n.2 [subst {
 953       set ::sqlite_io_error_persist $::ioerropts(-persist)
 954       set ::sqlite_io_error_pending $n
 955     }] $n
 956
 957     # Create a single TCL script from the TCL and SQL specified
 958     # as the body of the test.
 959     set ::ioerrorbody {}
 960     if {[info exists ::ioerropts(-tclbody)]} {
 961       append ::ioerrorbody "$::ioerropts(-tclbody)\n"
 962     }
 963     if {[info exists ::ioerropts(-sqlbody)]} {
 964       append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
 965     }
 966
 967     # Execute the TCL Script created in the above block. If
 968     # there are at least N IO operations performed by SQLite as
 969     # a result of the script, the Nth will fail.
 970     do_test $testname.$n.3 {
 971       set ::sqlite_io_error_hit 0
 972       set ::sqlite_io_error_hardhit 0
 973       set r [catch $::ioerrorbody msg]
 974       set ::errseen $r
 975       set rc [sqlite3_errcode $::DB]
 976       if {$::ioerropts(-erc)} {
 977         # If we are in extended result code mode, make sure all of the
 978         # IOERRs we get back really do have their extended code values.
 979         # If an extended result code is returned, the sqlite3_errcode
 980         # TCLcommand will return a string of the form:  SQLITE_IOERR+nnnn
 981         # where nnnn is a number
 982         if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {
 983           return $rc
 984         }
 985       } else {
 986         # If we are not in extended result code mode, make sure no
 987         # extended error codes are returned.
 988         if {[regexp {\+\d} $rc]} {
 989           return $rc
 990         }
 991       }
 992       # The test repeats as long as $::go is non-zero.  $::go starts out
 993       # as 1.  When a test runs to completion without hitting an I/O
 994       # error, that means there is no point in continuing with this test
 995       # case so set $::go to zero.
 996       #
 997       if {$::sqlite_io_error_pending>0} {
 998         set ::go 0
 999         set q 0
1000         set ::sqlite_io_error_pending 0
1001       } else {
1002         set q 1
1003       }
1004
1005       set s [expr $::sqlite_io_error_hit==0]
1006       if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
1007         set r 1
1008       }
1009       set ::sqlite_io_error_hit 0
1010
1011       # One of two things must have happened. either
1012       #   1.  We never hit the IO error and the SQL returned OK
1013       #   2.  An IO error was hit and the SQL failed
1014       #
1015       #puts "s=$s r=$r q=$q"
1016       expr { ($s && !$r && !$q) || (!$s && $r && $q) }
1017     } {1}
1018
1019     set ::sqlite_io_error_hit 0
1020     set ::sqlite_io_error_pending 0
1021
1022     # Check that no page references were leaked. There should be
1023     # a single reference if there is still an active transaction,
1024     # or zero otherwise.
1025     #
1026     # UPDATE: If the IO error occurs after a 'BEGIN' but before any
1027     # locks are established on database files (i.e. if the error
1028     # occurs while attempting to detect a hot-journal file), then
1029     # there may 0 page references and an active transaction according
1030     # to [sqlite3_get_autocommit].
1031     #
1032     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
1033       do_test $testname.$n.4 {
1034         set bt [btree_from_db db]
1035         db_enter db
1036         array set stats [btree_pager_stats $bt]
1037         db_leave db
1038         set nRef $stats(ref)
1039         expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}
1040       } {1}
1041     }
1042
1043     # If there is an open database handle and no open transaction,
1044     # and the pager is not running in exclusive-locking mode,
1045     # check that the pager is in "unlocked" state. Theoretically,
1046     # if a call to xUnlock() failed due to an IO error the underlying
1047     # file may still be locked.
1048     #
1049     ifcapable pragma {
1050       if { [info commands db] ne ""
1051         && $::ioerropts(-ckrefcount)
1052         && [db one {pragma locking_mode}] eq "normal"
1053         && [sqlite3_get_autocommit db]
1054       } {
1055         do_test $testname.$n.5 {
1056           set bt [btree_from_db db]
1057           db_enter db
1058           array set stats [btree_pager_stats $bt]
1059           db_leave db
1060           set stats(state)
1061         } 0
1062       }
1063     }
1064
1065     # If an IO error occured, then the checksum of the database should
1066     # be the same as before the script that caused the IO error was run.
1067     #
1068     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
1069       do_test $testname.$n.6 {
1070         catch {db close}
1071         catch {db2 close}
1072         set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
1073         cksum
1074       } $checksum
1075     }
1076
1077     set ::sqlite_io_error_hardhit 0
1078     set ::sqlite_io_error_pending 0
1079     if {[info exists ::ioerropts(-cleanup)]} {
1080       catch $::ioerropts(-cleanup)
1081     }
1082   }
1083   set ::sqlite_io_error_pending 0
1084   set ::sqlite_io_error_persist 0
1085   unset ::ioerropts
1086 }
1087
1088 # Return a checksum based on the contents of the main database associated
1089 # with connection $db
1090 #
1091 proc cksum {{db db}} {
1092   set txt [$db eval {
1093       SELECT name, type, sql FROM sqlite_master order by name
1094   }]\n
1095   foreach tbl [$db eval {
1096       SELECT name FROM sqlite_master WHERE type='table' order by name
1097   }] {
1098     append txt [$db eval "SELECT * FROM $tbl"]\n
1099   }
1100   foreach prag {default_synchronous default_cache_size} {
1101     append txt $prag-[$db eval "PRAGMA $prag"]\n
1102   }
1103   set cksum [string length $txt]-[md5 $txt]
1104   # puts $cksum-[file size test.db]
1105   return $cksum
1106 }
1107
1108 # Generate a checksum based on the contents of the main and temp tables
1109 # database $db. If the checksum of two databases is the same, and the
1110 # integrity-check passes for both, the two databases are identical.
1111 #
1112 proc allcksum {{db db}} {
1113   set ret [list]
1114   ifcapable tempdb {
1115     set sql {
1116       SELECT name FROM sqlite_master WHERE type = 'table' UNION
1117       SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION
1118       SELECT 'sqlite_master' UNION
1119       SELECT 'sqlite_temp_master' ORDER BY 1
1120     }
1121   } else {
1122     set sql {
1123       SELECT name FROM sqlite_master WHERE type = 'table' UNION
1124       SELECT 'sqlite_master' ORDER BY 1
1125     }
1126   }
1127   set tbllist [$db eval $sql]
1128   set txt {}
1129   foreach tbl $tbllist {
1130     append txt [$db eval "SELECT * FROM $tbl"]
1131   }
1132   foreach prag {default_cache_size} {
1133     append txt $prag-[$db eval "PRAGMA $prag"]\n
1134   }
1135   # puts txt=$txt
1136   return [md5 $txt]
1137 }
1138
1139 # Generate a checksum based on the contents of a single database with
1140 # a database connection.  The name of the database is $dbname.
1141 # Examples of $dbname are "temp" or "main".
1142 #
1143 proc dbcksum {db dbname} {
1144   if {$dbname=="temp"} {
1145     set master sqlite_temp_master
1146   } else {
1147     set master $dbname.sqlite_master
1148   }
1149   set alltab [$db eval "SELECT name FROM $master WHERE type='table'"]
1150   set txt [$db eval "SELECT * FROM $master"]\n
1151   foreach tab $alltab {
1152     append txt [$db eval "SELECT * FROM $dbname.$tab"]\n
1153   }
1154   return [md5 $txt]
1155 }
1156
1157 proc memdebug_log_sql {{filename mallocs.sql}} {
1158
1159   set data [sqlite3_memdebug_log dump]
1160   set nFrame [expr [llength [lindex $data 0]]-2]
1161   if {$nFrame < 0} { return "" }
1162
1163   set database temp
1164
1165   set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);"
1166
1167   set sql ""
1168   foreach e $data {
1169     set nCall [lindex $e 0]
1170     set nByte [lindex $e 1]
1171     set lStack [lrange $e 2 end]
1172     append sql "INSERT INTO ${database}.malloc VALUES"
1173     append sql "('test', $nCall, $nByte, '$lStack');\n"
1174     foreach f $lStack {
1175       set frames($f) 1
1176     }
1177   }
1178
1179   set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
1180   set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
1181
1182   foreach f [array names frames] {
1183     set addr [format %x $f]
1184     set cmd "addr2line -e [info nameofexec] $addr"
1185     set line [eval exec $cmd]
1186     append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
1187
1188     set file [lindex [split $line :] 0]
1189     set files($file) 1
1190   }
1191
1192   foreach f [array names files] {
1193     set contents ""
1194     catch {
1195       set fd [open $f]
1196       set contents [read $fd]
1197       close $fd
1198     }
1199     set contents [string map {' ''} $contents]
1200     append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
1201   }
1202
1203   set fd [open $filename w]
1204   puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
1205   close $fd
1206 }
1207
1208 # Copy file $from into $to. This is used because some versions of
1209 # TCL for windows (notably the 8.4.1 binary package shipped with the
1210 # current mingw release) have a broken "file copy" command.
1211 #
1212 proc copy_file {from to} {
1213   if {$::tcl_platform(platform)=="unix"} {
1214     file copy -force $from $to
1215   } else {
1216     set f [open $from]
1217     fconfigure $f -translation binary
1218     set t [open $to w]
1219     fconfigure $t -translation binary
1220     puts -nonewline $t [read $f [file size $from]]
1221     close $t
1222     close $f
1223   }
1224 }
1225
1226 # Drop all tables in database [db]
1227 proc drop_all_tables {{db db}} {
1228   ifcapable trigger&&foreignkey {
1229     set pk [$db one "PRAGMA foreign_keys"]
1230     $db eval "PRAGMA foreign_keys = OFF"
1231   }
1232   foreach {idx name file} [db eval {PRAGMA database_list}] {
1233     if {$idx==1} {
1234       set master sqlite_temp_master
1235     } else {
1236       set master $name.sqlite_master
1237     }
1238     foreach {t type} [$db eval "
1239       SELECT name, type FROM $master
1240       WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
1241     "] {
1242       $db eval "DROP $type \"$t\""
1243     }
1244   }
1245   ifcapable trigger&&foreignkey {
1246     $db eval "PRAGMA foreign_keys = $pk"
1247   }
1248 }
1249
1250 #-------------------------------------------------------------------------
1251 # If a test script is executed with global variable $::G(perm:name) set to
1252 # "wal", then the tests are run in WAL mode. Otherwise, they should be run
1253 # in rollback mode. The following Tcl procs are used to make this less
1254 # intrusive:
1255 #
1256 #   wal_set_journal_mode ?DB?
1257 #
1258 #     If running a WAL test, execute "PRAGMA journal_mode = wal" using
1259 #     connection handle DB. Otherwise, this command is a no-op.
1260 #
1261 #   wal_check_journal_mode TESTNAME ?DB?
1262 #
1263 #     If running a WAL test, execute a tests case that fails if the main
1264 #     database for connection handle DB is not currently a WAL database.
1265 #     Otherwise (if not running a WAL permutation) this is a no-op.
1266 #
1267 #   wal_is_wal_mode
1268 #
1269 #     Returns true if this test should be run in WAL mode. False otherwise.
1270 #
1271 proc wal_is_wal_mode {} {
1272   expr {[permutation] eq "wal"}
1273 }
1274 proc wal_set_journal_mode {{db db}} {
1275   if { [wal_is_wal_mode] } {
1276     $db eval "PRAGMA journal_mode = WAL"
1277   }
1278 }
1279 proc wal_check_journal_mode {testname {db db}} {
1280   if { [wal_is_wal_mode] } {
1281     $db eval { SELECT * FROM sqlite_master }
1282     do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal}
1283   }
1284 }
1285
1286 proc permutation {} {
1287   set perm ""
1288   catch {set perm $::G(perm:name)}
1289   set perm
1290 }
1291 proc presql {} {
1292   set presql ""
1293   catch {set presql $::G(perm:presql)}
1294   set presql
1295 }
1296
1297 #-------------------------------------------------------------------------
1298 #
1299 proc slave_test_script {script} {
1300
1301   # Create the interpreter used to run the test script.
1302   interp create tinterp
1303
1304   # Populate some global variables that tester.tcl expects to see.
1305   foreach {var value} [list              \
1306     ::argv0 $::argv0                     \
1307     ::argv  {}                           \
1308     ::SLAVE 1                            \
1309   ] {
1310     interp eval tinterp [list set $var $value]
1311   }
1312
1313   # The alias used to access the global test counters.
1314   tinterp alias set_test_counter set_test_counter
1315
1316   # Set up the ::cmdlinearg array in the slave.
1317   interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]]
1318
1319   # Set up the ::G array in the slave.
1320   interp eval tinterp [list array set ::G [array get ::G]]
1321
1322   # Load the various test interfaces implemented in C.
1323   load_testfixture_extensions tinterp
1324
1325   # Run the test script.
1326   interp eval tinterp $script
1327
1328   # Check if the interpreter call [run_thread_tests]
1329   if { [interp eval tinterp {info exists ::run_thread_tests_called}] } {
1330     set ::run_thread_tests_called 1
1331   }
1332
1333   # Delete the interpreter used to run the test script.
1334   interp delete tinterp
1335 }
1336
1337 proc slave_test_file {zFile} {
1338   set tail [file tail $zFile]
1339
1340   if {[info exists ::G(start:permutation)]} {
1341     if {[permutation] != $::G(start:permutation)} return
1342     unset ::G(start:permutation)
1343   }
1344   if {[info exists ::G(start:file)]} {
1345     if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return
1346     unset ::G(start:file)
1347   }
1348
1349   # Remember the value of the shared-cache setting. So that it is possible
1350   # to check afterwards that it was not modified by the test script.
1351   #
1352   ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] }
1353
1354   # Run the test script in a slave interpreter.
1355   #
1356   unset -nocomplain ::run_thread_tests_called
1357   reset_prng_state
1358   set ::sqlite_open_file_count 0
1359   set time [time { slave_test_script [list source $zFile] }]
1360   set ms [expr [lindex $time 0] / 1000]
1361
1362   # Test that all files opened by the test script were closed. Omit this
1363   # if the test script has "thread" in its name. The open file counter
1364   # is not thread-safe.
1365   #
1366   if {[info exists ::run_thread_tests_called]==0} {
1367     do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0}
1368   }
1369   set ::sqlite_open_file_count 0
1370
1371   # Test that the global "shared-cache" setting was not altered by
1372   # the test script.
1373   #
1374   ifcapable shared_cache {
1375     set res [expr {[sqlite3_enable_shared_cache] == $scs}]
1376     do_test ${tail}-sharedcachesetting [list set {} $res] 1
1377   }
1378
1379   # Add some info to the output.
1380   #
1381   puts "Time: $tail $ms ms"
1382   show_memstats
1383 }
1384
1385 # Open a new connection on database test.db and execute the SQL script
1386 # supplied as an argument. Before returning, close the new conection and
1387 # restore the 4 byte fields starting at header offsets 28, 92 and 96
1388 # to the values they held before the SQL was executed. This simulates
1389 # a write by a pre-3.7.0 client.
1390 #
1391 proc sql36231 {sql} {
1392   set B [hexio_read test.db 92 8]
1393   set A [hexio_read test.db 28 4]
1394   sqlite3 db36231 test.db
1395   catch { db36231 func a_string a_string }
1396   execsql $sql db36231
1397   db36231 close
1398   hexio_write test.db 28 $A
1399   hexio_write test.db 92 $B
1400   return ""
1401 }
1402
1403 proc db_save {} {
1404   foreach f [glob -nocomplain sv_test.db*] { forcedelete $f }
1405   foreach f [glob -nocomplain test.db*] {
1406     set f2 "sv_$f"
1407     file copy -force $f $f2
1408   }
1409 }
1410 proc db_save_and_close {} {
1411   db_save
1412   catch { db close }
1413   return ""
1414 }
1415 proc db_restore {} {
1416   foreach f [glob -nocomplain test.db*] { forcedelete $f }
1417   foreach f2 [glob -nocomplain sv_test.db*] {
1418     set f [string range $f2 3 end]
1419     file copy -force $f2 $f
1420   }
1421 }
1422 proc db_restore_and_reopen {{dbfile test.db}} {
1423   catch { db close }
1424   db_restore
1425   sqlite3 db $dbfile
1426 }
1427 proc db_delete_and_reopen {{file test.db}} {
1428   catch { db close }
1429   foreach f [glob -nocomplain test.db*] { file delete -force $f }
1430   sqlite3 db $file
1431 }
1432
1433 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
1434 # to non-zero, then set the global variable $AUTOVACUUM to 1.
1435 set AUTOVACUUM $sqlite_options(default_autovacuum)
1436
1437 source $testdir/thread_common.tcl
1438 source $testdir/malloc_common.tcl