[sql] Import SQLite 3.17.0.

third_party/sqlite/src/test/tester.tcl

 # 2001 September 15
 #
 # The author disclaims copyright to this source code.  In place of
 # a legal notice, here is a blessing:
 #
 #    May you do good and not evil.
 #    May you find forgiveness for yourself and forgive others.
 #    May you share freely, never taking more than you give.
 #
 #***********************************************************************
 # This file implements some common TCL routines used for regression
 # testing the SQLite library
 #
 # $Id: tester.tcl,v 1.143 2009/04/09 01:23:49 drh Exp $
 
 #-------------------------------------------------------------------------
 # The commands provided by the code in this file to help with creating
 # test cases are as follows:
 #
 # Commands to manipulate the db and the file-system at a high level:
 #
 #      is_relative_file
 #      test_pwd
 #      get_pwd
 #      copy_file              FROM TO
 #      delete_file            FILENAME
 #      drop_all_tables        ?DB?
+#      drop_all_indexes       ?DB?
 #      forcecopy              FROM TO
 #      forcedelete            FILENAME
 #
 # Test the capability of the SQLite version built into the interpreter to
 # determine if a specific test can be run:
 #
 #      capable                EXPR
 #      ifcapable              EXPR
 #
 # Calulate checksums based on database contents:
@@ skipping 328 matching lines @@
   }
 }
 
 # This command should be called after loading tester.tcl from within
 # all test scripts that are incompatible with encryption codecs.
 #
 proc do_not_use_codec {} {
   set ::do_not_use_codec 1
   reset_db
 }
+unset -nocomplain do_not_use_codec
+
+# Return true if the "reserved_bytes" integer on database files is non-zero.
+#
+proc nonzero_reserved_bytes {} {
+  return [sqlite3 -has-codec]
+}
+
+# Print a HELP message and exit
+#
+proc print_help_and_quit {} {
+  puts {Options:
+  --pause                  Wait for user input before continuing
+  --soft-heap-limit=N      Set the soft-heap-limit to N
+  --maxerror=N             Quit after N errors
+  --verbose=(0|1)          Control the amount of output.  Default '1'
+  --output=FILE            set --verbose=2 and output to FILE.  Implies -q
+  -q                       Shorthand for --verbose=0
+  --help                   This message
+}
+  exit 1
+}
 
 # The following block only runs the first time this file is sourced. It
 # does not run in slave interpreters (since the ::cmdlinearg array is
 # populated before the test script is run in slave interpreters).
 #
 if {[info exists cmdlinearg]==0} {
 
   # Parse any options specified in the $argv array. This script accepts the
   # following options:
   #
   #   --pause
   #   --soft-heap-limit=NN
   #   --maxerror=NN
   #   --malloctrace=N
   #   --backtrace=N
   #   --binarylog=N
   #   --soak=N
   #   --file-retries=N
   #   --file-retry-delay=N
   #   --start=[$permutation:]$testfile
   #   --match=$pattern
   #   --verbose=$val
   #   --output=$filename
+  #   -q                                      Reduce output
+  #   --testdir=$dir                          Run tests in subdirectory $dir
   #   --help
   #
   set cmdlinearg(soft-heap-limit)    0
   set cmdlinearg(maxerror)        1000
   set cmdlinearg(malloctrace)        0
   set cmdlinearg(backtrace)         10
   set cmdlinearg(binarylog)          0
   set cmdlinearg(soak)               0
   set cmdlinearg(file-retries)       0
   set cmdlinearg(file-retry-delay)   0
   set cmdlinearg(start)             ""
   set cmdlinearg(match)             ""
   set cmdlinearg(verbose)           ""
   set cmdlinearg(output)            ""
+  set cmdlinearg(testdir)           "testdir"
 
   set leftover [list]
   foreach a $argv {
     switch -regexp -- $a {
       {^-+pause$} {
         # Wait for user input before continuing. This is to give the user an
         # opportunity to connect profiling tools to the process.
         puts -nonewline "Press RETURN to begin..."
         flush stdout
         gets stdin
       }
       {^-+soft-heap-limit=.+$} {
         foreach {dummy cmdlinearg(soft-heap-limit)} [split $a =] break
       }
       {^-+maxerror=.+$} {
         foreach {dummy cmdlinearg(maxerror)} [split $a =] break
       }
       {^-+malloctrace=.+$} {
         foreach {dummy cmdlinearg(malloctrace)} [split $a =] break
         if {$cmdlinearg(malloctrace)} {
           sqlite3_memdebug_log start
         }
       }
       {^-+backtrace=.+$} {
         foreach {dummy cmdlinearg(backtrace)} [split $a =] break
-        sqlite3_memdebug_backtrace $value
+        sqlite3_memdebug_backtrace $cmdlinearg(backtrace)
       }
       {^-+binarylog=.+$} {
         foreach {dummy cmdlinearg(binarylog)} [split $a =] break
+        set cmdlinearg(binarylog) [file normalize $cmdlinearg(binarylog)]
       }
       {^-+soak=.+$} {
         foreach {dummy cmdlinearg(soak)} [split $a =] break
         set ::G(issoak) $cmdlinearg(soak)
       }
       {^-+file-retries=.+$} {
         foreach {dummy cmdlinearg(file-retries)} [split $a =] break
         set ::G(file-retries) $cmdlinearg(file-retries)
       }
       {^-+file-retry-delay=.+$} {
@@ skipping 12 matching lines @@
       }
       {^-+match=.+$} {
         foreach {dummy cmdlinearg(match)} [split $a =] break
 
         set ::G(match) $cmdlinearg(match)
         if {$::G(match) == ""} {unset ::G(match)}
       }
 
       {^-+output=.+$} {
         foreach {dummy cmdlinearg(output)} [split $a =] break
+        set cmdlinearg(output) [file normalize $cmdlinearg(output)]
         if {$cmdlinearg(verbose)==""} {
           set cmdlinearg(verbose) 2
         }
       }
       {^-+verbose=.+$} {
         foreach {dummy cmdlinearg(verbose)} [split $a =] break
         if {$cmdlinearg(verbose)=="file"} {
           set cmdlinearg(verbose) 2
         } elseif {[string is boolean -strict $cmdlinearg(verbose)]==0} {
           error "option --verbose= must be set to a boolean or to \"file\""
         }
       }
+      {^-+testdir=.*$} {
+        foreach {dummy cmdlinearg(testdir)} [split $a =] break
+      }
+      {.*help.*} {
+         print_help_and_quit
+      }
+      {^-q$} {
+        set cmdlinearg(output) test-out.txt
+        set cmdlinearg(verbose) 2
+      }
 
       default {
-        lappend leftover $a
+        if {[file tail $a]==$a} {
+          lappend leftover $a
+        } else {
+          lappend leftover [file normalize $a]
+        }
       }
     }
   }
+  set testdir [file normalize $testdir]
+  set cmdlinearg(TESTFIXTURE_HOME) [pwd]
+  set cmdlinearg(INFO_SCRIPT) [file normalize [info script]]
+  set argv0 [file normalize $argv0]
+  if {$cmdlinearg(testdir)!=""} {
+    file mkdir $cmdlinearg(testdir)
+    cd $cmdlinearg(testdir)
+  }
   set argv $leftover
 
   # Install the malloc layer used to inject OOM errors. And the 'automatic'
   # extensions. This only needs to be done once for the process.
   #
   sqlite3_shutdown
   install_malloc_faultsim 1
   sqlite3_initialize
   autoinstall_test_functions
 
@@ skipping 163 matching lines @@
     # A channel was explicitly specified.
     uplevel puts_original $args
   }
 }
 rename puts puts_original
 proc puts {args} { uplevel puts_override $args }
 
 
 # Invoke the do_test procedure to run a single test
 #
+# The $expected parameter is the expected result.  The result is the return
+# value from the last TCL command in $cmd.
+#
+# Normally, $expected must match exactly.  But if $expected is of the form
+# "/regexp/" then regular expression matching is used.  If $expected is
+# "~/regexp/" then the regular expression must NOT match.  If $expected is
+# of the form "#/value-list/" then each term in value-list must be numeric
+# and must approximately match the corresponding numeric term in $result.
+# Values must match within 10%.  Or if the $expected term is A..B then the
+# $result term must be in between A and B.
+#
 proc do_test {name cmd expected} {
   global argv cmdlinearg
 
   fix_testname name
 
   sqlite3_memdebug_settitle $name
 
 #  if {[llength $argv]==0} {
 #    set go 1
 #  } else {
@@ skipping 13 matching lines @@
   incr_ntest
   output1 -nonewline $name...
   flush stdout
 
   if {![info exists ::G(match)] || [string match $::G(match) $name]} {
     if {[catch {uplevel #0 "$cmd;\n"} result]} {
       output2_if_no_verbose -nonewline $name...
       output2 "\nError: $result"
       fail_test $name
     } else {
-      if {[regexp {^~?/.*/$} $expected]} {
+      if {[regexp {^[~#]?/.*/$} $expected]} {
         # "expected" is of the form "/PATTERN/" then the result if correct if
         # regular expression PATTERN matches the result.  "~/PATTERN/" means
         # the regular expression must not match.
         if {[string index $expected 0]=="~"} {
           set re [string range $expected 2 end-1]
           if {[string index $re 0]=="*"} {
             # If the regular expression begins with * then treat it as a glob instead
             set ok [string match $re $result]
           } else {
             set re [string map {# {[-0-9.]+}} $re]
             set ok [regexp $re $result]
           }
           set ok [expr {!$ok}]
+        } elseif {[string index $expected 0]=="#"} {
+          # Numeric range value comparison.  Each term of the $result is matched
+          # against one term of $expect.  Both $result and $expected terms must be
+          # numeric.  The values must match within 10%.  Or if $expected is of the
+          # form A..B then the $result term must be between A and B.
+          set e2 [string range $expected 2 end-1]
+          foreach i $result j $e2 {
+            if {[regexp {^(-?\d+)\.\.(-?\d)$} $j all A B]} {
+              set ok [expr {$i+0>=$A && $i+0<=$B}]
+            } else {
+              set ok [expr {$i+0>=0.9*$j && $i+0<=1.1*$j}]
+            }
+            if {!$ok} break
+          }
+          if {$ok && [llength $result]!=[llength $e2]} {set ok 0}
         } else {
           set re [string range $expected 1 end-1]
           if {[string index $re 0]=="*"} {
             # If the regular expression begins with * then treat it as a glob instead
             set ok [string match $re $result]
           } else {
             set re [string map {# {[-0-9.]+}} $re]
             set ok [regexp $re $result]
           }
         }
@@ skipping 98 matching lines @@
 
 proc fix_testname {varname} {
   upvar $varname testname
   if {[info exists ::testprefix]
    && [string is digit [string range $testname 0 0]]
   } {
     set testname "${::testprefix}-$testname"
   }
 }
 
-proc do_execsql_test {testname sql {result {}}} {
+proc normalize_list {L} {
+  set L2 [list]
+  foreach l $L {lappend L2 $l}
+  set L2
+}
+
+# Either:
+#
+#   do_execsql_test TESTNAME SQL ?RES?
+#   do_execsql_test -db DB TESTNAME SQL ?RES?
+#
+proc do_execsql_test {args} {
+  set db db
+  if {[lindex $args 0]=="-db"} {
+    set db [lindex $args 1]
+    set args [lrange $args 2 end]
+  }
+
+  if {[llength $args]==2} {
+    foreach {testname sql} $args {}
+    set result ""
+  } elseif {[llength $args]==3} {
+    foreach {testname sql result} $args {}
+  } else {
+    error [string trim {
+      wrong # args: should be "do_execsql_test ?-db DB? testname sql ?result?"
+    }]
+  }
+
   fix_testname testname
-  uplevel do_test [list $testname] [list "execsql {$sql}"] [list [list {*}$result]]
+
+  uplevel do_test                 \
+      [list $testname]            \
+      [list "execsql {$sql} $db"] \
+      [list [list {*}$result]]
 }
+
 proc do_catchsql_test {testname sql result} {
   fix_testname testname
   uplevel do_test [list $testname] [list "catchsql {$sql}"] [list $result]
 }
 proc do_timed_execsql_test {testname sql {result {}}} {
   fix_testname testname
   uplevel do_test [list $testname] [list "execsql_timed {$sql}"]\
                                    [list [list {*}$result]]
 }
 proc do_eqp_test {name sql res} {
@@ skipping 167 matching lines @@
     close $fd
     foreach x $content {set known_error($x) 1}
     foreach x [set_test_counter fail_list] {
       if {[info exists known_error($x)]} {incr nKnown}
     }
   }
   if {$nKnown>0} {
     output2 "[expr {$nErr-$nKnown}] new errors and $nKnown known errors\
          out of $nTest tests"
   } else {
-    output2 "$nErr errors out of $nTest tests"
+    set cpuinfo {}
+    if {[catch {exec hostname} hname]==0} {set cpuinfo [string trim $hname]}
+    append cpuinfo " $::tcl_platform(os)"
+    append cpuinfo " [expr {$::tcl_platform(pointerSize)*8}]-bit"
+    append cpuinfo " [string map {E -e} $::tcl_platform(byteOrder)]"
+    output2 "SQLite [sqlite3 -sourceid]"
+    output2 "$nErr errors out of $nTest tests on $cpuinfo"
   }
   if {$nErr>$nKnown} {
     output2 -nonewline "!Failures on these tests:"
     foreach x [set_test_counter fail_list] {
       if {![info exists known_error($x)]} {output2 -nonewline " $x"}
     }
     output2 ""
   }
   foreach warning [set_test_counter warn_list] {
     output2 "Warning: $warning"
@@ skipping 153 matching lines @@
     set G "\033\[32;1m"        ;# Green fg
     set B "\033\[34;1m"        ;# Red fg
     set D "\033\[39;0m"        ;# Default fg
   } else {
     set R ""
     set G ""
     set B ""
     set D ""
   }
   foreach opcode {
-      Seek SeekGe SeekGt SeekLe SeekLt NotFound Last Rewind
+      Seek SeekGE SeekGT SeekLE SeekLT NotFound Last Rewind
       NoConflict Next Prev VNext VPrev VFilter
-      SorterSort SorterNext
+      SorterSort SorterNext NextIfOpen
   } {
     set color($opcode) $B
   }
   foreach opcode {ResultRow} {
     set color($opcode) $G
   }
   foreach opcode {IdxInsert Insert Delete IdxDelete} {
     set color($opcode) $R
   }
 
   set bSeenGoto 0
   $db eval "explain $sql" {} {
     set x($addr) 0
     set op($addr) $opcode
 
     if {$opcode == "Goto" && ($bSeenGoto==0 || ($p2 > $addr+10))} {
       set linebreak($p2) 1
       set bSeenGoto 1
     }
 
+    if {$opcode=="Once"} {
+      for {set i $addr} {$i<$p2} {incr i} {
+        set star($i) $addr
+      }
+    }
+
     if {$opcode=="Next"  || $opcode=="Prev" 
      || $opcode=="VNext" || $opcode=="VPrev"
-     || $opcode=="SorterNext"
+     || $opcode=="SorterNext" || $opcode=="NextIfOpen"
     } {
       for {set i $p2} {$i<$addr} {incr i} {
         incr x($i) 2
       }
     }
 
     if {$opcode == "Goto" && $p2<$addr && $op($p2)=="Yield"} {
       for {set i [expr $p2+1]} {$i<$addr} {incr i} {
         incr x($i) 2
       }
     }
 
     if {$opcode == "Halt" && $comment == "End of coroutine"} {
       set linebreak([expr $addr+1]) 1
     }
   }
 
   $db eval "explain $sql" {} {
     if {[info exists linebreak($addr)]} {
       output2 ""
     }
     set I [string repeat " " $x($addr)]
 
+    if {[info exists star($addr)]} {
+      set ii [expr $x($star($addr))]
+      append I "  "
+      set I [string replace $I $ii $ii *]
+    }
+
     set col ""
     catch { set col $color($opcode) }
 
     output2 [format {%-4d  %s%s%-12.12s%s  %-6d  %-6d  %-6d  % -17s %s  %s} \
       $addr $I $col $opcode $D $p1 $p2 $p3 $p4 $p5 $comment
     ]
   }
   output2 "----  ------------  ------  ------  ------  ----------------  --  -"
 }
 
@@ skipping 581 matching lines @@
       WHERE type IN('table', 'view') AND name NOT LIKE 'sqliteX_%' ESCAPE 'X'
     "] {
       $db eval "DROP $type \"$t\""
     }
   }
   ifcapable trigger&&foreignkey {
     $db eval "PRAGMA foreign_keys = $pk"
   }
 }
 
+# Drop all auxiliary indexes from the main database opened by handle [db].
+#
+proc drop_all_indexes {{db db}} {
+  set L [$db eval {
+    SELECT name FROM sqlite_master WHERE type='index' AND sql LIKE 'create%'
+  }]
+  foreach idx $L { $db eval "DROP INDEX $idx" }
+}
+
+
 #-------------------------------------------------------------------------
 # If a test script is executed with global variable $::G(perm:name) set to
 # "wal", then the tests are run in WAL mode. Otherwise, they should be run
 # in rollback mode. The following Tcl procs are used to make this less
 # intrusive:
 #
 #   wal_set_journal_mode ?DB?
 #
 #     If running a WAL test, execute "PRAGMA journal_mode = wal" using
 #     connection handle DB. Otherwise, this command is a no-op.
@@ skipping 16 matching lines @@
     $db eval "PRAGMA journal_mode = WAL"
   }
 }
 proc wal_check_journal_mode {testname {db db}} {
   if { [wal_is_wal_mode] } {
     $db eval { SELECT * FROM sqlite_master }
     do_test $testname [list $db eval "PRAGMA main.journal_mode"] {wal}
   }
 }
 
+proc wal_is_capable {} {
+  ifcapable !wal { return 0 }
+  if {[permutation]=="journaltest"} { return 0 }
+  return 1
+}
+
 proc permutation {} {
   set perm ""
   catch {set perm $::G(perm:name)}
   set perm
 }
 proc presql {} {
   set presql ""
   catch {set presql $::G(perm:presql)}
   set presql
 }
 
+proc isquick {} {
+  set ret 0
+  catch {set ret $::G(isquick)}
+  set ret
+}
+
 #-------------------------------------------------------------------------
 #
 proc slave_test_script {script} {
 
   # Create the interpreter used to run the test script.
   interp create tinterp
 
   # Populate some global variables that tester.tcl expects to see.
   foreach {var value} [list              \
     ::argv0 $::argv0                     \
@@ skipping 161 matching lines @@
   catch {db3 close}
 
   sqlite3_shutdown
   eval sqlite3_config_pagecache $::old_pagecache_config
   unset ::old_pagecache_config 
   sqlite3_initialize
   autoinstall_test_functions
   sqlite3 db test.db
 }
 
+proc test_find_binary {nm} {
+  if {$::tcl_platform(platform)=="windows"} {
+    set ret "$nm.exe"
+  } else {
+    set ret $nm
+  }
+  set ret [file normalize [file join $::cmdlinearg(TESTFIXTURE_HOME) $ret]]
+  if {![file executable $ret]} {
+    finish_test
+    return ""
+  }
+  return $ret
+}
+
+# Find the name of the 'shell' executable (e.g. "sqlite3.exe") to use for
+# the tests in shell[1-5].test. If no such executable can be found, invoke
+# [finish_test ; return] in the callers context.
+#
+proc test_find_cli {} {
+  set prog [test_find_binary sqlite3]
+  if {$prog==""} { return -code return }
+  return $prog
+}
+
+# Find the name of the 'sqldiff' executable (e.g. "sqlite3.exe") to use for
+# the tests in sqldiff tests. If no such executable can be found, invoke
+# [finish_test ; return] in the callers context.
+#
+proc test_find_sqldiff {} {
+  set prog [test_find_binary sqldiff]
+  if {$prog==""} { return -code return }
+  return $prog
+}
+
+
 # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
 # to non-zero, then set the global variable $AUTOVACUUM to 1.
 set AUTOVACUUM $sqlite_options(default_autovacuum)
 
 # Make sure the FTS enhanced query syntax is disabled.
 set sqlite_fts3_enable_parentheses 0
 
 # During testing, assume that all database files are well-formed.  The
 # few test cases that deliberately corrupt database files should rescind 
 # this setting by invoking "database_can_be_corrupt"
 #
 database_never_corrupt
 
 source $testdir/thread_common.tcl
 source $testdir/malloc_common.tcl