sl@0: # 2001 September 15
sl@0: #
sl@0: # Portions Copyright (c) 2007-2010 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0: #
sl@0: # The author disclaims copyright to this source code.  In place of
sl@0: # a legal notice, here is a blessing:
sl@0: #
sl@0: #    May you do good and not evil.
sl@0: #    May you find forgiveness for yourself and forgive others.
sl@0: #    May you share freely, never taking more than you give.
sl@0: #
sl@0: #***********************************************************************
sl@0: # This file implements some common TCL routines used for regression
sl@0: # testing the SQLite library
sl@0: #
sl@0: # $Id: tester.tcl,v 1.134 2008/08/05 17:53:24 drh Exp $
sl@0: 
sl@0: #
sl@0: # What for user input before continuing.  This gives an opportunity
sl@0: # to connect profiling tools to the process.
sl@0: #
sl@0: for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:   if {[regexp {^-+pause$} [lindex $argv $i] all value]} {
sl@0:     puts -nonewline "Press RETURN to begin..."
sl@0:     flush stdout
sl@0:     gets stdin
sl@0:     set argv [lreplace $argv $i $i]
sl@0:   }
sl@0: }
sl@0: 
sl@0: set tcl_precision 15
sl@0: set sqlite_pending_byte 0x0010000
sl@0: 
sl@0: # 
sl@0: # Check the command-line arguments for a default soft-heap-limit.
sl@0: # Store this default value in the global variable ::soft_limit and
sl@0: # update the soft-heap-limit each time this script is run.  In that
sl@0: # way if an individual test file changes the soft-heap-limit, it
sl@0: # will be reset at the start of the next test file.
sl@0: #
sl@0: if {![info exists soft_limit]} {
sl@0:   set soft_limit 0
sl@0:   for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:     if {[regexp {^--soft-heap-limit=(.+)$} [lindex $argv $i] all value]} {
sl@0:       if {$value!="off"} {
sl@0:         set soft_limit $value
sl@0:       }
sl@0:       set argv [lreplace $argv $i $i]
sl@0:     }
sl@0:   }
sl@0: }
sl@0: sqlite3_soft_heap_limit $soft_limit
sl@0: 
sl@0: # 
sl@0: # Check the command-line arguments to set the memory debugger
sl@0: # backtrace depth.
sl@0: #
sl@0: # See the sqlite3_memdebug_backtrace() function in mem2.c or
sl@0: # test_malloc.c for additional information.
sl@0: #
sl@0: for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:   if {[lindex $argv $i] eq "--malloctrace"} {
sl@0:     set argv [lreplace $argv $i $i]
sl@0:     sqlite3_memdebug_backtrace 10
sl@0:     sqlite3_memdebug_log start
sl@0:     set tester_do_malloctrace 1
sl@0:   }
sl@0: }
sl@0: for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:   if {[regexp {^--backtrace=(\d+)$} [lindex $argv $i] all value]} {
sl@0:     sqlite3_memdebug_backtrace $value
sl@0:     set argv [lreplace $argv $i $i]
sl@0:   }
sl@0: }
sl@0: 
sl@0: 
sl@0: proc ostrace_call {zCall nClick zFile i32 i64} {
sl@0:   set s "INSERT INTO ostrace VALUES('$zCall', $nClick, '$zFile', $i32, $i64);"
sl@0:   puts $::ostrace_fd $s
sl@0: }
sl@0: 
sl@0: for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:   if {[lindex $argv $i] eq "--ossummary" || [lindex $argv $i] eq "--ostrace"} {
sl@0:     sqlite3_instvfs create -default ostrace
sl@0:     set tester_do_ostrace 1
sl@0:     set ostrace_fd [open ostrace.sql w]
sl@0:     puts $ostrace_fd "BEGIN;"
sl@0:     if {[lindex $argv $i] eq "--ostrace"} {
sl@0:       set    s "CREATE TABLE ostrace"
sl@0:       append s "(method TEXT, clicks INT, file TEXT, i32 INT, i64 INT);"
sl@0:       puts $ostrace_fd $s
sl@0:       sqlite3_instvfs configure ostrace ostrace_call
sl@0:       sqlite3_instvfs configure ostrace ostrace_call
sl@0:     }
sl@0:     set argv [lreplace $argv $i $i]
sl@0:   }
sl@0:   if {[lindex $argv $i] eq "--binarylog"} {
sl@0:     set tester_do_binarylog 1
sl@0:     set argv [lreplace $argv $i $i]
sl@0:   }
sl@0: }
sl@0: 
sl@0: # 
sl@0: # Check the command-line arguments to set the maximum number of
sl@0: # errors tolerated before halting.
sl@0: #
sl@0: if {![info exists maxErr]} {
sl@0:   set maxErr 1000
sl@0: }
sl@0: for {set i 0} {$i<[llength $argv]} {incr i} {
sl@0:   if {[regexp {^--maxerror=(\d+)$} [lindex $argv $i] all maxErr]} {
sl@0:     set argv [lreplace $argv $i $i]
sl@0:   }
sl@0: }
sl@0: #puts "Max error = $maxErr"
sl@0: 
sl@0: 
sl@0: # Use the pager codec if it is available
sl@0: #
sl@0: if {[sqlite3 -has-codec] && [info command sqlite_orig]==""} {
sl@0:   rename sqlite3 sqlite_orig
sl@0:   proc sqlite3 {args} {
sl@0:     if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} {
sl@0:       lappend args -key {xyzzy}
sl@0:     }
sl@0:     uplevel 1 sqlite_orig $args
sl@0:   }
sl@0: }
sl@0: 
sl@0: 
sl@0: # Create a test database
sl@0: #
sl@0: if {![info exists nTest]} {
sl@0:   sqlite3_shutdown 
sl@0:   install_malloc_faultsim 1 
sl@0:   sqlite3_initialize
sl@0:   if {[info exists tester_do_binarylog]} {
sl@0:     sqlite3_instvfs binarylog -default binarylog ostrace.bin
sl@0:     sqlite3_instvfs marker binarylog "$argv0 $argv"
sl@0:   }
sl@0: }
sl@0: catch {db close}
sl@0: file delete -force test.db
sl@0: file delete -force test.db-journal
sl@0: sqlite3 db ./test.db
sl@0: set ::DB [sqlite3_connection_pointer db]
sl@0: if {[info exists ::SETUP_SQL]} {
sl@0:   db eval $::SETUP_SQL
sl@0: }
sl@0: 
sl@0: # Abort early if this script has been run before.
sl@0: #
sl@0: if {[info exists nTest]} return
sl@0: 
sl@0: # Symbian OS globals
sl@0: set case_failure 0
sl@0: set nCases 0
sl@0: set nFailedCases 0
sl@0: 
sl@0: # Set the test counters to zero
sl@0: #
sl@0: set nErr 0
sl@0: set nTest 0
sl@0: set skip_test 0
sl@0: set failList {}
sl@0: set omitList {}
sl@0: if {![info exists speedTest]} {
sl@0:   set speedTest 0
sl@0: }
sl@0: 
sl@0: # Record the fact that a sequence of tests were omitted.
sl@0: #
sl@0: proc omit_test {name reason} {
sl@0:   global omitList
sl@0:   lappend omitList [list $name $reason]
sl@0: }
sl@0: 
sl@0: # Symbian OS: Added procedures to output test result in TEF format
sl@0: puts "<pre>"
sl@0: 
sl@0: # Symbian OS: global procedure to handle test errors counter
sl@0: proc do_fail {name} {
sl@0:   global case_failure nErr failList
sl@0:   set case_failure 1
sl@0:   incr nErr
sl@0:   lappend ::failList $name
sl@0: }
sl@0: 
sl@0: # Symbian OS: global procedure to output START_TESTCASE in TEF format
sl@0: proc start_case {name} {
sl@0:   global case_failure nCases
sl@0:   set case_failure 0
sl@0:   incr nCases
sl@0:   puts "<font color=00AF00> START_TESTCASE $name <\/font>"
sl@0: }
sl@0: 
sl@0: # Symbian OS: global procedure to output END_TESTCASE in TEF format
sl@0: proc end_case {name} {
sl@0:   global case_failure nFailedCases
sl@0:   if {$case_failure} {
sl@0:     incr nFailedCases
sl@0:     puts "<font color=FF0000> END_TESTCASE $name ***TestCaseResult = FAIL <\/font>"
sl@0:   } else {
sl@0:     puts "<font color=00AF00> END_TESTCASE $name ***TestCaseResult = PASS <\/font>"
sl@0:   }
sl@0: }
sl@0: 
sl@0: # Symbian OS: global procedure to output test summary in TEF format
sl@0: proc tef_summary {} {
sl@0:   global nCases nFailedCases
sl@0:   set nPass [expr "$nCases - $nFailedCases"]
sl@0:   puts "<font color=00AFFF>TEST STEP SUMMARY:<\/font>"
sl@0:   puts "<font color=00AF00>PASS = $nCases<\/font>"
sl@0:   puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"
sl@0:   puts "<font color=00AFFF>TEST CASE SUMMARY:<\/font>"
sl@0:   puts "<font color=00AF00>PASS = $nCases<\/font>"
sl@0:   puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"
sl@0:   puts "<\/pre>"
sl@0:   flush stdout
sl@0: }
sl@0: 
sl@0: # Invoke the do_test procedure to run a single test 
sl@0: #
sl@0: proc do_test {name cmd expected} {
sl@0:   global argv nErr nTest skip_test maxErr
sl@0:   sqlite3_memdebug_settitle $name
sl@0:   if {[info exists ::tester_do_binarylog]} {
sl@0:     sqlite3_instvfs marker binarylog "Start of $name"
sl@0:   }
sl@0:   if {$skip_test} {
sl@0:     set skip_test 0
sl@0:     return
sl@0:   }
sl@0:   if {[llength $argv]==0} { 
sl@0:     set go 1
sl@0:   } else {
sl@0:     set go 0
sl@0:     foreach pattern $argv {
sl@0:       if {[string match $pattern $name]} {
sl@0:         set go 1
sl@0:         break
sl@0:       }
sl@0:     }
sl@0:   }
sl@0:   if {!$go} return
sl@0:   incr nTest
sl@0:   puts -nonewline $name...
sl@0:   flush stdout
sl@0:   if {[catch {uplevel #0 "$cmd;\n"} result]} {
sl@0:     puts "\nError: $result"
sl@0:     # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)
sl@0:     do_fail $name 
sl@0:     print_text $name "FAILED"  
sl@0:     if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing}
sl@0:   } elseif {[string compare $result $expected]} {
sl@0:     puts "\nExpected: \[$expected\]\n     Got: \[$result\]"
sl@0:     # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)
sl@0:     do_fail $name 
sl@0:     print_text $name "FAILED"  
sl@0:     if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing}
sl@0:   } else {
sl@0:     puts " Ok"
sl@0:     print_text $name "OK"  
sl@0:   }
sl@0:   flush stdout
sl@0:   if {[info exists ::tester_do_binarylog]} {
sl@0:     sqlite3_instvfs marker binarylog "End of $name"
sl@0:   }
sl@0: }
sl@0: 
sl@0: # Run an SQL script.  
sl@0: # Return the number of microseconds per statement.
sl@0: #
sl@0: proc speed_trial {name numstmt units sql} {
sl@0:   puts -nonewline [format {%-21.21s } $name...]
sl@0:   flush stdout
sl@0:   set speed [time {sqlite3_exec_nr db $sql}]
sl@0:   set tm [lindex $speed 0]
sl@0:   if {$tm == 0} {
sl@0:     set rate [format %20s "many"]
sl@0:   } else {
sl@0:     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
sl@0:   }
sl@0:   set u2 $units/s
sl@0:   puts [format {%12d uS %s %s} $tm $rate $u2]
sl@0:   global total_time
sl@0:   set total_time [expr {$total_time+$tm}]
sl@0: }
sl@0: proc speed_trial_tcl {name numstmt units script} {
sl@0:   puts -nonewline [format {%-21.21s } $name...]
sl@0:   flush stdout
sl@0:   set speed [time {eval $script}]
sl@0:   set tm [lindex $speed 0]
sl@0:   if {$tm == 0} {
sl@0:     set rate [format %20s "many"]
sl@0:   } else {
sl@0:     set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]
sl@0:   }
sl@0:   set u2 $units/s
sl@0:   puts [format {%12d uS %s %s} $tm $rate $u2]
sl@0:   global total_time
sl@0:   set total_time [expr {$total_time+$tm}]
sl@0: }
sl@0: proc speed_trial_init {name} {
sl@0:   global total_time
sl@0:   set total_time 0
sl@0: }
sl@0: proc speed_trial_summary {name} {
sl@0:   global total_time
sl@0:   puts [format {%-21.21s %12d uS TOTAL} $name $total_time]
sl@0: }
sl@0: 
sl@0: # Run this routine last
sl@0: #
sl@0: proc finish_test {} {
sl@0:   finalize_testing
sl@0: }
sl@0: proc finalize_testing {} {
sl@0:   global nTest nErr sqlite_open_file_count omitList
sl@0: 
sl@0:   catch {db close}
sl@0:   catch {db2 close}
sl@0:   catch {db3 close}
sl@0: 
sl@0:   vfs_unlink_test
sl@0:   sqlite3 db {}
sl@0:   # sqlite3_clear_tsd_memdebug
sl@0:   db close
sl@0:   sqlite3_reset_auto_extension
sl@0: 
sl@0:   set heaplimit [sqlite3_soft_heap_limit]
sl@0:   if {$heaplimit!=$::soft_limit} {
sl@0:     puts "soft-heap-limit changed by this script\
sl@0:           from $::soft_limit to $heaplimit"
sl@0:   } elseif {$heaplimit!="" && $heaplimit>0} {
sl@0:     puts "soft-heap-limit set to $heaplimit"
sl@0:   }
sl@0:   
sl@0:   sqlite3_soft_heap_limit 0
sl@0:   incr nTest
sl@0:   puts "$nErr errors out of $nTest tests"
sl@0:   if {$nErr>0} {
sl@0:     puts "Failures on these tests: $::failList"
sl@0:   }
sl@0:   
sl@0:   if {[llength $omitList]>0} {
sl@0:     puts "Omitted test cases:"
sl@0:     set prec {}
sl@0:     foreach {rec} [lsort $omitList] {
sl@0:       if {$rec==$prec} continue
sl@0:       set prec $rec
sl@0:       puts [format {  %-12s %s} [lindex $rec 0] [lindex $rec 1]]
sl@0:     }
sl@0:   }
sl@0:   
sl@0:   if {$nErr>0 && ![working_64bit_int]} {
sl@0:     puts "******************************************************************"
sl@0:     puts "N.B.:  The version of TCL that you used to build this test harness"
sl@0:     puts "is defective in that it does not support 64-bit integers.  Some or"
sl@0:     puts "all of the test failures above might be a result from this defect"
sl@0:     puts "in your TCL build."
sl@0:     puts "******************************************************************"
sl@0:   }
sl@0:   if {[info exists ::tester_do_binarylog]} {
sl@0:     sqlite3_instvfs destroy binarylog
sl@0:   }
sl@0: 
sl@0:   if {$sqlite_open_file_count} {
sl@0:     puts "$sqlite_open_file_count files were left open"
sl@0:     incr nErr
sl@0:   }
sl@0:   
sl@0:   if {[info exists ::tester_do_ostrace]} {
sl@0:     puts "Writing ostrace.sql..."
sl@0:     set fd $::ostrace_fd
sl@0: 
sl@0:     puts -nonewline $fd "CREATE TABLE ossummary"
sl@0:     puts $fd "(method TEXT, clicks INTEGER, count INTEGER);"
sl@0:     foreach row [sqlite3_instvfs report ostrace] {
sl@0:       foreach {method count clicks} $row break
sl@0:       puts $fd "INSERT INTO ossummary VALUES('$method', $clicks, $count);"
sl@0:     }
sl@0:     puts $fd "COMMIT;"
sl@0:     close $fd
sl@0:     sqlite3_instvfs destroy ostrace
sl@0:   }
sl@0:   
sl@0:   if {[sqlite3_memory_used]>0} {
sl@0:     puts "Unfreed memory: [sqlite3_memory_used] bytes"
sl@0:     incr nErr
sl@0:     ifcapable memdebug||mem5||(mem3&&debug) {
sl@0:       puts "Writing unfreed memory log to \"./memleak.txt\""
sl@0:       sqlite3_memdebug_dump ./memleak.txt
sl@0:     }
sl@0:   } else {
sl@0:     puts "All memory allocations freed - no leaks"
sl@0:     ifcapable memdebug||mem5 {
sl@0:       sqlite3_memdebug_dump ./memusage.txt
sl@0:     }
sl@0:   }
sl@0:   
sl@0:   show_memstats
sl@0:   puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"
sl@0:   puts "Current memory usage: [sqlite3_memory_highwater] bytes"
sl@0:   if {[info commands sqlite3_memdebug_malloc_count] ne ""} {
sl@0:     puts "Number of malloc()  : [sqlite3_memdebug_malloc_count] calls"
sl@0:   }
sl@0: 
sl@0:   if {[info exists ::tester_do_malloctrace]} {
sl@0:     puts "Writing mallocs.sql..."
sl@0:     memdebug_log_sql
sl@0:     sqlite3_memdebug_log stop
sl@0:     sqlite3_memdebug_log clear
sl@0: 
sl@0:     if {[sqlite3_memory_used]>0} {
sl@0:       puts "Writing leaks.sql..."
sl@0:       sqlite3_memdebug_log sync
sl@0:       memdebug_log_sql leaks.sql
sl@0:     }
sl@0:   }
sl@0: 
sl@0:   foreach f [glob -nocomplain test.db-*-journal] {
sl@0:     file delete -force $f
sl@0:   }
sl@0:   
sl@0:   foreach f [glob -nocomplain test.db-mj*] {
sl@0:     file delete -force $f
sl@0:   }
sl@0: 
sl@0: #Symbian OS - delete_test_files() is called to cleanup after the tests execution
sl@0:   delete_test_files
sl@0: 
sl@0: # Symbian OS: output TEF format summary
sl@0:   tef_summary
sl@0: 
sl@0:   exit [expr {$nErr>0}]
sl@0: }
sl@0: 
sl@0: # Display memory statistics for analysis and debugging purposes.
sl@0: #
sl@0: proc show_memstats {} {
sl@0:   set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]
sl@0:   set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]
sl@0:   set val [format {now %10d  max %10d  max-size %10d} \
sl@0:               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
sl@0:   puts "Memory used:          $val"
sl@0:   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]
sl@0:   set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]
sl@0:   set val [format {now %10d  max %10d  max-size %10d} \
sl@0:               [lindex $x 1] [lindex $x 2] [lindex $y 2]]
sl@0:   puts "Page-cache used:      $val"
sl@0:   set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]
sl@0:   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
sl@0:   puts "Page-cache overflow:  $val"
sl@0:   set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]
sl@0:   set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]
sl@0:   puts "Scratch memory used:  $val"
sl@0:   set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]
sl@0:   set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]
sl@0:   set val [format {now %10d  max %10d  max-size %10d} \
sl@0:                [lindex $x 1] [lindex $x 2] [lindex $y 2]]
sl@0:   puts "Scratch overflow:     $val"
sl@0:   ifcapable yytrackmaxstackdepth {
sl@0:     set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]
sl@0:     set val [format {               max %10d} [lindex $x 2]]
sl@0:     puts "Parser stack depth:    $val"
sl@0:   }
sl@0: }
sl@0: 
sl@0: # A procedure to execute SQL
sl@0: #
sl@0: proc execsql {sql {db db}} {
sl@0:   # puts "SQL = $sql"
sl@0:   uplevel [list $db eval $sql]
sl@0: }
sl@0: 
sl@0: # Execute SQL and catch exceptions.
sl@0: #
sl@0: proc catchsql {sql {db db}} {
sl@0:   # puts "SQL = $sql"
sl@0:   set r [catch {$db eval $sql} msg]
sl@0:   lappend r $msg
sl@0:   return $r
sl@0: }
sl@0: 
sl@0: # Do an VDBE code dump on the SQL given
sl@0: #
sl@0: proc explain {sql {db db}} {
sl@0:   puts ""
sl@0:   puts "addr  opcode        p1      p2      p3      p4               p5  #"
sl@0:   puts "----  ------------  ------  ------  ------  ---------------  --  -"
sl@0:   $db eval "explain $sql" {} {
sl@0:     puts [format {%-4d  %-12.12s  %-6d  %-6d  %-6d  % -17s %s  %s} \
sl@0:       $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment
sl@0:     ]
sl@0:   }
sl@0: }
sl@0: 
sl@0: # Show the VDBE program for an SQL statement but omit the Trace
sl@0: # opcode at the beginning.  This procedure can be used to prove
sl@0: # that different SQL statements generate exactly the same VDBE code.
sl@0: #
sl@0: proc explain_no_trace {sql} {
sl@0:   set tr [db eval "EXPLAIN $sql"]
sl@0:   return [lrange $tr 7 end]
sl@0: }
sl@0: 
sl@0: # Another procedure to execute SQL.  This one includes the field
sl@0: # names in the returned list.
sl@0: #
sl@0: proc execsql2 {sql} {
sl@0:   set result {}
sl@0:   db eval $sql data {
sl@0:     foreach f $data(*) {
sl@0:       lappend result $f $data($f)
sl@0:     }
sl@0:   }
sl@0:   return $result
sl@0: }
sl@0: 
sl@0: # Use the non-callback API to execute multiple SQL statements
sl@0: #
sl@0: proc stepsql {dbptr sql} {
sl@0:   set sql [string trim $sql]
sl@0:   set r 0
sl@0:   while {[string length $sql]>0} {
sl@0:     if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {
sl@0:       return [list 1 $vm]
sl@0:     }
sl@0:     set sql [string trim $sqltail]
sl@0: #    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {
sl@0: #      foreach v $VAL {lappend r $v}
sl@0: #    }
sl@0:     while {[sqlite3_step $vm]=="SQLITE_ROW"} {
sl@0:       for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {
sl@0:         lappend r [sqlite3_column_text $vm $i]
sl@0:       }
sl@0:     }
sl@0:     if {[catch {sqlite3_finalize $vm} errmsg]} {
sl@0:       return [list 1 $errmsg]
sl@0:     }
sl@0:   }
sl@0:   return $r
sl@0: }
sl@0: 
sl@0: # Delete a file or directory
sl@0: #
sl@0: proc forcedelete {filename} {
sl@0:   if {[catch {file delete -force $filename}]} {
sl@0:     exec rm -rf $filename
sl@0:   }
sl@0: }
sl@0: 
sl@0: # Do an integrity check of the entire database
sl@0: #
sl@0: proc integrity_check {name} {
sl@0:   ifcapable integrityck {
sl@0:     do_test $name {
sl@0:       execsql {PRAGMA integrity_check}
sl@0:     } {ok}
sl@0:   }
sl@0: }
sl@0: 
sl@0: proc fix_ifcapable_expr {expr} {
sl@0:   set ret ""
sl@0:   set state 0
sl@0:   for {set i 0} {$i < [string length $expr]} {incr i} {
sl@0:     set char [string range $expr $i $i]
sl@0:     set newstate [expr {[string is alnum $char] || $char eq "_"}]
sl@0:     if {$newstate && !$state} {
sl@0:       append ret {$::sqlite_options(}
sl@0:     }
sl@0:     if {!$newstate && $state} {
sl@0:       append ret )
sl@0:     }
sl@0:     append ret $char
sl@0:     set state $newstate
sl@0:   }
sl@0:   if {$state} {append ret )}
sl@0:   return $ret
sl@0: }
sl@0: 
sl@0: # Evaluate a boolean expression of capabilities.  If true, execute the
sl@0: # code.  Omit the code if false.
sl@0: #
sl@0: proc ifcapable {expr code {else ""} {elsecode ""}} {
sl@0:   #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2
sl@0:   set e2 [fix_ifcapable_expr $expr]
sl@0:   if ($e2) {
sl@0:     set c [catch {uplevel 1 $code} r]
sl@0:   } else {
sl@0:     set c [catch {uplevel 1 $elsecode} r]
sl@0:   }
sl@0:   return -code $c $r
sl@0: }
sl@0: 
sl@0: # This proc execs a seperate process that crashes midway through executing
sl@0: # the SQL script $sql on database test.db.
sl@0: #
sl@0: # The crash occurs during a sync() of file $crashfile. When the crash
sl@0: # occurs a random subset of all unsynced writes made by the process are
sl@0: # written into the files on disk. Argument $crashdelay indicates the
sl@0: # number of file syncs to wait before crashing.
sl@0: #
sl@0: # The return value is a list of two elements. The first element is a
sl@0: # boolean, indicating whether or not the process actually crashed or
sl@0: # reported some other error. The second element in the returned list is the
sl@0: # error message. This is "child process exited abnormally" if the crash
sl@0: # occured.
sl@0: #
sl@0: #   crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql
sl@0: #
sl@0: proc crashsql {args} {
sl@0:   if {$::tcl_platform(platform)!="unix"} {
sl@0:     error "crashsql should only be used on unix"
sl@0:   }
sl@0: 
sl@0:   set blocksize ""
sl@0:   set crashdelay 1
sl@0:   set prngseed 0
sl@0:   set tclbody {}
sl@0:   set crashfile ""
sl@0:   set dc ""
sl@0:   set sql [lindex $args end]
sl@0:   
sl@0:   for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {
sl@0:     set z [lindex $args $ii]
sl@0:     set n [string length $z]
sl@0:     set z2 [lindex $args [expr $ii+1]]
sl@0: 
sl@0:     if     {$n>1 && [string first $z -delay]==0}     {set crashdelay $z2} \
sl@0:     elseif {$n>1 && [string first $z -seed]==0}      {set prngseed $z2} \
sl@0:     elseif {$n>1 && [string first $z -file]==0}      {set crashfile $z2}  \
sl@0:     elseif {$n>1 && [string first $z -tclbody]==0}   {set tclbody $z2}  \
sl@0:     elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \
sl@0:     elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \
sl@0:     else   { error "Unrecognized option: $z" }
sl@0:   }
sl@0: 
sl@0:   if {$crashfile eq ""} {
sl@0:     error "Compulsory option -file missing"
sl@0:   }
sl@0: 
sl@0:   set cfile [file join [pwd] $crashfile]
sl@0: 
sl@0:   set f [open crash.tcl w]
sl@0:   puts $f "sqlite3_crash_enable 1"
sl@0:   puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"
sl@0:   puts $f "set sqlite_pending_byte $::sqlite_pending_byte"
sl@0:   puts $f "sqlite3 db test.db -vfs crash"
sl@0: 
sl@0:   # This block sets the cache size of the main database to 10
sl@0:   # pages. This is done in case the build is configured to omit
sl@0:   # "PRAGMA cache_size".
sl@0:   puts $f {db eval {SELECT * FROM sqlite_master;}}
sl@0:   puts $f {set bt [btree_from_db db]}
sl@0:   puts $f {btree_set_cache_size $bt 10}
sl@0:   if {$prngseed} {
sl@0:     set seed [expr {$prngseed%10007+1}]
sl@0:     # puts seed=$seed
sl@0:     puts $f "db eval {SELECT randomblob($seed)}"
sl@0:   }
sl@0: 
sl@0:   if {[string length $tclbody]>0} {
sl@0:     puts $f $tclbody
sl@0:   }
sl@0:   if {[string length $sql]>0} {
sl@0:     puts $f "db eval {"
sl@0:     puts $f   "$sql"
sl@0:     puts $f "}"
sl@0:   }
sl@0:   close $f
sl@0: 
sl@0:   set r [catch {
sl@0:     exec [info nameofexec] crash.tcl >@stdout
sl@0:   } msg]
sl@0:   lappend r $msg
sl@0: }
sl@0: 
sl@0: # Usage: do_ioerr_test <test number> <options...>
sl@0: #
sl@0: # This proc is used to implement test cases that check that IO errors
sl@0: # are correctly handled. The first argument, <test number>, is an integer 
sl@0: # used to name the tests executed by this proc. Options are as follows:
sl@0: #
sl@0: #     -tclprep          TCL script to run to prepare test.
sl@0: #     -sqlprep          SQL script to run to prepare test.
sl@0: #     -tclbody          TCL script to run with IO error simulation.
sl@0: #     -sqlbody          TCL script to run with IO error simulation.
sl@0: #     -exclude          List of 'N' values not to test.
sl@0: #     -erc              Use extended result codes
sl@0: #     -persist          Make simulated I/O errors persistent
sl@0: #     -start            Value of 'N' to begin with (default 1)
sl@0: #
sl@0: #     -cksum            Boolean. If true, test that the database does
sl@0: #                       not change during the execution of the test case.
sl@0: #
sl@0: proc do_ioerr_test {testname args} {
sl@0: 
sl@0:   set ::ioerropts(-start) 1
sl@0:   set ::ioerropts(-cksum) 0
sl@0:   set ::ioerropts(-erc) 0
sl@0:   set ::ioerropts(-count) 100000000
sl@0:   set ::ioerropts(-persist) 1
sl@0:   set ::ioerropts(-ckrefcount) 0
sl@0:   set ::ioerropts(-restoreprng) 1
sl@0:   array set ::ioerropts $args
sl@0: 
sl@0:   # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are
sl@0:   # a couple of obscure IO errors that do not return them.
sl@0:   set ::ioerropts(-erc) 0
sl@0: 
sl@0:   set ::go 1
sl@0:   #reset_prng_state
sl@0:   save_prng_state
sl@0:   for {set n $::ioerropts(-start)} {$::go && $n<200} {incr n} {
sl@0:     set ::TN $n
sl@0:     incr ::ioerropts(-count) -1
sl@0:     if {$::ioerropts(-count)<0} break
sl@0:  
sl@0:     # Skip this IO error if it was specified with the "-exclude" option.
sl@0:     if {[info exists ::ioerropts(-exclude)]} {
sl@0:       if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue
sl@0:     }
sl@0:     if {$::ioerropts(-restoreprng)} {
sl@0:       restore_prng_state
sl@0:     }
sl@0: 
sl@0:     # Delete the files test.db and test2.db, then execute the TCL and 
sl@0:     # SQL (in that order) to prepare for the test case.
sl@0:     do_test $testname.$n.1 {
sl@0:       set ::sqlite_io_error_pending 0
sl@0:       catch {db close}
sl@0:       catch {file delete -force test.db}
sl@0:       catch {file delete -force test.db-journal}
sl@0:       catch {file delete -force test2.db}
sl@0:       catch {file delete -force test2.db-journal}
sl@0:       set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
sl@0:       sqlite3_extended_result_codes $::DB $::ioerropts(-erc)
sl@0:       if {[info exists ::ioerropts(-tclprep)]} {
sl@0:         eval $::ioerropts(-tclprep)
sl@0:       }
sl@0:       if {[info exists ::ioerropts(-sqlprep)]} {
sl@0:         execsql $::ioerropts(-sqlprep)
sl@0:       }
sl@0:       expr 0
sl@0:     } {0}
sl@0: 
sl@0:     # Read the 'checksum' of the database.
sl@0:     if {$::ioerropts(-cksum)} {
sl@0:       set checksum [cksum]
sl@0:     }
sl@0: 
sl@0:     # Set the Nth IO error to fail.
sl@0:     do_test $testname.$n.2 [subst {
sl@0:       set ::sqlite_io_error_persist $::ioerropts(-persist)
sl@0:       set ::sqlite_io_error_pending $n
sl@0:     }] $n
sl@0:   
sl@0:     # Create a single TCL script from the TCL and SQL specified
sl@0:     # as the body of the test.
sl@0:     set ::ioerrorbody {}
sl@0:     if {[info exists ::ioerropts(-tclbody)]} {
sl@0:       append ::ioerrorbody "$::ioerropts(-tclbody)\n"
sl@0:     }
sl@0:     if {[info exists ::ioerropts(-sqlbody)]} {
sl@0:       append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"
sl@0:     }
sl@0: 
sl@0:     # Execute the TCL Script created in the above block. If
sl@0:     # there are at least N IO operations performed by SQLite as
sl@0:     # a result of the script, the Nth will fail.
sl@0:     do_test $testname.$n.3 {
sl@0:       set ::sqlite_io_error_hit 0
sl@0:       set ::sqlite_io_error_hardhit 0
sl@0:       set r [catch $::ioerrorbody msg]
sl@0:       set ::errseen $r
sl@0:       set rc [sqlite3_errcode $::DB]
sl@0:       if {$::ioerropts(-erc)} {
sl@0:         # If we are in extended result code mode, make sure all of the
sl@0:         # IOERRs we get back really do have their extended code values.
sl@0:         # If an extended result code is returned, the sqlite3_errcode
sl@0:         # TCLcommand will return a string of the form:  SQLITE_IOERR+nnnn
sl@0:         # where nnnn is a number
sl@0:         if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {
sl@0:           return $rc
sl@0:         }
sl@0:       } else {
sl@0:         # If we are not in extended result code mode, make sure no
sl@0:         # extended error codes are returned.
sl@0:         if {[regexp {\+\d} $rc]} {
sl@0:           return $rc
sl@0:         }
sl@0:       }
sl@0:       # The test repeats as long as $::go is non-zero.  $::go starts out
sl@0:       # as 1.  When a test runs to completion without hitting an I/O
sl@0:       # error, that means there is no point in continuing with this test
sl@0:       # case so set $::go to zero.
sl@0:       #
sl@0:       if {$::sqlite_io_error_pending>0} {
sl@0:         set ::go 0
sl@0:         set q 0
sl@0:         set ::sqlite_io_error_pending 0
sl@0:       } else {
sl@0:         set q 1
sl@0:       }
sl@0: 
sl@0:       set s [expr $::sqlite_io_error_hit==0]
sl@0:       if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {
sl@0:         set r 1
sl@0:       }
sl@0:       set ::sqlite_io_error_hit 0
sl@0: 
sl@0:       # One of two things must have happened. either
sl@0:       #   1.  We never hit the IO error and the SQL returned OK
sl@0:       #   2.  An IO error was hit and the SQL failed
sl@0:       #
sl@0:       expr { ($s && !$r && !$q) || (!$s && $r && $q) }
sl@0:     } {1}
sl@0: 
sl@0:     set ::sqlite_io_error_hit 0
sl@0:     set ::sqlite_io_error_pending 0
sl@0: 
sl@0:     # Check that no page references were leaked. There should be 
sl@0:     # a single reference if there is still an active transaction, 
sl@0:     # or zero otherwise.
sl@0:     #
sl@0:     # UPDATE: If the IO error occurs after a 'BEGIN' but before any
sl@0:     # locks are established on database files (i.e. if the error 
sl@0:     # occurs while attempting to detect a hot-journal file), then
sl@0:     # there may 0 page references and an active transaction according
sl@0:     # to [sqlite3_get_autocommit].
sl@0:     #
sl@0:     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {
sl@0:       do_test $testname.$n.4 {
sl@0:         set bt [btree_from_db db]
sl@0:         db_enter db
sl@0:         array set stats [btree_pager_stats $bt]
sl@0:         db_leave db
sl@0:         set nRef $stats(ref)
sl@0:         expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}
sl@0:       } {1}
sl@0:     }
sl@0: 
sl@0:     # If there is an open database handle and no open transaction, 
sl@0:     # and the pager is not running in exclusive-locking mode,
sl@0:     # check that the pager is in "unlocked" state. Theoretically,
sl@0:     # if a call to xUnlock() failed due to an IO error the underlying
sl@0:     # file may still be locked.
sl@0:     #
sl@0:     ifcapable pragma {
sl@0:       if { [info commands db] ne ""
sl@0:         && $::ioerropts(-ckrefcount)
sl@0:         && [db one {pragma locking_mode}] eq "normal"
sl@0:         && [sqlite3_get_autocommit db]
sl@0:       } {
sl@0:         do_test $testname.$n.5 {
sl@0:           set bt [btree_from_db db]
sl@0:           db_enter db
sl@0:           array set stats [btree_pager_stats $bt]
sl@0:           db_leave db
sl@0:           set stats(state)
sl@0:         } 0
sl@0:       }
sl@0:     }
sl@0: 
sl@0:     # If an IO error occured, then the checksum of the database should
sl@0:     # be the same as before the script that caused the IO error was run.
sl@0:     #
sl@0:     if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {
sl@0:       do_test $testname.$n.6 {
sl@0:         catch {db close}
sl@0:         catch {db2 close}
sl@0:         set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]
sl@0:         cksum
sl@0:       } $checksum
sl@0:     }
sl@0: 
sl@0:     set ::sqlite_io_error_hardhit 0
sl@0:     set ::sqlite_io_error_pending 0
sl@0:     if {[info exists ::ioerropts(-cleanup)]} {
sl@0:       catch $::ioerropts(-cleanup)
sl@0:     }
sl@0:   }
sl@0:   set ::sqlite_io_error_pending 0
sl@0:   set ::sqlite_io_error_persist 0
sl@0:   unset ::ioerropts
sl@0: }
sl@0: 
sl@0: # Return a checksum based on the contents of the main database associated
sl@0: # with connection $db
sl@0: #
sl@0: proc cksum {{db db}} {
sl@0:   set txt [$db eval {
sl@0:       SELECT name, type, sql FROM sqlite_master order by name
sl@0:   }]\n
sl@0:   foreach tbl [$db eval {
sl@0:       SELECT name FROM sqlite_master WHERE type='table' order by name
sl@0:   }] {
sl@0:     append txt [$db eval "SELECT * FROM $tbl"]\n
sl@0:   }
sl@0:   foreach prag {default_synchronous default_cache_size} {
sl@0:     append txt $prag-[$db eval "PRAGMA $prag"]\n
sl@0:   }
sl@0:   set cksum [string length $txt]-[md5 $txt]
sl@0:   # puts $cksum-[file size test.db]
sl@0:   return $cksum
sl@0: }
sl@0: 
sl@0: # Generate a checksum based on the contents of the main and temp tables
sl@0: # database $db. If the checksum of two databases is the same, and the
sl@0: # integrity-check passes for both, the two databases are identical.
sl@0: #
sl@0: proc allcksum {{db db}} {
sl@0:   set ret [list]
sl@0:   ifcapable tempdb {
sl@0:     set sql {
sl@0:       SELECT name FROM sqlite_master WHERE type = 'table' UNION
sl@0:       SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION
sl@0:       SELECT 'sqlite_master' UNION
sl@0:       SELECT 'sqlite_temp_master' ORDER BY 1
sl@0:     }
sl@0:   } else {
sl@0:     set sql {
sl@0:       SELECT name FROM sqlite_master WHERE type = 'table' UNION
sl@0:       SELECT 'sqlite_master' ORDER BY 1
sl@0:     }
sl@0:   }
sl@0:   set tbllist [$db eval $sql]
sl@0:   set txt {}
sl@0:   foreach tbl $tbllist {
sl@0:     append txt [$db eval "SELECT * FROM $tbl"]
sl@0:   }
sl@0:   foreach prag {default_cache_size} {
sl@0:     append txt $prag-[$db eval "PRAGMA $prag"]\n
sl@0:   }
sl@0:   # puts txt=$txt
sl@0:   return [md5 $txt]
sl@0: }
sl@0: 
sl@0: proc memdebug_log_sql {{filename mallocs.sql}} {
sl@0: 
sl@0:   set data [sqlite3_memdebug_log dump]
sl@0:   set nFrame [expr [llength [lindex $data 0]]-2]
sl@0:   if {$nFrame < 0} { return "" }
sl@0: 
sl@0:   set database temp
sl@0: 
sl@0:   set tbl "CREATE TABLE ${database}.malloc(nCall, nByte"
sl@0:   for {set ii 1} {$ii <= $nFrame} {incr ii} {
sl@0:     append tbl ", f${ii}"
sl@0:   }
sl@0:   append tbl ");\n"
sl@0: 
sl@0:   set sql ""
sl@0:   foreach e $data {
sl@0:     append sql "INSERT INTO ${database}.malloc VALUES([join $e ,]);\n"
sl@0:     foreach f [lrange $e 2 end] {
sl@0:       set frames($f) 1
sl@0:     }
sl@0:   }
sl@0: 
sl@0:   set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"
sl@0:   set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"
sl@0: 
sl@0:   foreach f [array names frames] {
sl@0:     set addr [format %x $f]
sl@0:     set cmd "addr2line -e [info nameofexec] $addr"
sl@0:     set line [eval exec $cmd]
sl@0:     append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
sl@0: 
sl@0:     set file [lindex [split $line :] 0]
sl@0:     set files($file) 1
sl@0:   }
sl@0: 
sl@0:   foreach f [array names files] {
sl@0:     set contents ""
sl@0:     catch {
sl@0:       set fd [open $f]
sl@0:       set contents [read $fd]
sl@0:       close $fd
sl@0:     }
sl@0:     set contents [string map {' ''} $contents]
sl@0:     append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"
sl@0:   }
sl@0: 
sl@0:   set fd [open $filename w]
sl@0:   puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"
sl@0:   close $fd
sl@0: }
sl@0: 
sl@0: # Copy file $from into $to. This is used because some versions of
sl@0: # TCL for windows (notably the 8.4.1 binary package shipped with the
sl@0: # current mingw release) have a broken "file copy" command.
sl@0: #
sl@0: proc copy_file {from to} {
sl@0:   if {$::tcl_platform(platform)=="unix"} {
sl@0:     file copy -force $from $to
sl@0:   } else {
sl@0:     set f [open $from]
sl@0:     fconfigure $f -translation binary
sl@0:     set t [open $to w]
sl@0:     fconfigure $t -translation binary
sl@0:     puts -nonewline $t [read $f [file size $from]]
sl@0:     close $t
sl@0:     close $f
sl@0:   }
sl@0: }
sl@0: 
sl@0: # If the library is compiled with the SQLITE_DEFAULT_AUTOVACUUM macro set
sl@0: # to non-zero, then set the global variable $AUTOVACUUM to 1.
sl@0: set AUTOVACUUM $sqlite_options(default_autovacuum)