# 2001 September 15

#

# Portions Copyright (c) 2007-2010 Nokia Corporation and/or its subsidiaries. All rights reserved.

#

# 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.134 2008/08/05 17:53:24 drh Exp $

#

# What for user input before continuing.  This gives an opportunity

# to connect profiling tools to the process.

#

for {set i 0} {$i<[llength $argv]} {incr i} {

  if {[regexp {^-+pause$} [lindex $argv $i] all value]} {

    puts -nonewline "Press RETURN to begin..."

    flush stdout

    gets stdin

    set argv [lreplace $argv $i $i]

  }

}

set tcl_precision 15

set sqlite_pending_byte 0x0010000

# 

# Check the command-line arguments for a default soft-heap-limit.

# Store this default value in the global variable ::soft_limit and

# update the soft-heap-limit each time this script is run.  In that

# way if an individual test file changes the soft-heap-limit, it

# will be reset at the start of the next test file.

#

if {![info exists soft_limit]} {

  set soft_limit 0

  for {set i 0} {$i<[llength $argv]} {incr i} {

    if {[regexp {^--soft-heap-limit=(.+)$} [lindex $argv $i] all value]} {

      if {$value!="off"} {

        set soft_limit $value

      }

      set argv [lreplace $argv $i $i]

    }

  }

}

sqlite3_soft_heap_limit $soft_limit

# 

# Check the command-line arguments to set the memory debugger

# backtrace depth.

#

# See the sqlite3_memdebug_backtrace() function in mem2.c or

# test_malloc.c for additional information.

#

for {set i 0} {$i<[llength $argv]} {incr i} {

  if {[lindex $argv $i] eq "--malloctrace"} {

    set argv [lreplace $argv $i $i]

    sqlite3_memdebug_backtrace 10

    sqlite3_memdebug_log start

    set tester_do_malloctrace 1

  }

}

for {set i 0} {$i<[llength $argv]} {incr i} {

  if {[regexp {^--backtrace=(\d+)$} [lindex $argv $i] all value]} {

    sqlite3_memdebug_backtrace $value

    set argv [lreplace $argv $i $i]

  }

}

proc ostrace_call {zCall nClick zFile i32 i64} {

  set s "INSERT INTO ostrace VALUES('$zCall', $nClick, '$zFile', $i32, $i64);"

  puts $::ostrace_fd $s

}

for {set i 0} {$i<[llength $argv]} {incr i} {

  if {[lindex $argv $i] eq "--ossummary" || [lindex $argv $i] eq "--ostrace"} {

    sqlite3_instvfs create -default ostrace

    set tester_do_ostrace 1

    set ostrace_fd [open ostrace.sql w]

    puts $ostrace_fd "BEGIN;"

    if {[lindex $argv $i] eq "--ostrace"} {

      set    s "CREATE TABLE ostrace"

      append s "(method TEXT, clicks INT, file TEXT, i32 INT, i64 INT);"

      puts $ostrace_fd $s

      sqlite3_instvfs configure ostrace ostrace_call

      sqlite3_instvfs configure ostrace ostrace_call

    }

    set argv [lreplace $argv $i $i]

  }

  if {[lindex $argv $i] eq "--binarylog"} {

    set tester_do_binarylog 1

    set argv [lreplace $argv $i $i]

  }

}

# 

# Check the command-line arguments to set the maximum number of

# errors tolerated before halting.

#

if {![info exists maxErr]} {

  set maxErr 1000

}

for {set i 0} {$i<[llength $argv]} {incr i} {

  if {[regexp {^--maxerror=(\d+)$} [lindex $argv $i] all maxErr]} {

    set argv [lreplace $argv $i $i]

  }

}

#puts "Max error = $maxErr"

# Use the pager codec if it is available

#

if {[sqlite3 -has-codec] && [info command sqlite_orig]==""} {

  rename sqlite3 sqlite_orig

  proc sqlite3 {args} {

    if {[llength $args]==2 && [string index [lindex $args 0] 0]!="-"} {

      lappend args -key {xyzzy}

    }

    uplevel 1 sqlite_orig $args

  }

}

# Create a test database

#

if {![info exists nTest]} {

  sqlite3_shutdown 

  install_malloc_faultsim 1 

  sqlite3_initialize

  if {[info exists tester_do_binarylog]} {

    sqlite3_instvfs binarylog -default binarylog ostrace.bin

    sqlite3_instvfs marker binarylog "$argv0 $argv"

  }

}

catch {db close}

file delete -force test.db

file delete -force test.db-journal

sqlite3 db ./test.db

set ::DB [sqlite3_connection_pointer db]

if {[info exists ::SETUP_SQL]} {

  db eval $::SETUP_SQL

}

# Abort early if this script has been run before.

#

if {[info exists nTest]} return

# Symbian OS globals

set case_failure 0

set nCases 0

set nFailedCases 0

# Set the test counters to zero

#

set nErr 0

set nTest 0

set skip_test 0

set failList {}

set omitList {}

if {![info exists speedTest]} {

  set speedTest 0

}

# Record the fact that a sequence of tests were omitted.

#

proc omit_test {name reason} {

  global omitList

  lappend omitList [list $name $reason]

}

# Symbian OS: Added procedures to output test result in TEF format

puts "<pre>"

# Symbian OS: global procedure to handle test errors counter

proc do_fail {name} {

  global case_failure nErr failList

  set case_failure 1

  incr nErr

  lappend ::failList $name

}

# Symbian OS: global procedure to output START_TESTCASE in TEF format

proc start_case {name} {

  global case_failure nCases

  set case_failure 0

  incr nCases

  puts "<font color=00AF00> START_TESTCASE $name <\/font>"

}

# Symbian OS: global procedure to output END_TESTCASE in TEF format

proc end_case {name} {

  global case_failure nFailedCases

  if {$case_failure} {

    incr nFailedCases

    puts "<font color=FF0000> END_TESTCASE $name ***TestCaseResult = FAIL <\/font>"

  } else {

    puts "<font color=00AF00> END_TESTCASE $name ***TestCaseResult = PASS <\/font>"

  }

}

# Symbian OS: global procedure to output test summary in TEF format

proc tef_summary {} {

  global nCases nFailedCases

  set nPass [expr "$nCases - $nFailedCases"]

  puts "<font color=00AFFF>TEST STEP SUMMARY:<\/font>"

  puts "<font color=00AF00>PASS = $nCases<\/font>"

  puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"

  puts "<font color=00AFFF>TEST CASE SUMMARY:<\/font>"

  puts "<font color=00AF00>PASS = $nCases<\/font>"

  puts "<font color=FF0000>FAIL = $nFailedCases<\/font>"

  puts "<\/pre>"

  flush stdout

}

# Invoke the do_test procedure to run a single test 

#

proc do_test {name cmd expected} {

  global argv nErr nTest skip_test maxErr

  sqlite3_memdebug_settitle $name

  if {[info exists ::tester_do_binarylog]} {

    sqlite3_instvfs marker binarylog "Start of $name"

  }

  if {$skip_test} {

    set skip_test 0

    return

  }

  if {[llength $argv]==0} { 

    set go 1

  } else {

    set go 0

    foreach pattern $argv {

      if {[string match $pattern $name]} {

        set go 1

        break

      }

    }

  }

  if {!$go} return

  incr nTest

  puts -nonewline $name...

  flush stdout

  if {[catch {uplevel #0 "$cmd;\n"} result]} {

    puts "\nError: $result"

    # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)

    do_fail $name 

    print_text $name "FAILED"  

    if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing}

  } elseif {[string compare $result $expected]} {

    puts "\nExpected: \[$expected\]\n     Got: \[$result\]"

    # Symbian OS: Set and increase error count with do_fail procedure (definition in Tester.tcl)

    do_fail $name 

    print_text $name "FAILED"  

    if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing}

  } else {

    puts " Ok"

    print_text $name "OK"  

  }

  flush stdout

  if {[info exists ::tester_do_binarylog]} {

    sqlite3_instvfs marker binarylog "End of $name"

  }

}

# Run an SQL script.  

# Return the number of microseconds per statement.

#

proc speed_trial {name numstmt units sql} {

  puts -nonewline [format {%-21.21s } $name...]

  flush stdout

  set speed [time {sqlite3_exec_nr db $sql}]

  set tm [lindex $speed 0]

  if {$tm == 0} {

    set rate [format %20s "many"]

  } else {

    set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]

  }

  set u2 $units/s

  puts [format {%12d uS %s %s} $tm $rate $u2]

  global total_time

  set total_time [expr {$total_time+$tm}]

}

proc speed_trial_tcl {name numstmt units script} {

  puts -nonewline [format {%-21.21s } $name...]

  flush stdout

  set speed [time {eval $script}]

  set tm [lindex $speed 0]

  if {$tm == 0} {

    set rate [format %20s "many"]

  } else {

    set rate [format %20.5f [expr {1000000.0*$numstmt/$tm}]]

  }

  set u2 $units/s

  puts [format {%12d uS %s %s} $tm $rate $u2]

  global total_time

  set total_time [expr {$total_time+$tm}]

}

proc speed_trial_init {name} {

  global total_time

  set total_time 0

}

proc speed_trial_summary {name} {

  global total_time

  puts [format {%-21.21s %12d uS TOTAL} $name $total_time]

}

# Run this routine last

#

proc finish_test {} {

  finalize_testing

}

proc finalize_testing {} {

  global nTest nErr sqlite_open_file_count omitList

  catch {db close}

  catch {db2 close}

  catch {db3 close}

  vfs_unlink_test

  sqlite3 db {}

  # sqlite3_clear_tsd_memdebug

  db close

  sqlite3_reset_auto_extension

  set heaplimit [sqlite3_soft_heap_limit]

  if {$heaplimit!=$::soft_limit} {

    puts "soft-heap-limit changed by this script\

          from $::soft_limit to $heaplimit"

  } elseif {$heaplimit!="" && $heaplimit>0} {

    puts "soft-heap-limit set to $heaplimit"

  }

  sqlite3_soft_heap_limit 0

  incr nTest

  puts "$nErr errors out of $nTest tests"

  if {$nErr>0} {

    puts "Failures on these tests: $::failList"

  }

  if {[llength $omitList]>0} {

    puts "Omitted test cases:"

    set prec {}

    foreach {rec} [lsort $omitList] {

      if {$rec==$prec} continue

      set prec $rec

      puts [format {  %-12s %s} [lindex $rec 0] [lindex $rec 1]]

    }

  }

  if {$nErr>0 && ![working_64bit_int]} {

    puts "******************************************************************"

    puts "N.B.:  The version of TCL that you used to build this test harness"

    puts "is defective in that it does not support 64-bit integers.  Some or"

    puts "all of the test failures above might be a result from this defect"

    puts "in your TCL build."

    puts "******************************************************************"

  }

  if {[info exists ::tester_do_binarylog]} {

    sqlite3_instvfs destroy binarylog

  }

  if {$sqlite_open_file_count} {

    puts "$sqlite_open_file_count files were left open"

    incr nErr

  }

  if {[info exists ::tester_do_ostrace]} {

    puts "Writing ostrace.sql..."

    set fd $::ostrace_fd

    puts -nonewline $fd "CREATE TABLE ossummary"

    puts $fd "(method TEXT, clicks INTEGER, count INTEGER);"

    foreach row [sqlite3_instvfs report ostrace] {

      foreach {method count clicks} $row break

      puts $fd "INSERT INTO ossummary VALUES('$method', $clicks, $count);"

    }

    puts $fd "COMMIT;"

    close $fd

    sqlite3_instvfs destroy ostrace

  }

  if {[sqlite3_memory_used]>0} {

    puts "Unfreed memory: [sqlite3_memory_used] bytes"

    incr nErr

    ifcapable memdebug||mem5||(mem3&&debug) {

      puts "Writing unfreed memory log to \"./memleak.txt\""

      sqlite3_memdebug_dump ./memleak.txt

    }

  } else {

    puts "All memory allocations freed - no leaks"

    ifcapable memdebug||mem5 {

      sqlite3_memdebug_dump ./memusage.txt

    }

  }

  show_memstats

  puts "Maximum memory usage: [sqlite3_memory_highwater 1] bytes"

  puts "Current memory usage: [sqlite3_memory_highwater] bytes"

  if {[info commands sqlite3_memdebug_malloc_count] ne ""} {

    puts "Number of malloc()  : [sqlite3_memdebug_malloc_count] calls"

  }

  if {[info exists ::tester_do_malloctrace]} {

    puts "Writing mallocs.sql..."

    memdebug_log_sql

    sqlite3_memdebug_log stop

    sqlite3_memdebug_log clear

    if {[sqlite3_memory_used]>0} {

      puts "Writing leaks.sql..."

      sqlite3_memdebug_log sync

      memdebug_log_sql leaks.sql

    }

  }

  foreach f [glob -nocomplain test.db-*-journal] {

    file delete -force $f

  }

  foreach f [glob -nocomplain test.db-mj*] {

    file delete -force $f

  }

#Symbian OS - delete_test_files() is called to cleanup after the tests execution

  delete_test_files

# Symbian OS: output TEF format summary

  tef_summary

  exit [expr {$nErr>0}]

}

# Display memory statistics for analysis and debugging purposes.

#

proc show_memstats {} {

  set x [sqlite3_status SQLITE_STATUS_MEMORY_USED 0]

  set y [sqlite3_status SQLITE_STATUS_MALLOC_SIZE 0]

  set val [format {now %10d  max %10d  max-size %10d} \

              [lindex $x 1] [lindex $x 2] [lindex $y 2]]

  puts "Memory used:          $val"

  set x [sqlite3_status SQLITE_STATUS_PAGECACHE_USED 0]

  set y [sqlite3_status SQLITE_STATUS_PAGECACHE_SIZE 0]

  set val [format {now %10d  max %10d  max-size %10d} \

              [lindex $x 1] [lindex $x 2] [lindex $y 2]]

  puts "Page-cache used:      $val"

  set x [sqlite3_status SQLITE_STATUS_PAGECACHE_OVERFLOW 0]

  set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]

  puts "Page-cache overflow:  $val"

  set x [sqlite3_status SQLITE_STATUS_SCRATCH_USED 0]

  set val [format {now %10d  max %10d} [lindex $x 1] [lindex $x 2]]

  puts "Scratch memory used:  $val"

  set x [sqlite3_status SQLITE_STATUS_SCRATCH_OVERFLOW 0]

  set y [sqlite3_status SQLITE_STATUS_SCRATCH_SIZE 0]

  set val [format {now %10d  max %10d  max-size %10d} \

               [lindex $x 1] [lindex $x 2] [lindex $y 2]]

  puts "Scratch overflow:     $val"

  ifcapable yytrackmaxstackdepth {

    set x [sqlite3_status SQLITE_STATUS_PARSER_STACK 0]

    set val [format {               max %10d} [lindex $x 2]]

    puts "Parser stack depth:    $val"

  }

}

# A procedure to execute SQL

#

proc execsql {sql {db db}} {

  # puts "SQL = $sql"

  uplevel [list $db eval $sql]

}

# Execute SQL and catch exceptions.

#

proc catchsql {sql {db db}} {

  # puts "SQL = $sql"

  set r [catch {$db eval $sql} msg]

  lappend r $msg

  return $r

}

# Do an VDBE code dump on the SQL given

#

proc explain {sql {db db}} {

  puts ""

  puts "addr  opcode        p1      p2      p3      p4               p5  #"

  puts "----  ------------  ------  ------  ------  ---------------  --  -"

  $db eval "explain $sql" {} {

    puts [format {%-4d  %-12.12s  %-6d  %-6d  %-6d  % -17s %s  %s} \

      $addr $opcode $p1 $p2 $p3 $p4 $p5 $comment

    ]

  }

}

# Show the VDBE program for an SQL statement but omit the Trace

# opcode at the beginning.  This procedure can be used to prove

# that different SQL statements generate exactly the same VDBE code.

#

proc explain_no_trace {sql} {

  set tr [db eval "EXPLAIN $sql"]

  return [lrange $tr 7 end]

}

# Another procedure to execute SQL.  This one includes the field

# names in the returned list.

#

proc execsql2 {sql} {

  set result {}

  db eval $sql data {

    foreach f $data(*) {

      lappend result $f $data($f)

    }

  }

  return $result

}

# Use the non-callback API to execute multiple SQL statements

#

proc stepsql {dbptr sql} {

  set sql [string trim $sql]

  set r 0

  while {[string length $sql]>0} {

    if {[catch {sqlite3_prepare $dbptr $sql -1 sqltail} vm]} {

      return [list 1 $vm]

    }

    set sql [string trim $sqltail]

#    while {[sqlite_step $vm N VAL COL]=="SQLITE_ROW"} {

#      foreach v $VAL {lappend r $v}

#    }

    while {[sqlite3_step $vm]=="SQLITE_ROW"} {

      for {set i 0} {$i<[sqlite3_data_count $vm]} {incr i} {

        lappend r [sqlite3_column_text $vm $i]

      }

    }

    if {[catch {sqlite3_finalize $vm} errmsg]} {

      return [list 1 $errmsg]

    }

  }

  return $r

}

# Delete a file or directory

#

proc forcedelete {filename} {

  if {[catch {file delete -force $filename}]} {

    exec rm -rf $filename

  }

}

# Do an integrity check of the entire database

#

proc integrity_check {name} {

  ifcapable integrityck {

    do_test $name {

      execsql {PRAGMA integrity_check}

    } {ok}

  }

}

proc fix_ifcapable_expr {expr} {

  set ret ""

  set state 0

  for {set i 0} {$i < [string length $expr]} {incr i} {

    set char [string range $expr $i $i]

    set newstate [expr {[string is alnum $char] || $char eq "_"}]

    if {$newstate && !$state} {

      append ret {$::sqlite_options(}

    }

    if {!$newstate && $state} {

      append ret )

    }

    append ret $char

    set state $newstate

  }

  if {$state} {append ret )}

  return $ret

}

# Evaluate a boolean expression of capabilities.  If true, execute the

# code.  Omit the code if false.

#

proc ifcapable {expr code {else ""} {elsecode ""}} {

  #regsub -all {[a-z_0-9]+} $expr {$::sqlite_options(&)} e2

  set e2 [fix_ifcapable_expr $expr]

  if ($e2) {

    set c [catch {uplevel 1 $code} r]

  } else {

    set c [catch {uplevel 1 $elsecode} r]

  }

  return -code $c $r

}

# This proc execs a seperate process that crashes midway through executing

# the SQL script $sql on database test.db.

#

# The crash occurs during a sync() of file $crashfile. When the crash

# occurs a random subset of all unsynced writes made by the process are

# written into the files on disk. Argument $crashdelay indicates the

# number of file syncs to wait before crashing.

#

# The return value is a list of two elements. The first element is a

# boolean, indicating whether or not the process actually crashed or

# reported some other error. The second element in the returned list is the

# error message. This is "child process exited abnormally" if the crash

# occured.

#

#   crashsql -delay CRASHDELAY -file CRASHFILE ?-blocksize BLOCKSIZE? $sql

#

proc crashsql {args} {

  if {$::tcl_platform(platform)!="unix"} {

    error "crashsql should only be used on unix"

  }

  set blocksize ""

  set crashdelay 1

  set prngseed 0

  set tclbody {}

  set crashfile ""

  set dc ""

  set sql [lindex $args end]

  for {set ii 0} {$ii < [llength $args]-1} {incr ii 2} {

    set z [lindex $args $ii]

    set n [string length $z]

    set z2 [lindex $args [expr $ii+1]]

    if     {$n>1 && [string first $z -delay]==0}     {set crashdelay $z2} \

    elseif {$n>1 && [string first $z -seed]==0}      {set prngseed $z2} \

    elseif {$n>1 && [string first $z -file]==0}      {set crashfile $z2}  \

    elseif {$n>1 && [string first $z -tclbody]==0}   {set tclbody $z2}  \

    elseif {$n>1 && [string first $z -blocksize]==0} {set blocksize "-s $z2" } \

    elseif {$n>1 && [string first $z -characteristics]==0} {set dc "-c {$z2}" } \

    else   { error "Unrecognized option: $z" }

  }

  if {$crashfile eq ""} {

    error "Compulsory option -file missing"

  }

  set cfile [file join [pwd] $crashfile]

  set f [open crash.tcl w]

  puts $f "sqlite3_crash_enable 1"

  puts $f "sqlite3_crashparams $blocksize $dc $crashdelay $cfile"

  puts $f "set sqlite_pending_byte $::sqlite_pending_byte"

  puts $f "sqlite3 db test.db -vfs crash"

  # This block sets the cache size of the main database to 10

  # pages. This is done in case the build is configured to omit

  # "PRAGMA cache_size".

  puts $f {db eval {SELECT * FROM sqlite_master;}}

  puts $f {set bt [btree_from_db db]}

  puts $f {btree_set_cache_size $bt 10}

  if {$prngseed} {

    set seed [expr {$prngseed%10007+1}]

    # puts seed=$seed

    puts $f "db eval {SELECT randomblob($seed)}"

  }

  if {[string length $tclbody]>0} {

    puts $f $tclbody

  }

  if {[string length $sql]>0} {

    puts $f "db eval {"

    puts $f   "$sql"

    puts $f "}"

  }

  close $f

  set r [catch {

    exec [info nameofexec] crash.tcl >@stdout

  } msg]

  lappend r $msg

}

# Usage: do_ioerr_test <test number> <options...>

#

# This proc is used to implement test cases that check that IO errors

# are correctly handled. The first argument, <test number>, is an integer 

# used to name the tests executed by this proc. Options are as follows:

#

#     -tclprep          TCL script to run to prepare test.

#     -sqlprep          SQL script to run to prepare test.

#     -tclbody          TCL script to run with IO error simulation.

#     -sqlbody          TCL script to run with IO error simulation.

#     -exclude          List of 'N' values not to test.

#     -erc              Use extended result codes

#     -persist          Make simulated I/O errors persistent

#     -start            Value of 'N' to begin with (default 1)

#

#     -cksum            Boolean. If true, test that the database does

#                       not change during the execution of the test case.

#

proc do_ioerr_test {testname args} {

  set ::ioerropts(-start) 1

  set ::ioerropts(-cksum) 0

  set ::ioerropts(-erc) 0

  set ::ioerropts(-count) 100000000

  set ::ioerropts(-persist) 1

  set ::ioerropts(-ckrefcount) 0

  set ::ioerropts(-restoreprng) 1

  array set ::ioerropts $args

  # TEMPORARY: For 3.5.9, disable testing of extended result codes. There are

  # a couple of obscure IO errors that do not return them.

  set ::ioerropts(-erc) 0

  set ::go 1

  #reset_prng_state

  save_prng_state

  for {set n $::ioerropts(-start)} {$::go && $n<200} {incr n} {

    set ::TN $n

    incr ::ioerropts(-count) -1

    if {$::ioerropts(-count)<0} break

    # Skip this IO error if it was specified with the "-exclude" option.

    if {[info exists ::ioerropts(-exclude)]} {

      if {[lsearch $::ioerropts(-exclude) $n]!=-1} continue

    }

    if {$::ioerropts(-restoreprng)} {

      restore_prng_state

    }

    # Delete the files test.db and test2.db, then execute the TCL and 

    # SQL (in that order) to prepare for the test case.

    do_test $testname.$n.1 {

      set ::sqlite_io_error_pending 0

      catch {db close}

      catch {file delete -force test.db}

      catch {file delete -force test.db-journal}

      catch {file delete -force test2.db}

      catch {file delete -force test2.db-journal}

      set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]

      sqlite3_extended_result_codes $::DB $::ioerropts(-erc)

      if {[info exists ::ioerropts(-tclprep)]} {

        eval $::ioerropts(-tclprep)

      }

      if {[info exists ::ioerropts(-sqlprep)]} {

        execsql $::ioerropts(-sqlprep)

      }

      expr 0

    } {0}

    # Read the 'checksum' of the database.

    if {$::ioerropts(-cksum)} {

      set checksum [cksum]

    }

    # Set the Nth IO error to fail.

    do_test $testname.$n.2 [subst {

      set ::sqlite_io_error_persist $::ioerropts(-persist)

      set ::sqlite_io_error_pending $n

    }] $n

    # Create a single TCL script from the TCL and SQL specified

    # as the body of the test.

    set ::ioerrorbody {}

    if {[info exists ::ioerropts(-tclbody)]} {

      append ::ioerrorbody "$::ioerropts(-tclbody)\n"

    }

    if {[info exists ::ioerropts(-sqlbody)]} {

      append ::ioerrorbody "db eval {$::ioerropts(-sqlbody)}"

    }

    # Execute the TCL Script created in the above block. If

    # there are at least N IO operations performed by SQLite as

    # a result of the script, the Nth will fail.

    do_test $testname.$n.3 {

      set ::sqlite_io_error_hit 0

      set ::sqlite_io_error_hardhit 0

      set r [catch $::ioerrorbody msg]

      set ::errseen $r

      set rc [sqlite3_errcode $::DB]

      if {$::ioerropts(-erc)} {

        # If we are in extended result code mode, make sure all of the

        # IOERRs we get back really do have their extended code values.

        # If an extended result code is returned, the sqlite3_errcode

        # TCLcommand will return a string of the form:  SQLITE_IOERR+nnnn

        # where nnnn is a number

        if {[regexp {^SQLITE_IOERR} $rc] && ![regexp {IOERR\+\d} $rc]} {

          return $rc

        }

      } else {

        # If we are not in extended result code mode, make sure no

        # extended error codes are returned.

        if {[regexp {\+\d} $rc]} {

          return $rc

        }

      }

      # The test repeats as long as $::go is non-zero.  $::go starts out

      # as 1.  When a test runs to completion without hitting an I/O

      # error, that means there is no point in continuing with this test

      # case so set $::go to zero.

      #

      if {$::sqlite_io_error_pending>0} {

        set ::go 0

        set q 0

        set ::sqlite_io_error_pending 0

      } else {

        set q 1

      }

      set s [expr $::sqlite_io_error_hit==0]

      if {$::sqlite_io_error_hit>$::sqlite_io_error_hardhit && $r==0} {

        set r 1

      }

      set ::sqlite_io_error_hit 0

      # One of two things must have happened. either

      #   1.  We never hit the IO error and the SQL returned OK

      #   2.  An IO error was hit and the SQL failed

      #

      expr { ($s && !$r && !$q) || (!$s && $r && $q) }

    } {1}

    set ::sqlite_io_error_hit 0

    set ::sqlite_io_error_pending 0

    # Check that no page references were leaked. There should be 

    # a single reference if there is still an active transaction, 

    # or zero otherwise.

    #

    # UPDATE: If the IO error occurs after a 'BEGIN' but before any

    # locks are established on database files (i.e. if the error 

    # occurs while attempting to detect a hot-journal file), then

    # there may 0 page references and an active transaction according

    # to [sqlite3_get_autocommit].

    #

    if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-ckrefcount)} {

      do_test $testname.$n.4 {

        set bt [btree_from_db db]

        db_enter db

        array set stats [btree_pager_stats $bt]

        db_leave db

        set nRef $stats(ref)

        expr {$nRef == 0 || ([sqlite3_get_autocommit db]==0 && $nRef == 1)}

      } {1}

    }

    # If there is an open database handle and no open transaction, 

    # and the pager is not running in exclusive-locking mode,

    # check that the pager is in "unlocked" state. Theoretically,

    # if a call to xUnlock() failed due to an IO error the underlying

    # file may still be locked.

    #

    ifcapable pragma {

      if { [info commands db] ne ""

        && $::ioerropts(-ckrefcount)

        && [db one {pragma locking_mode}] eq "normal"

        && [sqlite3_get_autocommit db]

      } {

        do_test $testname.$n.5 {

          set bt [btree_from_db db]

          db_enter db

          array set stats [btree_pager_stats $bt]

          db_leave db

          set stats(state)

        } 0

      }

    }

    # If an IO error occured, then the checksum of the database should

    # be the same as before the script that caused the IO error was run.

    #

    if {$::go && $::sqlite_io_error_hardhit && $::ioerropts(-cksum)} {

      do_test $testname.$n.6 {

        catch {db close}

        catch {db2 close}

        set ::DB [sqlite3 db test.db; sqlite3_connection_pointer db]

        cksum

      } $checksum

    }

    set ::sqlite_io_error_hardhit 0

    set ::sqlite_io_error_pending 0

    if {[info exists ::ioerropts(-cleanup)]} {

      catch $::ioerropts(-cleanup)

    }

  }

  set ::sqlite_io_error_pending 0

  set ::sqlite_io_error_persist 0

  unset ::ioerropts

}

# Return a checksum based on the contents of the main database associated

# with connection $db

#

proc cksum {{db db}} {

  set txt [$db eval {

      SELECT name, type, sql FROM sqlite_master order by name

  }]\n

  foreach tbl [$db eval {

      SELECT name FROM sqlite_master WHERE type='table' order by name

  }] {

    append txt [$db eval "SELECT * FROM $tbl"]\n

  }

  foreach prag {default_synchronous default_cache_size} {

    append txt $prag-[$db eval "PRAGMA $prag"]\n

  }

  set cksum [string length $txt]-[md5 $txt]

  # puts $cksum-[file size test.db]

  return $cksum

}

# Generate a checksum based on the contents of the main and temp tables

# database $db. If the checksum of two databases is the same, and the

# integrity-check passes for both, the two databases are identical.

#

proc allcksum {{db db}} {

  set ret [list]

  ifcapable tempdb {

    set sql {

      SELECT name FROM sqlite_master WHERE type = 'table' UNION

      SELECT name FROM sqlite_temp_master WHERE type = 'table' UNION

      SELECT 'sqlite_master' UNION

      SELECT 'sqlite_temp_master' ORDER BY 1

    }

  } else {

    set sql {

      SELECT name FROM sqlite_master WHERE type = 'table' UNION

      SELECT 'sqlite_master' ORDER BY 1

    }

  }

  set tbllist [$db eval $sql]

  set txt {}

  foreach tbl $tbllist {

    append txt [$db eval "SELECT * FROM $tbl"]

  }

  foreach prag {default_cache_size} {

    append txt $prag-[$db eval "PRAGMA $prag"]\n

  }

  # puts txt=$txt

  return [md5 $txt]

}

proc memdebug_log_sql {{filename mallocs.sql}} {

  set data [sqlite3_memdebug_log dump]

  set nFrame [expr [llength [lindex $data 0]]-2]

  if {$nFrame < 0} { return "" }

  set database temp

  set tbl "CREATE TABLE ${database}.malloc(nCall, nByte"

  for {set ii 1} {$ii <= $nFrame} {incr ii} {

    append tbl ", f${ii}"

  }

  append tbl ");\n"

  set sql ""

  foreach e $data {

    append sql "INSERT INTO ${database}.malloc VALUES([join $e ,]);\n"

    foreach f [lrange $e 2 end] {

      set frames($f) 1

    }

  }

  set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"

  set tbl3 "CREATE TABLE ${database}.file(name PRIMARY KEY, content);\n"

  foreach f [array names frames] {

    set addr [format %x $f]

    set cmd "addr2line -e [info nameofexec] $addr"

    set line [eval exec $cmd]

    append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"

    set file [lindex [split $line :] 0]

    set files($file) 1

  }

  foreach f [array names files] {

    set contents ""

    catch {

      set fd [open $f]

      set contents [read $fd]

      close $fd

    }

    set contents [string map {' ''} $contents]

    append sql "INSERT INTO ${database}.file VALUES('$f', '$contents');\n"

  }

  set fd [open $filename w]

  puts $fd "BEGIN; ${tbl}${tbl2}${tbl3}${sql} ; COMMIT;"

  close $fd

}

# Copy file $from into $to. This is used because some versions of

# TCL for windows (notably the 8.4.1 binary package shipped with the

# current mingw release) have a broken "file copy" command.