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