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 #      drop_all_indexes       ?DB?
  29 #      forcecopy              FROM TO
  30 #      forcedelete            FILENAME
  31 #
  32 # Test the capability of the SQLite version built into the interpreter to
  33 # determine if a specific test can be run:
  34 #
  35 #      capable                EXPR
  36 #      ifcapable              EXPR
  37 #
  38 # Calulate checksums based on database contents:
  39 #
  40 #      dbcksum                DB DBNAME
  41 #      allcksum               ?DB?
  42 #      cksum                  ?DB?
  43 #
  44 # Commands to execute/explain SQL statements:
  45 #
  46 #      memdbsql               SQL
  47 #      stepsql                DB SQL
  48 #      execsql2               SQL
  49 #      explain_no_trace       SQL
  50 #      explain                SQL ?DB?
  51 #      catchsql               SQL ?DB?
  52 #      execsql                SQL ?DB?
  53 #
  54 # Commands to run test cases:
  55 #
  56 #      do_ioerr_test          TESTNAME ARGS...
  57 #      crashsql               ARGS...
  58 #      integrity_check        TESTNAME ?DB?
  59 #      verify_ex_errcode      TESTNAME EXPECTED ?DB?
  60 #      do_test                TESTNAME SCRIPT EXPECTED
  61 #      do_execsql_test        TESTNAME SQL EXPECTED
  62 #      do_catchsql_test       TESTNAME SQL EXPECTED
  63 #      do_timed_execsql_test  TESTNAME SQL EXPECTED
  64 #
  65 # Commands providing a lower level interface to the global test counters:
  66 #
  67 #      set_test_counter       COUNTER ?VALUE?
  68 #      omit_test              TESTNAME REASON ?APPEND?
  69 #      fail_test              TESTNAME
  70 #      incr_ntest
  71 #
  72 # Command run at the end of each test file:
  73 #
  74 #      finish_test
  75 #
  76 # Commands to help create test files that run with the "WAL" and other
  77 # permutations (see file permutations.test):
  78 #
  79 #      wal_is_wal_mode
  80 #      wal_set_journal_mode   ?DB?
  81 #      wal_check_journal_mode TESTNAME?DB?
  82 #      permutation
  83 #      presql
  84 #
  85 # Command to test whether or not --verbose=1 was specified on the command
  86 # line (returns 0 for not-verbose, 1 for verbose and 2 for "verbose in the
  87 # output file only").
  88 #
  89 #      verbose
  90 #
  91
  92 # Set the precision of FP arithmatic used by the interpreter. And
  93 # configure SQLite to take database file locks on the page that begins
  94 # 64KB into the database file instead of the one 1GB in. This means
  95 # the code that handles that special case can be tested without creating
  96 # very large database files.
  97 #
  98 set tcl_precision 15
  99 sqlite3_test_control_pending_byte 0x0010000
 100
 101
 102 # If the pager codec is available, create a wrapper for the [sqlite3]
 103 # command that appends "-key {xyzzy}" to the command line. i.e. this:
 104 #
 105 #     sqlite3 db test.db
 106 #
 107 # becomes
 108 #
 109 #     sqlite3 db test.db -key {xyzzy}
 110 #
 111 if {[info command sqlite_orig]==""} {
 112   rename sqlite3 sqlite_orig
 113   proc sqlite3 {args} {
 114     if {[llength $args]>=2 && [string index [lindex $args 0] 0]!="-"} {
 115       # This command is opening a new database connection.
 116       #
 117       if {[info exists ::G(perm:sqlite3_args)]} {
 118         set args [concat $args $::G(perm:sqlite3_args)]
 119       }
 120       if {[sqlite_orig -has-codec] && ![info exists ::do_not_use_codec]} {
 121         lappend args -key {xyzzy}
 122       }
 123
 124       set res [uplevel 1 sqlite_orig $args]
 125       if {[info exists ::G(perm:presql)]} {
 126         [lindex $args 0] eval $::G(perm:presql)
 127       }
 128       if {[info exists ::G(perm:dbconfig)]} {
 129         set ::dbhandle [lindex $args 0]
 130         uplevel #0 $::G(perm:dbconfig)
 131       }
 132       [lindex $args 0] cache size 3
 133       set res
 134     } else {
 135       # This command is not opening a new database connection. Pass the
 136       # arguments through to the C implementation as the are.
 137       #
 138       uplevel 1 sqlite_orig $args
 139     }
 140   }
 141 }
 142
 143 proc getFileRetries {} {
 144   if {![info exists ::G(file-retries)]} {
 145     #
 146     # NOTE: Return the default number of retries for [file] operations.  A
 147     #       value of zero or less here means "disabled".
 148     #
 149     return [expr {$::tcl_platform(platform) eq "windows" ? 50 : 0}]
 150   }
 151   return $::G(file-retries)
 152 }
 153
 154 proc getFileRetryDelay {} {
 155   if {![info exists ::G(file-retry-delay)]} {
 156     #
 157     # NOTE: Return the default number of milliseconds to wait when retrying
 158     #       failed [file] operations.  A value of zero or less means "do not
 159     #       wait".
 160     #
 161     return 100; # TODO: Good default?
 162   }
 163   return $::G(file-retry-delay)
 164 }
 165
 166 # Return the string representing the name of the current directory.  On
 167 # Windows, the result is "normalized" to whatever our parent command shell
 168 # is using to prevent case-mismatch issues.
 169 #
 170 proc get_pwd {} {
 171   if {$::tcl_platform(platform) eq "windows"} {
 172     #
 173     # NOTE: Cannot use [file normalize] here because it would alter the
 174     #       case of the result to what Tcl considers canonical, which would
 175     #       defeat the purpose of this procedure.
 176     #
 177     if {[info exists ::env(ComSpec)]} {
 178       set comSpec $::env(ComSpec)
 179     } else {
 180       # NOTE: Hard-code the typical default value.
 181       set comSpec {C:\Windows\system32\cmd.exe}
 182     }
 183     return [string map [list \\ /] \
 184         [string trim [exec -- $comSpec /c echo %CD%]]]
 185   } else {
 186     return [pwd]
 187   }
 188 }
 189
 190 # Copy file $from into $to. This is used because some versions of
 191 # TCL for windows (notably the 8.4.1 binary package shipped with the
 192 # current mingw release) have a broken "file copy" command.
 193 #
 194 proc copy_file {from to} {
 195   do_copy_file false $from $to
 196 }
 197
 198 proc forcecopy {from to} {
 199   do_copy_file true $from $to
 200 }
 201
 202 proc do_copy_file {force from to} {
 203   set nRetry [getFileRetries]     ;# Maximum number of retries.
 204   set nDelay [getFileRetryDelay]  ;# Delay in ms before retrying.
 205
 206   # On windows, sometimes even a [file copy -force] can fail. The cause is
 207   # usually "tag-alongs" - programs like anti-virus software, automatic backup
 208   # tools and various explorer extensions that keep a file open a little longer
 209   # than we expect, causing the delete to fail.
 210   #
 211   # The solution is to wait a short amount of time before retrying the copy.
 212   #
 213   if {$nRetry > 0} {
 214     for {set i 0} {$i<$nRetry} {incr i} {
 215       set rc [catch {
 216         if {$force} {
 217           file copy -force $from $to
 218         } else {
 219           file copy $from $to
 220         }
 221       } msg]
 222       if {$rc==0} break
 223       if {$nDelay > 0} { after $nDelay }
 224     }
 225     if {$rc} { error $msg }
 226   } else {
 227     if {$force} {
 228       file copy -force $from $to
 229     } else {
 230       file copy $from $to
 231     }
 232   }
 233 }
 234
 235 # Check if a file name is relative
 236 #
 237 proc is_relative_file { file } {
 238   return [expr {[file pathtype $file] != "absolute"}]
 239 }
 240
 241 # If the VFS supports using the current directory, returns [pwd];
 242 # otherwise, it returns only the provided suffix string (which is
 243 # empty by default).
 244 #
 245 proc test_pwd { args } {
 246   if {[llength $args] > 0} {
 247     set suffix1 [lindex $args 0]
 248     if {[llength $args] > 1} {
 249       set suffix2 [lindex $args 1]
 250     } else {
 251       set suffix2 $suffix1
 252     }
 253   } else {
 254     set suffix1 ""; set suffix2 ""
 255   }
 256   ifcapable curdir {
 257     return "[get_pwd]$suffix1"
 258   } else {
 259     return $suffix2
 260   }
 261 }
 262
 263 # Delete a file or directory
 264 #
 265 proc delete_file {args} {
 266   do_delete_file false {*}$args
 267 }
 268
 269 proc forcedelete {args} {
 270   do_delete_file true {*}$args
 271 }
 272
 273 proc do_delete_file {force args} {
 274   set nRetry [getFileRetries]     ;# Maximum number of retries.
 275   set nDelay [getFileRetryDelay]  ;# Delay in ms before retrying.
 276
 277   foreach filename $args {
 278     # On windows, sometimes even a [file delete -force] can fail just after
 279     # a file is closed. The cause is usually "tag-alongs" - programs like
 280     # anti-virus software, automatic backup tools and various explorer
 281     # extensions that keep a file open a little longer than we expect, causing
 282     # the delete to fail.
 283     #
 284     # The solution is to wait a short amount of time before retrying the
 285     # delete.
 286     #
 287     if {$nRetry > 0} {
 288       for {set i 0} {$i<$nRetry} {incr i} {
 289         set rc [catch {
 290           if {$force} {
 291             file delete -force $filename
 292           } else {
 293             file delete $filename
 294           }
 295         } msg]
 296         if {$rc==0} break
 297         if {$nDelay > 0} { after $nDelay }
 298       }
 299       if {$rc} { error $msg }
 300     } else {
 301       if {$force} {
 302         file delete -force $filename
 303       } else {
 304         file delete $filename
 305       }
 306     }
 307   }
 308 }
 309
 310 if {$::tcl_platform(platform) eq "windows"} {
 311   proc do_remove_win32_dir {args} {
 312     set nRetry [getFileRetries]     ;# Maximum number of retries.
 313     set nDelay [getFileRetryDelay]  ;# Delay in ms before retrying.
 314
 315     foreach dirName $args {
 316       # On windows, sometimes even a [remove_win32_dir] can fail just after
 317       # a directory is emptied. The cause is usually "tag-alongs" - programs
 318       # like anti-virus software, automatic backup tools and various explorer
 319       # extensions that keep a file open a little longer than we expect,
 320       # causing the delete to fail.
 321       #
 322       # The solution is to wait a short amount of time before retrying the
 323       # removal.
 324       #
 325       if {$nRetry > 0} {
 326         for {set i 0} {$i < $nRetry} {incr i} {
 327           set rc [catch {
 328             remove_win32_dir $dirName
 329           } msg]
 330           if {$rc == 0} break
 331           if {$nDelay > 0} { after $nDelay }
 332         }
 333         if {$rc} { error $msg }
 334       } else {
 335         remove_win32_dir $dirName
 336       }
 337     }
 338   }
 339
 340   proc do_delete_win32_file {args} {
 341     set nRetry [getFileRetries]     ;# Maximum number of retries.
 342     set nDelay [getFileRetryDelay]  ;# Delay in ms before retrying.
 343
 344     foreach fileName $args {
 345       # On windows, sometimes even a [delete_win32_file] can fail just after
 346       # a file is closed. The cause is usually "tag-alongs" - programs like
 347       # anti-virus software, automatic backup tools and various explorer
 348       # extensions that keep a file open a little longer than we expect,
 349       # causing the delete to fail.
 350       #
 351       # The solution is to wait a short amount of time before retrying the
 352       # delete.
 353       #
 354       if {$nRetry > 0} {
 355         for {set i 0} {$i < $nRetry} {incr i} {
 356           set rc [catch {
 357             delete_win32_file $fileName
 358           } msg]
 359           if {$rc == 0} break
 360           if {$nDelay > 0} { after $nDelay }
 361         }
 362         if {$rc} { error $msg }
 363       } else {
 364         delete_win32_file $fileName
 365       }
 366     }
 367   }
 368 }
 369
 370 proc execpresql {handle args} {
 371   trace remove execution $handle enter [list execpresql $handle]
 372   if {[info exists ::G(perm:presql)]} {
 373     $handle eval $::G(perm:presql)
 374   }
 375 }
 376
 377 # This command should be called after loading tester.tcl from within
 378 # all test scripts that are incompatible with encryption codecs.
 379 #
 380 proc do_not_use_codec {} {
 381   set ::do_not_use_codec 1
 382   reset_db
 383 }
 384 unset -nocomplain do_not_use_codec
 385
 386 # Return true if the "reserved_bytes" integer on database files is non-zero.
 387 #
 388 proc nonzero_reserved_bytes {} {
 389   return [sqlite3 -has-codec]
 390 }
 391
 392 # Print a HELP message and exit
 393 #
 394 proc print_help_and_quit {} {
 395   puts {Options:
 396   --pause                  Wait for user input before continuing
 397   --soft-heap-limit=N      Set the soft-heap-limit to N
 398   --hard-heap-limit=N      Set the hard-heap-limit to N
 399   --maxerror=N             Quit after N errors
 400   --verbose=(0|1)          Control the amount of output.  Default '1'
 401   --output=FILE            set --verbose=2 and output to FILE.  Implies -q
 402   -q                       Shorthand for --verbose=0
 403   --help                   This message
 404 }
 405   exit 1
 406 }
 407
 408 # The following block only runs the first time this file is sourced. It
 409 # does not run in slave interpreters (since the ::cmdlinearg array is
 410 # populated before the test script is run in slave interpreters).
 411 #
 412 if {[info exists cmdlinearg]==0} {
 413
 414   # Parse any options specified in the $argv array. This script accepts the
 415   # following options:
 416   #
 417   #   --pause
 418   #   --soft-heap-limit=NN
 419   #   --hard-heap-limit=NN
 420   #   --maxerror=NN
 421   #   --malloctrace=N
 422   #   --backtrace=N
 423   #   --binarylog=N
 424   #   --soak=N
 425   #   --file-retries=N
 426   #   --file-retry-delay=N
 427   #   --start=[$permutation:]$testfile
 428   #   --match=$pattern
 429   #   --verbose=$val
 430   #   --output=$filename
 431   #   -q                                      Reduce output
 432   #   --testdir=$dir                          Run tests in subdirectory $dir
 433   #   --help
 434   #
 435   set cmdlinearg(soft-heap-limit)    0
 436   set cmdlinearg(hard-heap-limit)    0
 437   set cmdlinearg(maxerror)        1000
 438   set cmdlinearg(malloctrace)        0
 439   set cmdlinearg(backtrace)         10
 440   set cmdlinearg(binarylog)          0
 441   set cmdlinearg(soak)               0
 442   set cmdlinearg(file-retries)       0
 443   set cmdlinearg(file-retry-delay)   0
 444   set cmdlinearg(start)             ""
 445   set cmdlinearg(match)             ""
 446   set cmdlinearg(verbose)           ""
 447   set cmdlinearg(output)            ""
 448   set cmdlinearg(testdir)           "testdir"
 449
 450   set leftover [list]
 451   foreach a $argv {
 452     switch -regexp -- $a {
 453       {^-+pause$} {
 454         # Wait for user input before continuing. This is to give the user an
 455         # opportunity to connect profiling tools to the process.
 456         puts -nonewline "Press RETURN to begin..."
 457         flush stdout
 458         gets stdin
 459       }
 460       {^-+soft-heap-limit=.+$} {
 461         foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break
 462       }
 463       {^-+hard-heap-limit=.+$} {
 464         foreach {dummy cmdlinearg(hard-heap-limit)} [split $a =] break
 465       }
 466       {^-+maxerror=.+$} {
 467         foreach {dummy cmdlinearg(maxerror)} [split $a =] break
 468       }
 469       {^-+malloctrace=.+$} {
 470         foreach {dummy cmdlinearg(malloctrace)} [split $a =] break
 471         if {$cmdlinearg(malloctrace)} {
 472           if {0==$::sqlite_options(memdebug)} {
 473             set err "Error: --malloctrace=1 requires an SQLITE_MEMDEBUG build"
 474             puts stderr $err
 475             exit 1
 476           }
 477           sqlite3_memdebug_log start
 478         }
 479       }
 480       {^-+backtrace=.+$} {
 481         foreach {dummy cmdlinearg(backtrace)} [split $a =] break
 482         sqlite3_memdebug_backtrace $cmdlinearg(backtrace)
 483       }
 484       {^-+binarylog=.+$} {
 485         foreach {dummy cmdlinearg(binarylog)} [split $a =] break
 486         set cmdlinearg(binarylog) [file normalize $cmdlinearg(binarylog)]
 487       }
 488       {^-+soak=.+$} {
 489         foreach {dummy cmdlinearg(soak)} [split $a =] break
 490         set ::G(issoak) $cmdlinearg(soak)
 491       }
 492       {^-+file-retries=.+$} {
 493         foreach {dummy cmdlinearg(file-retries)} [split $a =] break
 494         set ::G(file-retries) $cmdlinearg(file-retries)
 495       }
 496       {^-+file-retry-delay=.+$} {
 497         foreach {dummy cmdlinearg(file-retry-delay)} [split $a =] break
 498         set ::G(file-retry-delay) $cmdlinearg(file-retry-delay)
 499       }
 500       {^-+start=.+$} {
 501         foreach {dummy cmdlinearg(start)} [split $a =] break
 502
 503         set ::G(start:file) $cmdlinearg(start)
 504         if {[regexp {(.*):(.*)} $cmdlinearg(start) -> s.perm s.file]} {
 505           set ::G(start:permutation) ${s.perm}
 506           set ::G(start:file)        ${s.file}
 507         }
 508         if {$::G(start:file) == ""} {unset ::G(start:file)}
 509       }
 510       {^-+match=.+$} {
 511         foreach {dummy cmdlinearg(match)} [split $a =] break
 512
 513         set ::G(match) $cmdlinearg(match)
 514         if {$::G(match) == ""} {unset ::G(match)}
 515       }
 516
 517       {^-+output=.+$} {
 518         foreach {dummy cmdlinearg(output)} [split $a =] break
 519         set cmdlinearg(output) [file normalize $cmdlinearg(output)]
 520         if {$cmdlinearg(verbose)==""} {
 521           set cmdlinearg(verbose) 2
 522         }
 523       }
 524       {^-+verbose=.+$} {
 525         foreach {dummy cmdlinearg(verbose)} [split $a =] break
 526         if {$cmdlinearg(verbose)=="file"} {
 527           set cmdlinearg(verbose) 2
 528         } elseif {[string is boolean -strict $cmdlinearg(verbose)]==0} {
 529           error "option --verbose= must be set to a boolean or to \"file\""
 530         }
 531       }
 532       {^-+testdir=.*$} {
 533         foreach {dummy cmdlinearg(testdir)} [split $a =] break
 534       }
 535       {.*help.*} {
 536          print_help_and_quit
 537       }
 538       {^-q$} {
 539         set cmdlinearg(output) test-out.txt
 540         set cmdlinearg(verbose) 2
 541       }
 542
 543       default {
 544         if {[file tail $a]==$a} {
 545           lappend leftover $a
 546         } else {
 547           lappend leftover [file normalize $a]
 548         }
 549       }
 550     }
 551   }
 552   set testdir [file normalize $testdir]
 553   set cmdlinearg(TESTFIXTURE_HOME) [pwd]
 554   set cmdlinearg(INFO_SCRIPT) [file normalize [info script]]
 555   set argv0 [file normalize $argv0]
 556   if {$cmdlinearg(testdir)!=""} {
 557     file mkdir $cmdlinearg(testdir)
 558     cd $cmdlinearg(testdir)
 559   }
 560   set argv $leftover
 561
 562   # Install the malloc layer used to inject OOM errors. And the 'automatic'
 563   # extensions. This only needs to be done once for the process.
 564   #
 565   sqlite3_shutdown
 566   install_malloc_faultsim 1
 567   sqlite3_initialize
 568   autoinstall_test_functions
 569
 570   # If the --binarylog option was specified, create the logging VFS. This
 571   # call installs the new VFS as the default for all SQLite connections.
 572   #
 573   if {$cmdlinearg(binarylog)} {
 574     vfslog new binarylog {} vfslog.bin
 575   }
 576
 577   # Set the backtrace depth, if malloc tracing is enabled.
 578   #
 579   if {$cmdlinearg(malloctrace)} {
 580     sqlite3_memdebug_backtrace $cmdlinearg(backtrace)
 581   }
 582
 583   if {$cmdlinearg(output)!=""} {
 584     puts "Copying output to file $cmdlinearg(output)"
 585     set ::G(output_fd) [open $cmdlinearg(output) w]
 586     fconfigure $::G(output_fd) -buffering line
 587   }
 588
 589   if {$cmdlinearg(verbose)==""} {
 590     set cmdlinearg(verbose) 1
 591   }
 592
 593   if {[info commands vdbe_coverage]!=""} {
 594     vdbe_coverage start
 595   }
 596 }
 597
 598 # Update the soft-heap-limit each time this script is run. In that
 599 # way if an individual test file changes the soft-heap-limit, it
 600 # will be reset at the start of the next test file.
 601 #
 602 sqlite3_soft_heap_limit64 $cmdlinearg(soft-heap-limit)
 603 sqlite3_hard_heap_limit64 $cmdlinearg(hard-heap-limit)
 604
 605 # Create a test database
 606 #
 607 proc reset_db {} {
 608   catch {db close}
 609   forcedelete test.db
 610   forcedelete test.db-journal
 611   forcedelete test.db-wal
 612   sqlite3 db ./test.db
 613   set ::DB [sqlite3_connection_pointer db]
 614   if {[info exists ::SETUP_SQL]} {
 615     db eval $::SETUP_SQL
 616   }
 617 }
 618 reset_db
 619
 620 # Abort early if this script has been run before.
 621 #
 622 if {[info exists TC(count)]} return
 623
 624 # Make sure memory statistics are enabled.
 625 #
 626 sqlite3_config_memstatus 1
 627
 628 # Initialize the test counters and set up commands to access them.
 629 # Or, if this is a slave interpreter, set up aliases to write the
 630 # counters in the parent interpreter.
 631 #
 632 if {0==[info exists ::SLAVE]} {
 633   set TC(errors)    0
 634   set TC(count)     0
 635   set TC(fail_list) [list]
 636   set TC(omit_list) [list]
 637   set TC(warn_list) [list]
 638
 639   proc set_test_counter {counter args} {
 640     if {[llength $args]} {
 641       set ::TC($counter) [lindex $args 0]
 642     }
 643     set ::TC($counter)
 644   }
 645 }
 646
 647 # Record the fact that a sequence of tests were omitted.
 648 #
 649 proc omit_test {name reason {append 1}} {
 650   set omitList [set_test_counter omit_list]
 651   if {$append} {
 652     lappend omitList [list $name $reason]
 653   }
 654   set_test_counter omit_list $omitList
 655 }
 656
 657 # Record the fact that a test failed.
 658 #
 659 proc fail_test {name} {
 660   set f [set_test_counter fail_list]
 661   lappend f $name
 662   set_test_counter fail_list $f
 663   set_test_counter errors [expr [set_test_counter errors] + 1]
 664
 665   set nFail [set_test_counter errors]
 666   if {$nFail>=$::cmdlinearg(maxerror)} {
 667     output2 "*** Giving up..."
 668     finalize_testing
 669   }
 670 }
 671
 672 # Remember a warning message to be displayed at the conclusion of all testing
 673 #
 674 proc warning {msg {append 1}} {
 675   output2 "Warning: $msg"
 676   set warnList [set_test_counter warn_list]
 677   if {$append} {
 678     lappend warnList $msg
 679   }
 680   set_test_counter warn_list $warnList
 681 }
 682
 683
 684 # Increment the number of tests run
 685 #
 686 proc incr_ntest {} {
 687   set_test_counter count [expr [set_test_counter count] + 1]
 688 }
 689
 690 # Return true if --verbose=1 was specified on the command line. Otherwise,
 691 # return false.
 692 #
 693 proc verbose {} {
 694   return $::cmdlinearg(verbose)
 695 }
 696
 697 # Use the following commands instead of [puts] for test output within
 698 # this file. Test scripts can still use regular [puts], which is directed
 699 # to stdout and, if one is open, the --output file.
 700 #
 701 # output1: output that should be printed if --verbose=1 was specified.
 702 # output2: output that should be printed unconditionally.
 703 # output2_if_no_verbose: output that should be printed only if --verbose=0.
 704 #
 705 proc output1 {args} {
 706   set v [verbose]
 707   if {$v==1} {
 708     uplevel output2 $args
 709   } elseif {$v==2} {
 710     uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end]
 711   }
 712 }
 713 proc output2 {args} {
 714   set nArg [llength $args]
 715   uplevel puts $args
 716 }
 717 proc output2_if_no_verbose {args} {
 718   set v [verbose]
 719   if {$v==0} {
 720     uplevel output2 $args
 721   } elseif {$v==2} {
 722     uplevel puts [lrange $args 0 end-1] stdout [lrange $args end end]
 723   }
 724 }
 725
 726 # Override the [puts] command so that if no channel is explicitly
 727 # specified the string is written to both stdout and to the file
 728 # specified by "--output=", if any.
 729 #
 730 proc puts_override {args} {
 731   set nArg [llength $args]
 732   if {$nArg==1 || ($nArg==2 && [string first [lindex $args 0] -nonewline]==0)} {
 733     uplevel puts_original $args
 734     if {[info exists ::G(output_fd)]} {
 735       uplevel puts [lrange $args 0 end-1] $::G(output_fd) [lrange $args end end]
 736     }
 737   } else {
 738     # A channel was explicitly specified.
 739     uplevel puts_original $args
 740   }
 741 }
 742 rename puts puts_original
 743 proc puts {args} { uplevel puts_override $args }
 744
 745
 746 # Invoke the do_test procedure to run a single test
 747 #
 748 # The $expected parameter is the expected result.  The result is the return
 749 # value from the last TCL command in $cmd.
 750 #
 751 # Normally, $expected must match exactly.  But if $expected is of the form
 752 # "/regexp/" then regular expression matching is used.  If $expected is
 753 # "~/regexp/" then the regular expression must NOT match.  If $expected is
 754 # of the form "#/value-list/" then each term in value-list must be numeric
 755 # and must approximately match the corresponding numeric term in $result.
 756 # Values must match within 10%.  Or if the $expected term is A..B then the
 757 # $result term must be in between A and B.
 758 #
 759 proc do_test {name cmd expected} {
 760   global argv cmdlinearg
 761
 762   fix_testname name
 763
 764   sqlite3_memdebug_settitle $name
 765
 766 #  if {[llength $argv]==0} {
 767 #    set go 1
 768 #  } else {
 769 #    set go 0
 770 #    foreach pattern $argv {
 771 #      if {[string match $pattern $name]} {
 772 #        set go 1
 773 #        break
 774 #      }
 775 #    }
 776 #  }
 777
 778   if {[info exists ::G(perm:prefix)]} {
 779     set name "$::G(perm:prefix)$name"
 780   }
 781
 782   incr_ntest
 783   output1 -nonewline $name...
 784   flush stdout
 785
 786   if {![info exists ::G(match)] || [string match $::G(match) $name]} {
 787     if {[catch {uplevel #0 "$cmd;\n"} result]} {
 788       output2_if_no_verbose -nonewline $name...
 789       output2 "\nError: $result"
 790       fail_test $name
 791     } else {
 792       if {[permutation]=="maindbname"} {
 793         set result [string map [list [string tolower ICECUBE] main] $result]
 794       }
 795       if {[regexp {^[~#]?/.*/$} $expected]} {
 796         # "expected" is of the form "/PATTERN/" then the result if correct if
 797         # regular expression PATTERN matches the result.  "~/PATTERN/" means
 798         # the regular expression must not match.
 799         if {[string index $expected 0]=="~"} {
 800           set re [string range $expected 2 end-1]
 801           if {[string index $re 0]=="*"} {
 802             # If the regular expression begins with * then treat it as a glob instead
 803             set ok [string match $re $result]
 804           } else {
 805             set re [string map {# {[-0-9.]+}} $re]
 806             set ok [regexp $re $result]
 807           }
 808           set ok [expr {!$ok}]
 809         } elseif {[string index $expected 0]=="#"} {
 810           # Numeric range value comparison.  Each term of the $result is matched
 811           # against one term of $expect.  Both $result and $expected terms must be
 812           # numeric.  The values must match within 10%.  Or if $expected is of the
 813           # form A..B then the $result term must be between A and B.
 814           set e2 [string range $expected 2 end-1]
 815           foreach i $result j $e2 {
 816             if {[regexp {^(-?\d+)\.\.(-?\d)$} $j all A B]} {
 817               set ok [expr {$i+0>=$A && $i+0<=$B}]
 818             } else {
 819               set ok [expr {$i+0>=0.9*$j && $i+0<=1.1*$j}]
 820             }
 821             if {!$ok} break
 822           }
 823           if {$ok && [llength $result]!=[llength $e2]} {set ok 0}
 824         } else {
 825           set re [string range $expected 1 end-1]
 826           if {[string index $re 0]=="*"} {
 827             # If the regular expression begins with * then treat it as a glob instead
 828             set ok [string match $re $result]
 829           } else {
 830             set re [string map {# {[-0-9.]+}} $re]
 831             set ok [regexp $re $result]
 832           }
 833         }
 834       } elseif {[regexp {^~?\*.*\*$} $expected]} {
 835         # "expected" is of the form "*GLOB*" then the result if correct if
 836         # glob pattern GLOB matches the result.  "~/GLOB/" means
 837         # the glob must not match.
 838         if {[string index $expected 0]=="~"} {
 839           set e [string range $expected 1 end]
 840           set ok [expr {![string match $e $result]}]
 841         } else {
 842           set ok [string match $expected $result]
 843         }
 844       } else {
 845         set ok [expr {[string compare $result $expected]==0}]
 846       }
 847       if {!$ok} {
 848         # if {![info exists ::testprefix] || $::testprefix eq ""} {
 849         #   error "no test prefix"
 850         # }
 851         output1 ""
 852         output2 "! $name expected: \[$expected\]\n! $name got:      \[$result\]"
 853         fail_test $name
 854       } else {
 855         output1 " Ok"
 856       }
 857     }
 858   } else {
 859     output1 " Omitted"
 860     omit_test $name "pattern mismatch" 0
 861   }
 862   flush stdout
 863 }
 864
 865 proc dumpbytes {s} {
 866   set r ""
 867   for {set i 0} {$i < [string length $s]} {incr i} {
 868     if {$i > 0} {append r " "}
 869     append r [format %02X [scan [string index $s $i] %c]]
 870   }
 871   return $r
 872 }
 873
 874 proc catchcmd {db {cmd ""}} {
 875   global CLI
 876   set out [open cmds.txt w]
 877   puts $out $cmd
 878   close $out
 879   set line "exec $CLI $db < cmds.txt"
 880   set rc [catch { eval $line } msg]
 881   list $rc $msg
 882 }
 883
 884 proc catchcmdex {db {cmd ""}} {
 885   global CLI
 886   set out [open cmds.txt w]
 887   fconfigure $out -encoding binary -translation binary
 888   puts -nonewline $out $cmd
 889   close $out
 890   set line "exec -keepnewline -- $CLI $db < cmds.txt"
 891   set chans [list stdin stdout stderr]
 892   foreach chan $chans {
 893     catch {
 894       set modes($chan) [fconfigure $chan]
 895       fconfigure $chan -encoding binary -translation binary -buffering none
 896     }
 897   }
 898   set rc [catch { eval $line } msg]
 899   foreach chan $chans {
 900     catch {
 901       eval fconfigure [list $chan] $modes($chan)
 902     }
 903   }
 904   # puts [dumpbytes $msg]
 905   list $rc $msg
 906 }
 907
 908 proc filepath_normalize {p} {
 909   # test cases should be written to assume "unix"-like file paths
 910   if {$::tcl_platform(platform)!="unix"} {
 911     string map [list \\ / \{/ / .db\} .db] \
 912         [regsub -nocase -all {[a-z]:[/\\]+} $p {/}]
 913   } {
 914     set p
 915   }
 916 }
 917 proc do_filepath_test {name cmd expected} {
 918   uplevel [list do_test $name [
 919     subst -nocommands { filepath_normalize [ $cmd ] }
 920   ] [filepath_normalize $expected]]
 921 }
 922
 923 proc realnum_normalize {r} {
 924   # different TCL versions display floating point values differently.
 925   string map {1.#INF inf Inf inf .0e e} [regsub -all {(e[+-])0+} $r {\1}]
 926 }
 927 proc do_realnum_test {name cmd expected} {
 928   uplevel [list do_test $name [
 929     subst -nocommands { realnum_normalize [ $cmd ] }
 930   ] [realnum_normalize $expected]]
 931 }
 932
 933 proc fix_testname {varname} {
 934   upvar $varname testname
 935   if {[info exists ::testprefix]
 936    && [string is digit [string range $testname 0 0]]
 937   } {
 938     set testname "${::testprefix}-$testname"
 939   }
 940 }
 941
 942 proc normalize_list {L} {
 943   set L2 [list]
 944   foreach l $L {lappend L2 $l}
 945   set L2
 946 }
 947
 948 # Either:
 949 #
 950 #   do_execsql_test TESTNAME SQL ?RES?
 951 #   do_execsql_test -db DB TESTNAME SQL ?RES?
 952 #
 953 proc do_execsql_test {args} {
 954   set db db
 955   if {[lindex $args 0]=="-db"} {
 956     set db [lindex $args 1]
 957     set args [lrange $args 2 end]
 958   }
 959
 960   if {[llength $args]==2} {
 961     foreach {testname sql} $args {}
 962     set result ""
 963   } elseif {[llength $args]==3} {
 964     foreach {testname sql result} $args {}
 965
 966     # With some versions of Tcl on windows, if $result is all whitespace but
 967     # contains some CR/LF characters, the [list {*}$result] below returns a
 968     # copy of $result instead of a zero length string. Not clear exactly why
 969     # this is. The following is a workaround.
 970     if {[llength $result]==0} { set result "" }
 971   } else {
 972     error [string trim {
 973       wrong # args: should be "do_execsql_test ?-db DB? testname sql ?result?"
 974     }]
 975   }
 976
 977   fix_testname testname
 978
 979   uplevel do_test                 \
 980       [list $testname]            \
 981       [list "execsql {$sql} $db"] \
 982       [list [list {*}$result]]
 983 }
 984
 985 proc do_catchsql_test {testname sql result} {
 986   fix_testname testname
 987   uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result]
 988 }
 989 proc do_timed_execsql_test {testname sql {result {}}} {
 990   fix_testname testname
 991   uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\
 992                                    [list [list {*}$result]]
 993 }
 994
 995 # Run an EXPLAIN QUERY PLAN $sql in database "db".  Then rewrite the output
 996 # as an ASCII-art graph and return a string that is that graph.
 997 #
 998 # Hexadecimal literals in the output text are converted into "xxxxxx" since those
 999 # literals are pointer values that might very from one run of the test to the
1000 # next, yet we want the output to be consistent.
1001 #
1002 proc query_plan_graph {sql} {
1003   db eval "EXPLAIN QUERY PLAN $sql" {
1004     set dx($id) $detail
1005     lappend cx($parent) $id
1006   }
1007   set a "\n  QUERY PLAN\n"
1008   append a [append_graph "  " dx cx 0]
1009   regsub -all { 0x[A-F0-9]+\y} $a { xxxxxx} a
1010   regsub -all {(MATERIALIZE|CO-ROUTINE|SUBQUERY) \d+\y} $a {\1 xxxxxx} a
1011   return $a
1012 }
1013
1014 # Helper routine for [query_plan_graph SQL]:
1015 #
1016 # Output rows of the graph that are children of $level.
1017 #
1018 #   prefix:  Prepend to every output line
1019 #
1020 #   dxname:  Name of an array variable that stores text describe
1021 #            The description for $id is $dx($id)
1022 #
1023 #   cxname:  Name of an array variable holding children of item.
1024 #            Children of $id are $cx($id)
1025 #
1026 #   level:   Render all lines that are children of $level
1027 #
1028 proc append_graph {prefix dxname cxname level} {
1029   upvar $dxname dx $cxname cx
1030   set a ""
1031   set x $cx($level)
1032   set n [llength $x]
1033   for {set i 0} {$i<$n} {incr i} {
1034     set id [lindex $x $i]
1035     if {$i==$n-1} {
1036       set p1 "`--"
1037       set p2 "   "
1038     } else {
1039       set p1 "|--"
1040       set p2 "|  "
1041     }
1042     append a $prefix$p1$dx($id)\n
1043     if {[info exists cx($id)]} {
1044       append a [append_graph "$prefix$p2" dx cx $id]
1045     }
1046   }
1047   return $a
1048 }
1049
1050 # Do an EXPLAIN QUERY PLAN test on input $sql with expected results $res
1051 #
1052 # If $res begins with a "\s+QUERY PLAN\n" then it is assumed to be the
1053 # complete graph which must match the output of [query_plan_graph $sql]
1054 # exactly.
1055 #
1056 # If $res does not begin with "\s+QUERY PLAN\n" then take it is a string
1057 # that must be found somewhere in the query plan output.
1058 #
1059 proc do_eqp_test {name sql res} {
1060   if {[regexp {^\s+QUERY PLAN\n} $res]} {
1061     uplevel do_test $name [list [list query_plan_graph $sql]] [list $res]
1062   } else {
1063     if {[string index $res 0]!="/"} {
1064       set res "/*$res*/"
1065     }
1066     uplevel do_execsql_test $name [list "EXPLAIN QUERY PLAN $sql"] [list $res]
1067   }
1068 }
1069
1070
1071 #-------------------------------------------------------------------------
1072 #   Usage: do_select_tests PREFIX ?SWITCHES? TESTLIST
1073 #
1074 # Where switches are:
1075 #
1076 #   -errorformat FMTSTRING
1077 #   -count
1078 #   -query SQL
1079 #   -tclquery TCL
1080 #   -repair TCL
1081 #
1082 proc do_select_tests {prefix args} {
1083
1084   set testlist [lindex $args end]
1085   set switches [lrange $args 0 end-1]
1086
1087   set errfmt ""
1088   set countonly 0
1089   set tclquery ""
1090   set repair ""
1091
1092   for {set i 0} {$i < [llength $switches]} {incr i} {
1093     set s [lindex $switches $i]
1094     set n [string length $s]
1095     if {$n>=2 && [string equal -length $n $s "-query"]} {
1096       set tclquery [list execsql [lindex $switches [incr i]]]
1097     } elseif {$n>=2 && [string equal -length $n $s "-tclquery"]} {
1098       set tclquery [lindex $switches [incr i]]
1099     } elseif {$n>=2 && [string equal -length $n $s "-errorformat"]} {
1100       set errfmt [lindex $switches [incr i]]
1101     } elseif {$n>=2 && [string equal -length $n $s "-repair"]} {
1102       set repair [lindex $switches [incr i]]
1103     } elseif {$n>=2 && [string equal -length $n $s "-count"]} {
1104       set countonly 1
1105     } else {
1106       error "unknown switch: $s"
1107     }
1108   }
1109
1110   if {$countonly && $errfmt!=""} {
1111     error "Cannot use -count and -errorformat together"
1112   }
1113   set nTestlist [llength $testlist]
1114   if {$nTestlist%3 || $nTestlist==0 } {
1115     error "SELECT test list contains [llength $testlist] elements"
1116   }
1117
1118   eval $repair
1119   foreach {tn sql res} $testlist {
1120     if {$tclquery != ""} {
1121       execsql $sql
1122       uplevel do_test ${prefix}.$tn [list $tclquery] [list [list {*}$res]]
1123     } elseif {$countonly} {
1124       set nRow 0
1125       db eval $sql {incr nRow}
1126       uplevel do_test ${prefix}.$tn [list [list set {} $nRow]] [list $res]
1127     } elseif {$errfmt==""} {
1128       uplevel do_execsql_test ${prefix}.${tn} [list $sql] [list [list {*}$res]]
1129     } else {
1130       set res [list 1 [string trim [format $errfmt {*}$res]]]
1131       uplevel do_catchsql_test ${prefix}.${tn} [list $sql] [list $res]
1132     }
1133     eval $repair
1134   }
1135
1136 }
1137
1138 proc delete_all_data {} {
1139   db eval {SELECT tbl_name AS t FROM sqlite_master WHERE type = 'table'} {
1140     db eval "DELETE FROM '[string map {' ''} $t]'"
1141   }
1142 }
1143
1144 # Run an SQL script.
1145 # Return the number of microseconds per statement.
1146 #
1147 proc speed_trial {name numstmt units sql} {
1148   output2 -nonewline [format {%-21.21s } $name...]
1149   flush stdout
1150   set speed [time {sqlite3_exec_nr db $sql}]
1151   set tm [lindex $speed 0]
1152   if {$tm == 0} {
1153     set rate [format %20s "many"]
1154   } else {
1155     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
1156   }
1157   set u2 $units/s
1158   output2 [format {%12d uS %s %s} $tm $rate $u2]
1159   global total_time
1160   set total_time [expr {$total_time+$tm}]
1161   lappend ::speed_trial_times $name $tm
1162 }
1163 proc speed_trial_tcl {name numstmt units script} {
1164   output2 -nonewline [format {%-21.21s } $name...]
1165   flush stdout
1166   set speed [time {eval $script}]
1167   set tm [lindex $speed 0]
1168   if {$tm == 0} {
1169     set rate [format %20s "many"]
1170   } else {
1171     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
1172   }
1173   set u2 $units/s
1174   output2 [format {%12d uS %s %s} $tm $rate $u2]
1175   global total_time
1176   set total_time [expr {$total_time+$tm}]
1177   lappend ::speed_trial_times $name $tm
1178 }
1179 proc speed_trial_init {name} {
1180   global total_time
1181   set total_time 0
1182   set ::speed_trial_times [list]
1183   sqlite3 versdb :memory:
1184   set vers [versdb one {SELECT sqlite_source_id()}]
1185   versdb close
1186   output2 "SQLite $vers"
1187 }
1188 proc speed_trial_summary {name} {
1189   global total_time
1190   output2 [format {%-21.21s %12d uS TOTAL} $name $total_time]
1191
1192   if { 0 } {
1193     sqlite3 versdb :memory:
1194     set vers [lindex [versdb one {SELECT sqlite_source_id()}] 0]
1195     versdb close
1196     output2 "CREATE TABLE IF NOT EXISTS time(version, script, test, us);"
1197     foreach {test us} $::speed_trial_times {
1198       output2 "INSERT INTO time VALUES('$vers', '$name', '$test', $us);"
1199     }
1200   }
1201 }
1202
1203 # Run this routine last
1204 #
1205 proc finish_test {} {
1206   catch {db close}
1207   catch {db1 close}
1208   catch {db2 close}
1209   catch {db3 close}
1210   if {0==[info exists ::SLAVE]} { finalize_testing }
1211 }
1212 proc finalize_testing {} {
1213   global sqlite_open_file_count
1214
1215   set omitList [set_test_counter omit_list]
1216
1217   catch {db close}
1218   catch {db2 close}
1219   catch {db3 close}
1220
1221   vfs_unlink_test
1222   sqlite3 db {}
1223   # sqlite3_clear_tsd_memdebug
1224   db close
1225   sqlite3_reset_auto_extension
1226
1227   sqlite3_soft_heap_limit64 0
1228   sqlite3_hard_heap_limit64 0
1229   set nTest [incr_ntest]
1230   set nErr [set_test_counter errors]
1231
1232   set nKnown 0
1233   if {[file readable known-problems.txt]} {
1234     set fd [open known-problems.txt]
1235     set content [read $fd]
1236     close $fd
1237     foreach x $content {set known_error($x) 1}
1238     foreach x [set_test_counter fail_list] {
1239       if {[info exists known_error($x)]} {incr nKnown}
1240     }
1241   }
1242   if {$nKnown>0} {
1243     output2 "[expr {$nErr-$nKnown}] new errors and $nKnown known errors\
1244          out of $nTest tests"
1245   } else {
1246     set cpuinfo {}
1247     if {[catch {exec hostname} hname]==0} {set cpuinfo [string trim $hname]}
1248     append cpuinfo " $::tcl_platform(os)"
1249     append cpuinfo " [expr {$::tcl_platform(pointerSize)*8}]-bit"
1250     append cpuinfo " [string map {E -e} $::tcl_platform(byteOrder)]"
1251     output2 "SQLite [sqlite3 -sourceid]"
1252     output2 "$nErr errors out of $nTest tests on $cpuinfo"
1253   }
1254   if {$nErr>$nKnown} {
1255     output2 -nonewline "!Failures on these tests:"
1256     foreach x [set_test_counter fail_list] {
1257       if {![info exists known_error($x)]} {output2 -nonewline " $x"}
1258     }
1259     output2 ""
1260   }
1261   foreach warning [set_test_counter warn_list] {
1262     output2 "Warning: $warning"
1263   }
1264   run_thread_tests 1
1265   if {[llength $omitList]>0} {
1266     output2 "Omitted test cases:"
1267     set prec {}
1268     foreach {rec} [lsort $omitList] {
1269       if {$rec==$prec} continue
1270       set prec $rec
1271       output2 [format {.  %-12s %s} [lindex $rec 0] [lindex $rec 1]]
1272     }
1273   }
1274   if {$nErr>0 && ![working_64bit_int]} {
1275     output2 "******************************************************************"
1276     output2 "N.B.:  The version of TCL that you used to build this test harness"
1277     output2 "is defective in that it does not support 64-bit integers.  Some or"
1278     output2 "all of the test failures above might be a result from this defect"
1279     output2 "in your TCL build."
1280     output2 "******************************************************************"
1281   }
1282   if {$::cmdlinearg(binarylog)} {
1283     vfslog finalize binarylog
1284   }
1285   if {$sqlite_open_file_count} {
1286     output2 "$sqlite_open_file_count files were left open"
1287     incr nErr
1288   }
1289   if {[lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1]>0 ||
1290               [sqlite3_memory_used]>0} {
1291     output2 "Unfreed memory: [sqlite3_memory_used] bytes in\
1292          [lindex [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0] 1] allocations"
1293     incr nErr
1294     ifcapable mem5||(mem3&&debug) {
1295       output2 "Writing unfreed memory log to \"./memleak.txt\""
1296       sqlite3_memdebug_dump ./memleak.txt
1297     }
1298   } else {
1299     output2 "All memory allocations freed - no leaks"
1300     ifcapable mem5 {
1301       sqlite3_memdebug_dump ./memusage.txt
1302     }
1303   }
1304   show_memstats
1305   output2 "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
1306   output2 "Current memory usage: [sqlite3_memory_highwater] bytes"
1307   if {[info commands sqlite3_memdebug_malloc_count] ne ""} {
1308     output2 "Number of malloc()  : [sqlite3_memdebug_malloc_count] calls"
1309   }
1310   if {$::cmdlinearg(malloctrace)} {
1311     output2 "Writing mallocs.tcl..."
1312     memdebug_log_sql mallocs.tcl
1313     sqlite3_memdebug_log stop
1314     sqlite3_memdebug_log clear
1315     if {[sqlite3_memory_used]>0} {
1316       output2 "Writing leaks.tcl..."
1317       sqlite3_memdebug_log sync
1318       memdebug_log_sql leaks.tcl
1319     }
1320   }
1321   if {[info commands vdbe_coverage]!=""} {
1322     vdbe_coverage_report
1323   }
1324   foreach f [glob -nocomplain test.db-*-journal] {
1325     forcedelete $f
1326   }
1327   foreach f [glob -nocomplain test.db-mj*] {
1328     forcedelete $f
1329   }
1330   exit [expr {$nErr>0}]
1331 }
1332
1333 proc vdbe_coverage_report {} {
1334   puts "Writing vdbe coverage report to vdbe_coverage.txt"
1335   set lSrc [list]
1336   set iLine 0
1337   if {[file exists ../sqlite3.c]} {
1338     set fd [open ../sqlite3.c]
1339     set iLine
1340     while { ![eof $fd] } {
1341       set line [gets $fd]
1342       incr iLine
1343       if {[regexp {^/\** Begin file (.*\.c) \**/} $line -> file]} {
1344         lappend lSrc [list $iLine $file]
1345       }
1346     }
1347     close $fd
1348   }
1349   set fd [open vdbe_coverage.txt w]
1350   foreach miss [vdbe_coverage report] {
1351     foreach {line branch never} $miss {}
1352     set nextfile ""
1353     while {[llength $lSrc]>0 && [lindex $lSrc 0 0] < $line} {
1354       set nextfile [lindex $lSrc 0 1]
1355       set lSrc [lrange $lSrc 1 end]
1356     }
1357     if {$nextfile != ""} {
1358       puts $fd ""
1359       puts $fd "### $nextfile ###"
1360     }
1361     puts $fd "Vdbe branch $line: never $never (path $branch)"
1362   }
1363   close $fd
1364 }
1365
1366 # Display memory statistics for analysis and debugging purposes.
1367 #
1368 proc show_memstats {} {
1369   set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]
1370   set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]
1371   set val [format {now %10d  max %10d  max-size %10d} \
1372               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1373   output1 "Memory used:          $val"
1374   set x [sqlite3_status SQLITE_STATUS_MALLOC_COUNT 0]
1375   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
1376   output1 "Allocation count:     $val"
1377   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]
1378   set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]
1379   set val [format {now %10d  max %10d  max-size %10d} \
1380               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
1381   output1 "Page-cache used:      $val"
1382   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]
1383   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
1384   output1 "Page-cache overflow:  $val"
1385   ifcapable yytrackmaxstackdepth {
1386     set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]
1387     set val [format {               max %10d} [lindex $x 2]]
1388     output2 "Parser stack depth:    $val"
1389   }
1390 }
1391
1392 # A procedure to execute SQL
1393 #
1394 proc execsql {sql {db db}} {
1395   # puts "SQL = $sql"
1396   uplevel [list $db eval $sql]
1397 }
1398 proc execsql_timed {sql {db db}} {
1399   set tm [time {
1400     set x [uplevel [list $db eval $sql]]
1401   } 1]
1402   set tm [lindex $tm 0]
1403   output1 -nonewline " ([expr {$tm*0.001}]ms) "
1404   set x
1405 }
1406
1407 # Execute SQL and catch exceptions.
1408 #
1409 proc catchsql {sql {db db}} {
1410   # puts "SQL = $sql"
1411   set r [catch [list uplevel [list $db eval $sql]] msg]
1412   lappend r $msg
1413   return $r
1414 }
1415
1416 # Do an VDBE code dump on the SQL given
1417 #
1418 proc explain {sql {db db}} {
1419   output2 ""
1420   output2 "addr  opcode        p1      p2      p3      p4               p5  #"
1421   output2 "----  ------------  ------  ------  ------  ---------------  --  -"
1422   $db eval "explain $sql" {} {
1423     output2 [format {%-4d  %-12.12s  %-6d  %-6d  %-6d  % -17s %s  %s} \
1424       $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
1425     ]
1426   }
1427 }
1428
1429 proc explain_i {sql {db db}} {
1430   output2 ""
1431   output2 "addr  opcode        p1      p2      p3      p4                p5  #"
1432   output2 "----  ------------  ------  ------  ------  ----------------  --  -"
1433
1434
1435   # Set up colors for the different opcodes. Scheme is as follows:
1436   #
1437   #   Red:   Opcodes that write to a b-tree.
1438   #   Blue:  Opcodes that reposition or seek a cursor.
1439   #   Green: The ResultRow opcode.
1440   #
1441   if { [catch {fconfigure stdout -mode}]==0 } {
1442     set R "\033\[31;1m"        ;# Red fg
1443     set G "\033\[32;1m"        ;# Green fg
1444     set B "\033\[34;1m"        ;# Red fg
1445     set D "\033\[39;0m"        ;# Default fg
1446   } else {
1447     set R ""
1448     set G ""
1449     set B ""
1450     set D ""
1451   }
1452   foreach opcode {
1453       Seek SeekGE SeekGT SeekLE SeekLT NotFound Last Rewind
1454       NoConflict Next Prev VNext VPrev VFilter
1455       SorterSort SorterNext NextIfOpen
1456   } {
1457     set color($opcode) $B
1458   }
1459   foreach opcode {ResultRow} {
1460     set color($opcode) $G
1461   }
1462   foreach opcode {IdxInsert Insert Delete IdxDelete} {
1463     set color($opcode) $R
1464   }
1465
1466   set bSeenGoto 0
1467   $db eval "explain $sql" {} {
1468     set x($addr) 0
1469     set op($addr) $opcode
1470
1471     if {$opcode == "Goto" && ($bSeenGoto==0 || ($p2 > $addr+10))} {
1472       set linebreak($p2) 1
1473       set bSeenGoto 1
1474     }
1475
1476     if {$opcode=="Once"} {
1477       for {set i $addr} {$i<$p2} {incr i} {
1478         set star($i) $addr
1479       }
1480     }
1481
1482     if {$opcode=="Next"  || $opcode=="Prev"
1483      || $opcode=="VNext" || $opcode=="VPrev"
1484      || $opcode=="SorterNext" || $opcode=="NextIfOpen"
1485     } {
1486       for {set i $p2} {$i<$addr} {incr i} {
1487         incr x($i) 2
1488       }
1489     }
1490
1491     if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} {
1492       for {set i [expr $p2+1]} {$i<$addr} {incr i} {
1493         incr x($i) 2
1494       }
1495     }
1496
1497     if {$opcode == "Halt" && $comment == "End of coroutine"} {
1498       set linebreak([expr $addr+1]) 1
1499     }
1500   }
1501
1502   $db eval "explain $sql" {} {
1503     if {[info exists linebreak($addr)]} {
1504       output2 ""
1505     }
1506     set I [string repeat " " $x($addr)]
1507
1508     if {[info exists star($addr)]} {
1509       set ii [expr $x($star($addr))]
1510       append I "  "
1511       set I [string replace $I $ii $ii *]
1512     }
1513
1514     set col ""
1515     catch { set col $color($opcode) }
1516
1517     output2 [format {%-4d  %s%s%-12.12s%s  %-6d  %-6d  %-6d  % -17s %s  %s} \
1518       $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment
1519     ]
1520   }
1521   output2 "----  ------------  ------  ------  ------  ----------------  --  -"
1522 }
1523
1524 # Show the VDBE program for an SQL statement but omit the Trace
1525 # opcode at the beginning.  This procedure can be used to prove
1526 # that different SQL statements generate exactly the same VDBE code.
1527 #
1528 proc explain_no_trace {sql} {
1529   set tr [db eval "EXPLAIN $sql"]
1530   return [lrange $tr 7 end]
1531 }
1532
1533 # Another procedure to execute SQL.  This one includes the field
1534 # names in the returned list.
1535 #
1536 proc execsql2 {sql} {
1537   set result {}
1538   db eval $sql data {
1539     foreach f $data(*) {
1540       lappend result $f $data($f)
1541     }
1542   }
1543   return $result
1544 }
1545
1546 # Use a temporary in-memory database to execute SQL statements
1547 #
1548 proc memdbsql {sql} {
1549   sqlite3 memdb :memory:
1550   set result [memdb eval $sql]
1551   memdb close
1552   return $result
1553 }
1554
1555 # Use the non-callback API to execute multiple SQL statements
1556 #
1557 proc stepsql {dbptr sql} {
1558   set sql [string trim $sql]
1559   set r 0
1560   while {[string length $sql]>0} {
1561     if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {
1562       return [list 1 $vm]
1563     }
1564     set sql [string trim $sqltail]
1565 #    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
1566 #      foreach v $VAL {lappend r $v}
1567 #    }
1568     while {[sqlite3_step $vm]=="SQLITE_ROW"} {
1569       for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {
1570         lappend r [sqlite3_column_text $vm $i]
1571       }
1572     }
1573     if {[catch {sqlite3_finalize $vm} errmsg]} {
1574       return [list 1 $errmsg]
1575     }
1576   }
1577   return $r
1578 }
1579
1580 # Do an integrity check of the entire database
1581 #
1582 proc integrity_check {name {db db}} {
1583   ifcapable integrityck {
1584     do_test $name [list execsql {PRAGMA integrity_check} $db] {ok}
1585   }
1586 }
1587
1588 # Check the extended error code
1589 #
1590 proc verify_ex_errcode {name expected {db db}} {
1591   do_test $name [list sqlite3_extended_errcode $db] $expected
1592 }
1593
1594
1595 # Return true if the SQL statement passed as the second argument uses a
1596 # statement transaction.
1597 #
1598 proc sql_uses_stmt {db sql} {
1599   set stmt [sqlite3_prepare $db $sql -1 dummy]
1600   set uses [uses_stmt_journal $stmt]
1601   sqlite3_finalize $stmt
1602   return $uses
1603 }
1604
1605 proc fix_ifcapable_expr {expr} {
1606   set ret ""
1607   set state 0
1608   for {set i 0} {$i < [string length $expr]} {incr i} {
1609     set char [string range $expr $i $i]
1610     set newstate [expr {[string is alnum $char] || $char eq "_"}]
1611     if {$newstate && !$state} {
1612       append ret {$::sqlite_options(}
1613     }
1614     if {!$newstate && $state} {
1615       append ret )
1616     }
1617     append ret $char
1618     set state $newstate
1619   }
1620   if {$state} {append ret )}
1621   return $ret
1622 }
1623
1624 # Returns non-zero if the capabilities are present; zero otherwise.
1625 #
1626 proc capable {expr} {
1627   set e [fix_ifcapable_expr $expr]; return [expr ($e)]
1628 }
1629
1630 # Evaluate a boolean expression of capabilities.  If true, execute the
1631 # code.  Omit the code if false.
1632 #
1633 proc ifcapable {expr code {else ""} {elsecode ""}} {
1634   #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
1635   set e2 [fix_ifcapable_expr $expr]
1636   if ($e2) {
1637     set c [catch {uplevel 1 $code} r]
1638   } else {
1639     set c [catch {uplevel 1 $elsecode} r]
1640   }
1641   return -code $c $r
1642 }
1643
1644 # This proc execs a seperate process that crashes midway through executing
1645 # the SQL script $sql on database test.db.
1646 #
1647 # The crash occurs during a sync() of file $crashfile. When the crash
1648 # occurs a random subset of all unsynced writes made by the process are
1649 # written into the files on disk. Argument $crashdelay indicates the
1650 # number of file syncs to wait before crashing.
1651 #
1652 # The return value is a list of two elements. The first element is a
1653 # boolean, indicating whether or not the process actually crashed or
1654 # reported some other error. The second element in the returned list is the
1655 # error message. This is "child process exited abnormally" if the crash
1656 # occurred.
1657 #
1658 #   crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
1659 #
1660 proc crashsql {args} {
1661
1662   set blocksize ""
1663   set crashdelay 1
1664   set prngseed 0
1665   set opendb { sqlite3 db test.db -vfs crash }
1666   set tclbody {}
1667   set crashfile ""
1668   set dc ""
1669   set dfltvfs 0
1670   set sql [lindex $args end]
1671
1672   for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {
1673     set z [lindex $args $ii]
1674     set n [string length $z]
1675     set z2 [lindex $args [expr $ii+1]]
1676
1677     if     {$n>1 && [string first $z -delay]==0}     {set crashdelay $z2} \
1678     elseif {$n>1 && [string first $z -opendb]==0}    {set opendb $z2} \
1679     elseif {$n>1 && [string first $z -seed]==0}      {set prngseed $z2} \
1680     elseif {$n>1 && [string first $z -file]==0}      {set crashfile $z2}  \
1681     elseif {$n>1 && [string first $z -tclbody]==0}   {set tclbody $z2}  \
1682     elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \
1683     elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" }\
1684     elseif {$n>1 && [string first $z -dfltvfs]==0} {set dfltvfs $z2 }\
1685     else   { error "Unrecognized option: $z" }
1686   }
1687
1688   if {$crashfile eq ""} {
1689     error "Compulsory option -file missing"
1690   }
1691
1692   # $crashfile gets compared to the native filename in
1693   # cfSync(), which can be different then what TCL uses by
1694   # default, so here we force it to the "nativename" format.
1695   set cfile [string map {\\ \\\\} [file nativename [file join [get_pwd] $crashfile]]]
1696
1697   set f [open crash.tcl w]
1698   puts $f "sqlite3_initialize ; sqlite3_shutdown"
1699   puts $f "catch { install_malloc_faultsim 1 }"
1700   puts $f "sqlite3_crash_enable 1 $dfltvfs"
1701   puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
1702   puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
1703   puts $f "autoinstall_test_functions"
1704
1705   # This block sets the cache size of the main database to 10
1706   # pages. This is done in case the build is configured to omit
1707   # "PRAGMA cache_size".
1708   if {$opendb!=""} {
1709     puts $f $opendb
1710     puts $f {db eval {SELECT * FROM sqlite_master;}}
1711     puts $f {set bt [btree_from_db db]}
1712     puts $f {btree_set_cache_size $bt 10}
1713   }
1714
1715   if {$prngseed} {
1716     set seed [expr {$prngseed%10007+1}]
1717     # puts seed=$seed
1718     puts $f "db eval {SELECT randomblob($seed)}"
1719   }
1720
1721   if {[string length $tclbody]>0} {
1722     puts $f $tclbody
1723   }
1724   if {[string length $sql]>0} {
1725     puts $f "db eval {"
1726     puts $f   "$sql"
1727     puts $f "}"
1728   }
1729   close $f
1730   set r [catch {
1731     exec [info nameofexec] crash.tcl >@stdout 2>@stdout
1732   } msg]
1733
1734   # Windows/ActiveState TCL returns a slightly different
1735   # error message.  We map that to the expected message
1736   # so that we don't have to change all of the test
1737   # cases.
1738   if {$::tcl_platform(platform)=="windows"} {
1739     if {$msg=="child killed: unknown signal"} {
1740       set msg "child process exited abnormally"
1741     }
1742   }
1743   if {$r && [string match {*ERROR: LeakSanitizer*} $msg]} {
1744     set msg "child process exited abnormally"
1745   }
1746
1747   lappend r $msg
1748 }
1749
1750 #   crash_on_write ?-devchar DEVCHAR? CRASHDELAY SQL
1751 #
1752 proc crash_on_write {args} {
1753
1754   set nArg [llength $args]
1755   if {$nArg<2 || $nArg%2} {
1756     error "bad args: $args"
1757   }
1758   set zSql [lindex $args end]
1759   set nDelay [lindex $args end-1]
1760
1761   set devchar {}
1762   for {set ii 0} {$ii < $nArg-2} {incr ii 2} {
1763     set opt [lindex $args $ii]
1764     switch -- [lindex $args $ii] {
1765       -devchar {
1766         set devchar [lindex $args [expr $ii+1]]
1767       }
1768
1769       default { error "unrecognized option: $opt" }
1770     }
1771   }
1772
1773   set f [open crash.tcl w]
1774   puts $f "sqlite3_crash_on_write $nDelay"
1775   puts $f "sqlite3_test_control_pending_byte $::sqlite_pending_byte"
1776   puts $f "sqlite3 db test.db -vfs writecrash"
1777   puts $f "db eval {$zSql}"
1778   puts $f "set {} {}"
1779
1780   close $f
1781   set r [catch {
1782     exec [info nameofexec] crash.tcl >@stdout
1783   } msg]
1784
1785   # Windows/ActiveState TCL returns a slightly different
1786   # error message.  We map that to the expected message
1787   # so that we don't have to change all of the test
1788   # cases.
1789   if {$::tcl_platform(platform)=="windows"} {
1790     if {$msg=="child killed: unknown signal"} {
1791       set msg "child process exited abnormally"
1792     }
1793   }
1794
1795   lappend r $msg
1796 }
1797
1798 proc run_ioerr_prep {} {
1799   set ::sqlite_io_error_pending 0
1800   catch {db close}
1801   catch {db2 close}
1802   catch {forcedelete test.db}
1803   catch {forcedelete test.db-journal}
1804   catch {forcedelete test2.db}
1805   catch {forcedelete test2.db-journal}
1806   set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
1807   sqlite3_extended_result_codes $::DB $::ioerropts(-erc)
1808   if {[info exists ::ioerropts(-tclprep)]} {
1809     eval $::ioerropts(-tclprep)
1810   }
1811   if {[info exists ::ioerropts(-sqlprep)]} {
1812     execsql $::ioerropts(-sqlprep)
1813   }
1814   expr 0
1815 }
1816
1817 # Usage: do_ioerr_test <test number> <options...>
1818 #
1819 # This proc is used to implement test cases that check that IO errors
1820 # are correctly handled. The first argument, <test number>, is an integer
1821 # used to name the tests executed by this proc. Options are as follows:
1822 #
1823 #     -tclprep          TCL script to run to prepare test.
1824 #     -sqlprep          SQL script to run to prepare test.
1825 #     -tclbody          TCL script to run with IO error simulation.
1826 #     -sqlbody          TCL script to run with IO error simulation.
1827 #     -exclude          List of 'N' values not to test.
1828 #     -erc              Use extended result codes
1829 #     -persist          Make simulated I/O errors persistent
1830 #     -start            Value of 'N' to begin with (default 1)
1831 #
1832 #     -cksum            Boolean. If true, test that the database does
1833 #                       not change during the execution of the test case.
1834 #
1835 proc do_ioerr_test {testname args} {
1836
1837   set ::ioerropts(-start) 1
1838   set ::ioerropts(-cksum) 0
1839   set ::ioerropts(-erc) 0
1840   set ::ioerropts(-count) 100000000
1841   set ::ioerropts(-persist) 1
1842   set ::ioerropts(-ckrefcount) 0
1843   set ::ioerropts(-restoreprng) 1
1844   array set ::ioerropts $args
1845
1846   # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
1847   # a couple of obscure IO errors that do not return them.
1848   set ::ioerropts(-erc) 0
1849
1850   # Create a single TCL script from the TCL and SQL specified
1851   # as the body of the test.
1852   set ::ioerrorbody {}
1853   if {[info exists ::ioerropts(-tclbody)]} {
1854     append ::ioerrorbody "$::ioerropts(-tclbody)\n"
1855   }
1856   if {[info exists ::ioerropts(-sqlbody)]} {
1857     append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
1858   }
1859
1860   save_prng_state
1861   if {$::ioerropts(-cksum)} {
1862     run_ioerr_prep
1863     eval $::ioerrorbody
1864     set ::goodcksum [cksum]
1865   }
1866
1867   set ::go 1
1868   #reset_prng_state
1869   for {set n $::ioerropts(-start)} {$::go} {incr n} {
1870     set ::TN $n
1871     incr ::ioerropts(-count) -1
1872     if {$::ioerropts(-count)<0} break
1873
1874     # Skip this IO error if it was specified with the "-exclude" option.
1875     if {[info exists ::ioerropts(-exclude)]} {
1876       if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
1877     }
1878     if {$::ioerropts(-restoreprng)} {
1879       restore_prng_state
1880     }
1881
1882     # Delete the files test.db and test2.db, then execute the TCL and
1883     # SQL (in that order) to prepare for the test case.
1884     do_test $testname.$n.1 {
1885       run_ioerr_prep
1886     } {0}
1887
1888     # Read the 'checksum' of the database.
1889     if {$::ioerropts(-cksum)} {
1890       set ::checksum [cksum]
1891     }
1892
1893     # Set the Nth IO error to fail.
1894     do_test $testname.$n.2 [subst {
1895       set ::sqlite_io_error_persist $::ioerropts(-persist)
1896       set ::sqlite_io_error_pending $n
1897     }] $n
1898
1899     # Execute the TCL script created for the body of this test. If
1900     # at least N IO operations performed by SQLite as a result of
1901     # the script, the Nth will fail.
1902     do_test $testname.$n.3 {
1903       set ::sqlite_io_error_hit 0
1904       set ::sqlite_io_error_hardhit 0
1905       set r [catch $::ioerrorbody msg]
1906       set ::errseen $r
1907       set rc [sqlite3_errcode $::DB]
1908       if {$::ioerropts(-erc)} {
1909         # If we are in extended result code mode, make sure all of the
1910         # IOERRs we get back really do have their extended code values.
1911         # If an extended result code is returned, the sqlite3_errcode
1912         # TCLcommand will return a string of the form:  SQLITE_IOERR+nnnn
1913         # where nnnn is a number
1914         if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {
1915           return $rc
1916         }
1917       } else {
1918         # If we are not in extended result code mode, make sure no
1919         # extended error codes are returned.
1920         if {[regexp {\+\d} $rc]} {
1921           return $rc
1922         }
1923       }
1924       # The test repeats as long as $::go is non-zero.  $::go starts out
1925       # as 1.  When a test runs to completion without hitting an I/O
1926       # error, that means there is no point in continuing with this test
1927       # case so set $::go to zero.
1928       #
1929       if {$::sqlite_io_error_pending>0} {
1930         set ::go 0
1931         set q 0
1932         set ::sqlite_io_error_pending 0
1933       } else {
1934         set q 1
1935       }
1936
1937       set s [expr $::sqlite_io_error_hit==0]
1938       if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
1939         set r 1
1940       }
1941       set ::sqlite_io_error_hit 0
1942
1943       # One of two things must have happened. either
1944       #   1.  We never hit the IO error and the SQL returned OK
1945       #   2.  An IO error was hit and the SQL failed
1946       #
1947       #puts "s=$s r=$r q=$q"
1948       expr { ($s && !$r && !$q) || (!$s && $r && $q) }
1949     } {1}
1950
1951     set ::sqlite_io_error_hit 0
1952     set ::sqlite_io_error_pending 0
1953
1954     # Check that no page references were leaked. There should be
1955     # a single reference if there is still an active transaction,
1956     # or zero otherwise.
1957     #
1958     # UPDATE: If the IO error occurs after a 'BEGIN' but before any
1959     # locks are established on database files (i.e. if the error
1960     # occurs while attempting to detect a hot-journal file), then
1961     # there may 0 page references and an active transaction according
1962     # to [sqlite3_get_autocommit].
1963     #
1964     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
1965       do_test $testname.$n.4 {
1966         set bt [btree_from_db db]
1967         db_enter db
1968         array set stats [btree_pager_stats $bt]
1969         db_leave db
1970         set nRef $stats(ref)
1971         expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}
1972       } {1}
1973     }
1974
1975     # If there is an open database handle and no open transaction,
1976     # and the pager is not running in exclusive-locking mode,
1977     # check that the pager is in "unlocked" state. Theoretically,
1978     # if a call to xUnlock() failed due to an IO error the underlying
1979     # file may still be locked.
1980     #
1981     ifcapable pragma {
1982       if { [info commands db] ne ""
1983         && $::ioerropts(-ckrefcount)
1984         && [db one {pragma locking_mode}] eq "normal"
1985         && [sqlite3_get_autocommit db]
1986       } {
1987         do_test $testname.$n.5 {
1988           set bt [btree_from_db db]
1989           db_enter db
1990           array set stats [btree_pager_stats $bt]
1991           db_leave db
1992           set stats(state)
1993         } 0
1994       }
1995     }
1996
1997     # If an IO error occurred, then the checksum of the database should
1998     # be the same as before the script that caused the IO error was run.
1999     #
2000     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
2001       do_test $testname.$n.6 {
2002         catch {db close}
2003         catch {db2 close}
2004         set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
2005         set nowcksum [cksum]
2006         set res [expr {$nowcksum==$::checksum || $nowcksum==$::goodcksum}]
2007         if {$res==0} {
2008           output2 "now=$nowcksum"
2009           output2 "the=$::checksum"
2010           output2 "fwd=$::goodcksum"
2011         }
2012         set res
2013       } 1
2014     }
2015
2016     set ::sqlite_io_error_hardhit 0
2017     set ::sqlite_io_error_pending 0
2018     if {[info exists ::ioerropts(-cleanup)]} {
2019       catch $::ioerropts(-cleanup)
2020     }
2021   }
2022   set ::sqlite_io_error_pending 0
2023   set ::sqlite_io_error_persist 0
2024   unset ::ioerropts
2025 }
2026
2027 # Return a checksum based on the contents of the main database associated
2028 # with connection $db
2029 #
2030 proc cksum {{db db}} {
2031   set txt [$db eval {
2032       SELECT name, type, sql FROM sqlite_master order by name
2033   }]\n
2034   foreach tbl [$db eval {
2035       SELECT name FROM sqlite_master WHERE type='table' order by name
2036   }] {
2037     append txt [$db eval "SELECT * FROM $tbl"]\n
2038   }
2039   foreach prag {default_synchronous default_cache_size} {
2040     append txt $prag-[$db eval "PRAGMA $prag"]\n
2041   }
2042   set cksum [string length $txt]-[md5 $txt]
2043   # puts $cksum-[file size test.db]
2044   return $cksum
2045 }
2046
2047 # Generate a checksum based on the contents of the main and temp tables
2048 # database $db. If the checksum of two databases is the same, and the
2049 # integrity-check passes for both, the two databases are identical.
2050 #
2051 proc allcksum {{db db}} {
2052   set ret [list]
2053   ifcapable tempdb {
2054     set sql {
2055       SELECT name FROM sqlite_master WHERE type = 'table' UNION
2056       SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION
2057       SELECT 'sqlite_master' UNION
2058       SELECT 'sqlite_temp_master' ORDER BY 1
2059     }
2060   } else {
2061     set sql {
2062       SELECT name FROM sqlite_master WHERE type = 'table' UNION
2063       SELECT 'sqlite_master' ORDER BY 1
2064     }
2065   }
2066   set tbllist [$db eval $sql]
2067   set txt {}
2068   foreach tbl $tbllist {
2069     append txt [$db eval "SELECT * FROM $tbl"]
2070   }
2071   foreach prag {default_cache_size} {
2072     append txt $prag-[$db eval "PRAGMA $prag"]\n
2073   }
2074   # puts txt=$txt
2075   return [md5 $txt]
2076 }
2077
2078 # Generate a checksum based on the contents of a single database with
2079 # a database connection.  The name of the database is $dbname.
2080 # Examples of $dbname are "temp" or "main".
2081 #
2082 proc dbcksum {db dbname} {
2083   if {$dbname=="temp"} {
2084     set master sqlite_temp_master
2085   } else {
2086     set master $dbname.sqlite_master
2087   }
2088   set alltab [$db eval "SELECT name FROM $master WHERE type='table'"]
2089   set txt [$db eval "SELECT * FROM $master"]\n
2090   foreach tab $alltab {
2091     append txt [$db eval "SELECT * FROM $dbname.$tab"]\n
2092   }
2093   return [md5 $txt]
2094 }
2095
2096 proc memdebug_log_sql {filename} {
2097
2098   set data [sqlite3_memdebug_log dump]
2099   set nFrame [expr [llength [lindex $data 0]]-2]
2100   if {$nFrame < 0} { return "" }
2101
2102   set database temp
2103
2104   set tbl "CREATE TABLE ${database}.malloc(zTest, nCall, nByte, lStack);"
2105
2106   set sql ""
2107   foreach e $data {
2108     set nCall [lindex $e 0]
2109     set nByte [lindex $e 1]
2110     set lStack [lrange $e 2 end]
2111     append sql "INSERT INTO ${database}.malloc VALUES"
2112     append sql "('test', $nCall, $nByte, '$lStack');\n"
2113     foreach f $lStack {
2114       set frames($f) 1
2115     }
2116   }
2117
2118   set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
2119   set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
2120
2121   set pid [pid]
2122
2123   foreach f [array names frames] {
2124     set addr [format %x $f]
2125     set cmd "eu-addr2line --pid=$pid $addr"
2126     set line [eval exec $cmd]
2127     append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
2128
2129     set file [lindex [split $line :] 0]
2130     set files($file) 1
2131   }
2132
2133   foreach f [array names files] {
2134     set contents ""
2135     catch {
2136       set fd [open $f]
2137       set contents [read $fd]
2138       close $fd
2139     }
2140     set contents [string map {' ''} $contents]
2141     append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
2142   }
2143
2144   set escaped "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
2145   set escaped [string map [list "{" "\\{" "}" "\\}"] $escaped]
2146
2147   set fd [open $filename w]
2148   puts $fd "set BUILTIN {"
2149   puts $fd $escaped
2150   puts $fd "}"
2151   puts $fd {set BUILTIN [string map [list "\\{" "{" "\\}" "}"] $BUILTIN]}
2152   set mtv [open $::testdir/malloctraceviewer.tcl]
2153   set txt [read $mtv]
2154   close $mtv
2155   puts $fd $txt
2156   close $fd
2157 }
2158
2159 # Drop all tables in database [db]
2160 proc drop_all_tables {{db db}} {
2161   ifcapable trigger&&foreignkey {
2162     set pk [$db one "PRAGMA foreign_keys"]
2163     $db eval "PRAGMA foreign_keys = OFF"
2164   }
2165   foreach {idx name file} [db eval {PRAGMA database_list}] {
2166     if {$idx==1} {
2167       set master sqlite_temp_master
2168     } else {
2169       set master $name.sqlite_master
2170     }
2171     foreach {t type} [$db eval "
2172       SELECT name, type FROM $master
2173       WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
2174     "] {
2175       $db eval "DROP $type \"$t\""
2176     }
2177   }
2178   ifcapable trigger&&foreignkey {
2179     $db eval "PRAGMA foreign_keys = $pk"
2180   }
2181 }
2182
2183 # Drop all auxiliary indexes from the main database opened by handle [db].
2184 #
2185 proc drop_all_indexes {{db db}} {
2186   set L [$db eval {
2187     SELECT name FROM sqlite_master WHERE type='index' AND sql LIKE 'create%'
2188   }]
2189   foreach idx $L { $db eval "DROP INDEX $idx" }
2190 }
2191
2192
2193 #-------------------------------------------------------------------------
2194 # If a test script is executed with global variable $::G(perm:name) set to
2195 # "wal", then the tests are run in WAL mode. Otherwise, they should be run
2196 # in rollback mode. The following Tcl procs are used to make this less
2197 # intrusive:
2198 #
2199 #   wal_set_journal_mode ?DB?
2200 #
2201 #     If running a WAL test, execute "PRAGMA journal_mode = wal" using
2202 #     connection handle DB. Otherwise, this command is a no-op.
2203 #
2204 #   wal_check_journal_mode TESTNAME ?DB?
2205 #
2206 #     If running a WAL test, execute a tests case that fails if the main
2207 #     database for connection handle DB is not currently a WAL database.
2208 #     Otherwise (if not running a WAL permutation) this is a no-op.
2209 #
2210 #   wal_is_wal_mode
2211 #
2212 #     Returns true if this test should be run in WAL mode. False otherwise.
2213 #
2214 proc wal_is_wal_mode {} {
2215   expr {[permutation] eq "wal"}
2216 }
2217 proc wal_set_journal_mode {{db db}} {
2218   if { [wal_is_wal_mode] } {
2219     $db eval "PRAGMA journal_mode = WAL"
2220   }
2221 }
2222 proc wal_check_journal_mode {testname {db db}} {
2223   if { [wal_is_wal_mode] } {
2224     $db eval { SELECT * FROM sqlite_master }
2225     do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal}
2226   }
2227 }
2228
2229 proc wal_is_capable {} {
2230   ifcapable !wal { return 0 }
2231   if {[permutation]=="journaltest"} { return 0 }
2232   return 1
2233 }
2234
2235 proc permutation {} {
2236   set perm ""
2237   catch {set perm $::G(perm:name)}
2238   set perm
2239 }
2240 proc presql {} {
2241   set presql ""
2242   catch {set presql $::G(perm:presql)}
2243   set presql
2244 }
2245
2246 proc isquick {} {
2247   set ret 0
2248   catch {set ret $::G(isquick)}
2249   set ret
2250 }
2251
2252 #-------------------------------------------------------------------------
2253 #
2254 proc slave_test_script {script} {
2255
2256   # Create the interpreter used to run the test script.
2257   interp create tinterp
2258
2259   # Populate some global variables that tester.tcl expects to see.
2260   foreach {var value} [list              \
2261     ::argv0 $::argv0                     \
2262     ::argv  {}                           \
2263     ::SLAVE 1                            \
2264   ] {
2265     interp eval tinterp [list set $var $value]
2266   }
2267
2268   # If output is being copied into a file, share the file-descriptor with
2269   # the interpreter.
2270   if {[info exists ::G(output_fd)]} {
2271     interp share {} $::G(output_fd) tinterp
2272   }
2273
2274   # The alias used to access the global test counters.
2275   tinterp alias set_test_counter set_test_counter
2276
2277   # Set up the ::cmdlinearg array in the slave.
2278   interp eval tinterp [list array set ::cmdlinearg [array get ::cmdlinearg]]
2279
2280   # Set up the ::G array in the slave.
2281   interp eval tinterp [list array set ::G [array get ::G]]
2282
2283   # Load the various test interfaces implemented in C.
2284   load_testfixture_extensions tinterp
2285
2286   # Run the test script.
2287   interp eval tinterp $script
2288
2289   # Check if the interpreter call [run_thread_tests]
2290   if { [interp eval tinterp {info exists ::run_thread_tests_called}] } {
2291     set ::run_thread_tests_called 1
2292   }
2293
2294   # Delete the interpreter used to run the test script.
2295   interp delete tinterp
2296 }
2297
2298 proc slave_test_file {zFile} {
2299   set tail [file tail $zFile]
2300
2301   if {[info exists ::G(start:permutation)]} {
2302     if {[permutation] != $::G(start:permutation)} return
2303     unset ::G(start:permutation)
2304   }
2305   if {[info exists ::G(start:file)]} {
2306     if {$tail != $::G(start:file) && $tail!="$::G(start:file).test"} return
2307     unset ::G(start:file)
2308   }
2309
2310   # Remember the value of the shared-cache setting. So that it is possible
2311   # to check afterwards that it was not modified by the test script.
2312   #
2313   ifcapable shared_cache { set scs [sqlite3_enable_shared_cache] }
2314
2315   # Run the test script in a slave interpreter.
2316   #
2317   unset -nocomplain ::run_thread_tests_called
2318   reset_prng_state
2319   set ::sqlite_open_file_count 0
2320   set time [time { slave_test_script [list source $zFile] }]
2321   set ms [expr [lindex $time 0] / 1000]
2322
2323   # Test that all files opened by the test script were closed. Omit this
2324   # if the test script has "thread" in its name. The open file counter
2325   # is not thread-safe.
2326   #
2327   if {[info exists ::run_thread_tests_called]==0} {
2328     do_test ${tail}-closeallfiles { expr {$::sqlite_open_file_count>0} } {0}
2329   }
2330   set ::sqlite_open_file_count 0
2331
2332   # Test that the global "shared-cache" setting was not altered by
2333   # the test script.
2334   #
2335   ifcapable shared_cache {
2336     set res [expr {[sqlite3_enable_shared_cache] == $scs}]
2337     do_test ${tail}-sharedcachesetting [list set {} $res] 1
2338   }
2339
2340   # Add some info to the output.
2341   #
2342   output2 "Time: $tail $ms ms"
2343   show_memstats
2344 }
2345
2346 # Open a new connection on database test.db and execute the SQL script
2347 # supplied as an argument. Before returning, close the new conection and
2348 # restore the 4 byte fields starting at header offsets 28, 92 and 96
2349 # to the values they held before the SQL was executed. This simulates
2350 # a write by a pre-3.7.0 client.
2351 #
2352 proc sql36231 {sql} {
2353   set B [hexio_read test.db 92 8]
2354   set A [hexio_read test.db 28 4]
2355   sqlite3 db36231 test.db
2356   catch { db36231 func a_string a_string }
2357   execsql $sql db36231
2358   db36231 close
2359   hexio_write test.db 28 $A
2360   hexio_write test.db 92 $B
2361   return ""
2362 }
2363
2364 proc db_save {} {
2365   foreach f [glob -nocomplain sv_test.db*] { forcedelete $f }
2366   foreach f [glob -nocomplain test.db*] {
2367     set f2 "sv_$f"
2368     forcecopy $f $f2
2369   }
2370 }
2371 proc db_save_and_close {} {
2372   db_save
2373   catch { db close }
2374   return ""
2375 }
2376 proc db_restore {} {
2377   foreach f [glob -nocomplain test.db*] { forcedelete $f }
2378   foreach f2 [glob -nocomplain sv_test.db*] {
2379     set f [string range $f2 3 end]
2380     forcecopy $f2 $f
2381   }
2382 }
2383 proc db_restore_and_reopen {{dbfile test.db}} {
2384   catch { db close }
2385   db_restore
2386   sqlite3 db $dbfile
2387 }
2388 proc db_delete_and_reopen {{file test.db}} {
2389   catch { db close }
2390   foreach f [glob -nocomplain test.db*] { forcedelete $f }
2391   sqlite3 db $file
2392 }
2393
2394 # Close any connections named [db], [db2] or [db3]. Then use sqlite3_config
2395 # to configure the size of the PAGECACHE allocation using the parameters
2396 # provided to this command. Save the old PAGECACHE parameters in a global
2397 # variable so that [test_restore_config_pagecache] can restore the previous
2398 # configuration.
2399 #
2400 # Before returning, reopen connection [db] on file test.db.
2401 #
2402 proc test_set_config_pagecache {sz nPg} {
2403   catch {db close}
2404   catch {db2 close}
2405   catch {db3 close}
2406
2407   sqlite3_shutdown
2408   set ::old_pagecache_config [sqlite3_config_pagecache $sz $nPg]
2409   sqlite3_initialize
2410   autoinstall_test_functions
2411   reset_db
2412 }
2413
2414 # Close any connections named [db], [db2] or [db3]. Then use sqlite3_config
2415 # to configure the size of the PAGECACHE allocation to the size saved in
2416 # the global variable by an earlier call to [test_set_config_pagecache].
2417 #
2418 # Before returning, reopen connection [db] on file test.db.
2419 #
2420 proc test_restore_config_pagecache {} {
2421   catch {db close}
2422   catch {db2 close}
2423   catch {db3 close}
2424
2425   sqlite3_shutdown
2426   eval sqlite3_config_pagecache $::old_pagecache_config
2427   unset ::old_pagecache_config
2428   sqlite3_initialize
2429   autoinstall_test_functions
2430   sqlite3 db test.db
2431 }
2432
2433 proc test_binary_name {nm} {
2434   if {$::tcl_platform(platform)=="windows"} {
2435     set ret "$nm.exe"
2436   } else {
2437     set ret $nm
2438   }
2439   file normalize [file join $::cmdlinearg(TESTFIXTURE_HOME) $ret]
2440 }
2441
2442 proc test_find_binary {nm} {
2443   set ret [test_binary_name $nm]
2444   if {![file executable $ret]} {
2445     finish_test
2446     return ""
2447   }
2448   return $ret
2449 }
2450
2451 # Find the name of the 'shell' executable (e.g. "sqlite3.exe") to use for
2452 # the tests in shell[1-5].test. If no such executable can be found, invoke
2453 # [finish_test ; return] in the callers context.
2454 #
2455 proc test_find_cli {} {
2456   set prog [test_find_binary sqlite3]
2457   if {$prog==""} { return -code return }
2458   return $prog
2459 }
2460
2461 # Find the name of the 'sqldiff' executable (e.g. "sqlite3.exe") to use for
2462 # the tests in sqldiff tests. If no such executable can be found, invoke
2463 # [finish_test ; return] in the callers context.
2464 #
2465 proc test_find_sqldiff {} {
2466   set prog [test_find_binary sqldiff]
2467   if {$prog==""} { return -code return }
2468   return $prog
2469 }
2470
2471 # Call sqlite3_expanded_sql() on all statements associated with database
2472 # connection $db. This sometimes finds use-after-free bugs if run with
2473 # valgrind or address-sanitizer.
2474 proc expand_all_sql {db} {
2475   set stmt ""
2476   while {[set stmt [sqlite3_next_stmt $db $stmt]]!=""} {
2477     sqlite3_expanded_sql $stmt
2478   }
2479 }
2480
2481
2482 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
2483 # to non-zero, then set the global variable $AUTOVACUUM to 1.
2484 set AUTOVACUUM $sqlite_options(default_autovacuum)
2485
2486 # Make sure the FTS enhanced query syntax is disabled.
2487 set sqlite_fts3_enable_parentheses 0
2488
2489 # During testing, assume that all database files are well-formed.  The
2490 # few test cases that deliberately corrupt database files should rescind
2491 # this setting by invoking "database_can_be_corrupt"
2492 #
2493 database_never_corrupt
2494 extra_schema_checks 1
2495
2496 source $testdir/thread_common.tcl
2497 source $testdir/malloc_common.tcl