mirrors/sqlite
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
555f8de7ef
sqlite/test/tester.tcl
aswift aebf413d9a Added support for proxy file locking style 
Added pragma support for controlling proxy file locking
Added file control access to last errno and proxy locking
Added support for TMPDIR environment variable
Extended unit tests to cover new proxy locking pragmas and file control features (CVS 5934)

FossilOrigin-Name: b9bc36d3d5e35821ef69c0881a84c0afed253c9e
2008-11-21 00:10:35 +00:00

942 lines
28 KiB
Tcl
Raw Blame History

# 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.135 2008/11/21 00:10:35 aswift 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
# 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]
}
# 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"
incr nErr
lappend ::failList $name
if {$nErr>$maxErr} {puts "*** Giving up..."; finalize_testing}
} elseif {[string compare $result $expected]} {
puts "\nExpected: \[$expected\]\n Got: \[$result\]"
incr nErr
lappend ::failList $name
if {$nErr>=$maxErr} {puts "*** Giving up..."; finalize_testing}
} else {
puts " 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
}
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 {db2 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.
#
proc copy_file {from to} {
if {$::tcl_platform(platform)=="unix"} {
file copy -force $from $to
} else {
set f [open $from]
fconfigure $f -translation binary
set t [open $to w]
fconfigure $t -translation binary
puts -nonewline $t [read $f [file size $from]]
close $t
close $f
}
}
# 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)
Reference in New Issue View Git Blame Copy Permalink