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