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