greg/libdb
1
0
Fork 0
mirror of https://github.com/berkeleydb/libdb.git synced 2024-09-29 11:36:56 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions
libdb/test/tcl/testutils.tcl

4046 lines
96 KiB
Tcl
Raw Normal View History

Release 5.2.28 on 6/10/2011
2011-09-13 17:44:24 +00:00
# See the file LICENSE for redistribution information.
#
# Copyright (c) 1996, 2011 Oracle and/or its affiliates. All rights reserved.
#
# $Id$
#
# Test system utilities
#
# Timestamp -- print time along with elapsed time since last invocation
# of timestamp.
proc timestamp {{opt ""}} {
global __timestamp_start
set now [clock seconds]
# -c accurate to the click, instead of the second.
# -r seconds since the Epoch
# -t current time in the format expected by db_recover -t.
# -w wallclock time
# else wallclock plus elapsed time.
if {[string compare $opt "-r"] == 0} {
return $now
} elseif {[string compare $opt "-t"] == 0} {
return [clock format $now -format "%y%m%d%H%M.%S"]
} elseif {[string compare $opt "-w"] == 0} {
return [clock format $now -format "%c"]
} else {
if {[string compare $opt "-c"] == 0} {
set printclicks 1
} else {
set printclicks 0
}
if {[catch {set start $__timestamp_start}] != 0} {
set __timestamp_start $now
}
set start $__timestamp_start
set elapsed [expr $now - $start]
set the_time [clock format $now -format ""]
set __timestamp_start $now
if { $printclicks == 1 } {
set pc_print [format ".%08u" [__fix_num [clock clicks]]]
} else {
set pc_print ""
}
format "%02d:%02d:%02d$pc_print (%02d:%02d:%02d)" \
[__fix_num [clock format $now -format "%H"]] \
[__fix_num [clock format $now -format "%M"]] \
[__fix_num [clock format $now -format "%S"]] \
[expr $elapsed / 3600] \
[expr ($elapsed % 3600) / 60] \
[expr ($elapsed % 3600) % 60]
}
}
proc __fix_num { num } {
set num [string trimleft $num "0"]
if {[string length $num] == 0} {
set num "0"
}
return $num
}
# Add a {key,data} pair to the specified database where
# key=filename and data=file contents.
proc put_file { db txn flags file } {
source ./include.tcl
set fid [open $file r]
fconfigure $fid -translation binary
set data [read $fid]
close $fid
set ret [eval {$db put} $txn $flags {$file $data}]
error_check_good put_file $ret 0
}
# Get a {key,data} pair from the specified database where
# key=filename and data=file contents and then write the
# data to the specified file.
proc get_file { db txn flags file outfile } {
source ./include.tcl
set fid [open $outfile w]
fconfigure $fid -translation binary
if [catch {eval {$db get} $txn $flags {$file}} data] {
puts -nonewline $fid $data
} else {
# Data looks like {{key data}}
set data [lindex [lindex $data 0] 1]
puts -nonewline $fid $data
}
close $fid
}
# Add a {key,data} pair to the specified database where
# key=file contents and data=file name.
proc put_file_as_key { db txn flags file } {
source ./include.tcl
set fid [open $file r]
fconfigure $fid -translation binary
set filecont [read $fid]
close $fid
# Use not the file contents, but the file name concatenated
# before the file contents, as a key, to ensure uniqueness.
set data $file$filecont
set ret [eval {$db put} $txn $flags {$data $file}]
error_check_good put_file $ret 0
}
# Get a {key,data} pair from the specified database where
# key=file contents and data=file name
proc get_file_as_key { db txn flags file} {
source ./include.tcl
set fid [open $file r]
fconfigure $fid -translation binary
set filecont [read $fid]
close $fid
set data $file$filecont
return [eval {$db get} $txn $flags {$data}]
}
# open file and call dump_file to dumpkeys to tempfile
proc open_and_dump_file {
dbname env outfile checkfunc dump_func beg cont args} {
global encrypt
global passwd
source ./include.tcl
set encarg ""
if { $encrypt > 0 && $env == "NULL" } {
set encarg "-encryptany $passwd"
}
set envarg ""
set txn ""
set txnenv 0
if { $env != "NULL" } {
append envarg " -env $env "
set txnenv [is_txnenv $env]
if { $txnenv == 1 } {
append envarg " -auto_commit "
set t [$env txn]
error_check_good txn [is_valid_txn $t $env] TRUE
set txn "-txn $t"
}
}
set db [eval {berkdb open} $envarg -rdonly -unknown $encarg $args $dbname]
error_check_good dbopen [is_valid_db $db] TRUE
$dump_func $db $txn $outfile $checkfunc $beg $cont
if { $txnenv == 1 } {
error_check_good txn [$t commit] 0
}
error_check_good db_close [$db close] 0
}
# open file and call dump_file to dumpkeys to tempfile
proc open_and_dump_subfile {
dbname env outfile checkfunc dump_func beg cont subdb} {
global encrypt
global passwd
source ./include.tcl
set encarg ""
if { $encrypt > 0 && $env == "NULL" } {
set encarg "-encryptany $passwd"
}
set envarg ""
set txn ""
set txnenv 0
if { $env != "NULL" } {
append envarg "-env $env"
set txnenv [is_txnenv $env]
if { $txnenv == 1 } {
append envarg " -auto_commit "
set t [$env txn]
error_check_good txn [is_valid_txn $t $env] TRUE
set txn "-txn $t"
}
}
set db [eval {berkdb open -rdonly -unknown} \
$envarg $encarg {$dbname $subdb}]
error_check_good dbopen [is_valid_db $db] TRUE
$dump_func $db $txn $outfile $checkfunc $beg $cont
if { $txnenv == 1 } {
error_check_good txn [$t commit] 0
}
error_check_good db_close [$db close] 0
}
# Sequentially read a file and call checkfunc on each key/data pair.
# Dump the keys out to the file specified by outfile.
proc dump_file { db txn outfile {checkfunc NONE} } {
source ./include.tcl
dump_file_direction $db $txn $outfile $checkfunc "-first" "-next"
}
proc dump_file_direction { db txn outfile checkfunc start continue } {
source ./include.tcl
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
error_check_good db_cursor [is_valid_cursor $c $db] TRUE
dump_file_walk $c $outfile $checkfunc $start $continue
error_check_good curs_close [$c close] 0
}
proc dump_file_walk { c outfile checkfunc start continue {flag ""} } {
set outf [open $outfile w]
for {set d [eval {$c get} $flag $start] } \
{ [llength $d] != 0 } \
{set d [eval {$c get} $flag $continue] } {
set kd [lindex $d 0]
set k [lindex $kd 0]
set d2 [lindex $kd 1]
if { $checkfunc != "NONE" } {
$checkfunc $k $d2
}
puts $outf $k
# XXX: Geoff Mainland
# puts $outf "$k $d2"
}
close $outf
}
proc dump_binkey_file { db txn outfile checkfunc } {
source ./include.tcl
dump_binkey_file_direction $db $txn $outfile $checkfunc \
"-first" "-next"
}
proc dump_bin_file { db txn outfile checkfunc } {
source ./include.tcl
dump_bin_file_direction $db $txn $outfile $checkfunc "-first" "-next"
}
# Note: the following procedure assumes that the binary-file-as-keys were
# inserted into the database by put_file_as_key, and consist of the file
# name followed by the file contents as key, to ensure uniqueness.
proc dump_binkey_file_direction { db txn outfile checkfunc begin cont } {
source ./include.tcl
set d1 $testdir/d1
set outf [open $outfile w]
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
error_check_good db_cursor [is_valid_cursor $c $db] TRUE
set inf $d1
for {set d [$c get $begin] } { [llength $d] != 0 } \
{set d [$c get $cont] } {
set kd [lindex $d 0]
set keyfile [lindex $kd 0]
set data [lindex $kd 1]
set ofid [open $d1 w]
fconfigure $ofid -translation binary
# Chop off the first few bytes--that's the file name,
# added for uniqueness in put_file_as_key, which we don't
# want in the regenerated file.
set namelen [string length $data]
set keyfile [string range $keyfile $namelen end]
puts -nonewline $ofid $keyfile
close $ofid
$checkfunc $data $d1
puts $outf $data
flush $outf
}
close $outf
error_check_good curs_close [$c close] 0
fileremove $d1
}
proc dump_bin_file_direction { db txn outfile checkfunc begin cont } {
source ./include.tcl
set d1 $testdir/d1
set outf [open $outfile w]
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
for {set d [$c get $begin] } \
{ [llength $d] != 0 } {set d [$c get $cont] } {
set k [lindex [lindex $d 0] 0]
set data [lindex [lindex $d 0] 1]
set ofid [open $d1 w]
fconfigure $ofid -translation binary
puts -nonewline $ofid $data
close $ofid
$checkfunc $k $d1
puts $outf $k
}
close $outf
error_check_good curs_close [$c close] 0
fileremove -f $d1
}
proc make_data_str { key } {
set datastr ""
for {set i 0} {$i < 10} {incr i} {
append datastr $key
}
return $datastr
}
proc error_check_bad { func result bad {txn 0}} {
if { [binary_compare $result $bad] == 0 } {
if { $txn != 0 } {
$txn abort
}
flush stdout
flush stderr
error "FAIL:[timestamp] $func returned error value $bad"
}
}
proc error_check_good { func result desired {txn 0} } {
if { [binary_compare $desired $result] != 0 } {
if { $txn != 0 } {
$txn abort
}
flush stdout
flush stderr
error "FAIL:[timestamp]\
$func: expected $desired, got $result"
}
}
proc error_check_match { note result desired } {
if { ![string match $desired $result] } {
error "FAIL:[timestamp]\
$note: expected $desired, got $result"
}
}
# Locks have the prefix of their manager.
proc is_substr { str sub } {
if { [string first $sub $str] == -1 } {
return 0
} else {
return 1
}
}
proc is_serial { str } {
global serial_tests
foreach test $serial_tests {
if { [is_substr $str $test] == 1 } {
return 1
}
}
return 0
}
proc release_list { l } {
# Now release all the locks
foreach el $l {
catch { $el put } ret
error_check_good lock_put $ret 0
}
}
proc debug { {stop 0} } {
global __debug_on
global __debug_print
global __debug_test
set __debug_on 1
set __debug_print 1
set __debug_test $stop
}
# Check if each key appears exactly [llength dlist] times in the file with
# the duplicate tags matching those that appear in dlist.
proc dup_check { db txn tmpfile dlist {extra 0}} {
source ./include.tcl
set outf [open $tmpfile w]
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
set lastkey ""
set done 0
while { $done != 1} {
foreach did $dlist {
set rec [$c get "-next"]
if { [string length $rec] == 0 } {
set done 1
break
}
set key [lindex [lindex $rec 0] 0]
set fulldata [lindex [lindex $rec 0] 1]
set id [id_of $fulldata]
set d [data_of $fulldata]
if { [string compare $key $lastkey] != 0 && \
$id != [lindex $dlist 0] } {
set e [lindex $dlist 0]
error "FAIL: \tKey \
$key, expected dup id $e, got $id"
}
error_check_good dupget.data $d $key
error_check_good dupget.id $id $did
set lastkey $key
}
#
# Some tests add an extra dup (like overflow entries)
# Check id if it exists.
if { $extra != 0} {
set okey $key
set rec [$c get "-next"]
if { [string length $rec] != 0 } {
set key [lindex [lindex $rec 0] 0]
#
# If this key has no extras, go back for
# next iteration.
if { [string compare $key $lastkey] != 0 } {
set key $okey
set rec [$c get "-prev"]
} else {
set fulldata [lindex [lindex $rec 0] 1]
set id [id_of $fulldata]
set d [data_of $fulldata]
error_check_bad dupget.data1 $d $key
error_check_good dupget.id1 $id $extra
}
}
}
if { $done != 1 } {
puts $outf $key
}
}
close $outf
error_check_good curs_close [$c close] 0
}
# Check if each key appears exactly [llength dlist] times in the file with
# the duplicate tags matching those that appear in dlist.
proc dup_file_check { db txn tmpfile dlist } {
source ./include.tcl
set outf [open $tmpfile w]
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
set lastkey ""
set done 0
while { $done != 1} {
foreach did $dlist {
set rec [$c get "-next"]
if { [string length $rec] == 0 } {
set done 1
break
}
set key [lindex [lindex $rec 0] 0]
if { [string compare $key $lastkey] != 0 } {
#
# If we changed files read in new contents.
#
set fid [open $key r]
fconfigure $fid -translation binary
set filecont [read $fid]
close $fid
}
set fulldata [lindex [lindex $rec 0] 1]
set id [id_of $fulldata]
set d [data_of $fulldata]
if { [string compare $key $lastkey] != 0 && \
$id != [lindex $dlist 0] } {
set e [lindex $dlist 0]
error "FAIL: \tKey \
$key, expected dup id $e, got $id"
}
error_check_good dupget.data $d $filecont
error_check_good dupget.id $id $did
set lastkey $key
}
if { $done != 1 } {
puts $outf $key
}
}
close $outf
error_check_good curs_close [$c close] 0
}
# Parse duplicate data entries of the form N:data. Data_of returns
# the data part; id_of returns the numerical part
proc data_of {str} {
set ndx [string first ":" $str]
if { $ndx == -1 } {
return ""
}
return [ string range $str [expr $ndx + 1] end]
}
proc id_of {str} {
set ndx [string first ":" $str]
if { $ndx == -1 } {
return ""
}
return [ string range $str 0 [expr $ndx - 1]]
}
proc nop { {args} } {
return
}
# Partial put test procedure.
# Munges a data val through three different partial puts. Stores
# the final munged string in the dvals array so that you can check
# it later (dvals should be global). We take the characters that
# are being replaced, make them capitals and then replicate them
# some number of times (n_add). We do this at the beginning of the
# data, at the middle and at the end. The parameters are:
# db, txn, key -- as per usual. Data is the original data element
# from which we are starting. n_replace is the number of characters
# that we will replace. n_add is the number of times we will add
# the replaced string back in.
proc partial_put { method db txn gflags key data n_replace n_add } {
global dvals
source ./include.tcl
# Here is the loop where we put and get each key/data pair
# We will do the initial put and then three Partial Puts
# for the beginning, middle and end of the string.
eval {$db put} $txn {$key [chop_data $method $data]}
# Beginning change
set s [string range $data 0 [ expr $n_replace - 1 ] ]
set repl [ replicate [string toupper $s] $n_add ]
# This is gross, but necessary: if this is a fixed-length
# method, and the chopped length of $repl is zero,
# it's because the original string was zero-length and our data item
# is all nulls. Set repl to something non-NULL.
if { [is_fixed_length $method] && \
[string length [chop_data $method $repl]] == 0 } {
set repl [replicate "." $n_add]
}
set newstr [chop_data $method $repl[string range $data $n_replace end]]
set ret [eval {$db put} $txn {-partial [list 0 $n_replace] \
$key [chop_data $method $repl]}]
error_check_good put $ret 0
set ret [eval {$db get} $gflags $txn {$key}]
error_check_good get $ret [list [list $key [pad_data $method $newstr]]]
# End Change
set len [string length $newstr]
set spl [expr $len - $n_replace]
# Handle case where $n_replace > $len
if { $spl < 0 } {
set spl 0
}
set s [string range $newstr [ expr $len - $n_replace ] end ]
# Handle zero-length keys
if { [string length $s] == 0 } { set s "A" }
set repl [ replicate [string toupper $s] $n_add ]
set newstr [chop_data $method \
[string range $newstr 0 [expr $spl - 1 ] ]$repl]
set ret [eval {$db put} $txn \
{-partial [list $spl $n_replace] $key [chop_data $method $repl]}]
error_check_good put $ret 0
set ret [eval {$db get} $gflags $txn {$key}]
error_check_good get $ret [list [list $key [pad_data $method $newstr]]]
# Middle Change
set len [string length $newstr]
set mid [expr $len / 2 ]
set beg [expr $mid - [expr $n_replace / 2] ]
set end [expr $beg + $n_replace - 1]
set s [string range $newstr $beg $end]
set repl [ replicate [string toupper $s] $n_add ]
set newstr [chop_data $method [string range $newstr 0 \
[expr $beg - 1 ] ]$repl[string range $newstr [expr $end + 1] end]]
set ret [eval {$db put} $txn {-partial [list $beg $n_replace] \
$key [chop_data $method $repl]}]
error_check_good put $ret 0
set ret [eval {$db get} $gflags $txn {$key}]
error_check_good get $ret [list [list $key [pad_data $method $newstr]]]
set dvals($key) [pad_data $method $newstr]
}
proc replicate { str times } {
set res $str
for { set i 1 } { $i < $times } { set i [expr $i * 2] } {
append res $res
}
return $res
}
proc repeat { str n } {
set ret ""
while { $n > 0 } {
set ret $str$ret
incr n -1
}
return $ret
}
proc isqrt { l } {
set s [expr sqrt($l)]
set ndx [expr [string first "." $s] - 1]
return [string range $s 0 $ndx]
}
# If we run watch_procs multiple times without an intervening
# testdir cleanup, it's possible that old sentinel files will confuse
# us. Make sure they're wiped out before we spawn any other processes.
proc sentinel_init { } {
source ./include.tcl
set filelist {}
set ret [catch {glob $testdir/begin.*} result]
if { $ret == 0 } {
set filelist $result
}
set ret [catch {glob $testdir/end.*} result]
if { $ret == 0 } {
set filelist [concat $filelist $result]
}
foreach f $filelist {
fileremove $f
}
}
proc watch_procs { pidlist {delay 5} {max 3600} {quiet 0} } {
source ./include.tcl
global killed_procs
set elapsed 0
set killed_procs {}
# Don't start watching the processes until a sentinel
# file has been created for each one.
foreach pid $pidlist {
while { [file exists $testdir/begin.$pid] == 0 } {
tclsleep $delay
incr elapsed $delay
# If pids haven't been created in one-fifth
# of the time allowed for the whole test,
# there's a problem. Report an error and fail.
if { $elapsed > [expr {$max / 5}] } {
puts "FAIL: begin.pid not created"
break
}
}
}
while { 1 } {
tclsleep $delay
incr elapsed $delay
# Find the list of processes with outstanding sentinel
# files (i.e. a begin.pid and no end.pid).
set beginlist {}
set endlist {}
set ret [catch {glob $testdir/begin.*} result]
if { $ret == 0 } {
set beginlist $result
}
set ret [catch {glob $testdir/end.*} result]
if { $ret == 0 } {
set endlist $result
}
set bpids {}
catch {unset epids}
foreach begfile $beginlist {
lappend bpids [string range $begfile \
[string length $testdir/begin.] end]
}
foreach endfile $endlist {
set epids([string range $endfile \
[string length $testdir/end.] end]) 1
}
# The set of processes that we still want to watch, $l,
# is the set of pids that have begun but not ended
# according to their sentinel files.
set l {}
foreach p $bpids {
if { [info exists epids($p)] == 0 } {
lappend l $p
}
}
set rlist {}
foreach i $l {
set r [ catch { exec $KILL -0 $i } res ]
if { $r == 0 } {
lappend rlist $i
}
}
if { [ llength $rlist] == 0 } {
break
} else {
puts "[timestamp] processes running: $rlist"
}
if { $elapsed > $max } {
# We have exceeded the limit; kill processes
# and report an error
foreach i $l {
tclkill $i
}
set killed_procs $l
}
}
if { $quiet == 0 } {
puts "All processes have exited."
}
#
# Once we are done, remove all old sentinel files.
#
set oldsent [glob -nocomplain $testdir/begin* $testdir/end*]
foreach f oldsent {
fileremove -f $f
}
}
# These routines are all used from within the dbscript.tcl tester.
proc db_init { dbp do_data } {
global a_keys
global l_keys
source ./include.tcl
set txn ""
set nk 0
set lastkey ""
set a_keys() BLANK
set l_keys ""
set c [$dbp cursor]
for {set d [$c get -first] } { [llength $d] != 0 } {
set d [$c get -next] } {
set k [lindex [lindex $d 0] 0]
set d2 [lindex [lindex $d 0] 1]
incr nk
if { $do_data == 1 } {
if { [info exists a_keys($k)] } {
lappend a_keys($k) $d2]
} else {
set a_keys($k) $d2
}
}
lappend l_keys $k
}
error_check_good curs_close [$c close] 0
return $nk
}
proc pick_op { min max n } {
if { $n == 0 } {
return add
}
set x [berkdb random_int 1 12]
if {$n < $min} {
if { $x <= 4 } {
return put
} elseif { $x <= 8} {
return get
} else {
return add
}
} elseif {$n > $max} {
if { $x <= 4 } {
return put
} elseif { $x <= 8 } {
return get
} else {
return del
}
} elseif { $x <= 3 } {
return del
} elseif { $x <= 6 } {
return get
} elseif { $x <= 9 } {
return put
} else {
return add
}
}
# random_data: Generate a string of random characters.
# If recno is 0 - Use average to pick a length between 1 and 2 * avg.
# If recno is non-0, generate a number between 1 and 2 ^ (avg * 2),
# that will fit into a 32-bit integer.
# If the unique flag is 1, then make sure that the string is unique
# in the array "where".
proc random_data { avg unique where {recno 0} } {
upvar #0 $where arr
global debug_on
set min 1
set max [expr $avg+$avg-1]
if { $recno } {
#
# Tcl seems to have problems with values > 30.
#
if { $max > 30 } {
set max 30
}
set maxnum [expr int(pow(2, $max))]
}
while {1} {
set len [berkdb random_int $min $max]
set s ""
if {$recno} {
set s [berkdb random_int 1 $maxnum]
} else {
for {set i 0} {$i < $len} {incr i} {
append s [int_to_char [berkdb random_int 0 25]]
}
}
if { $unique == 0 || [info exists arr($s)] == 0 } {
break
}
}
return $s
}
proc random_key { } {
global l_keys
global nkeys
set x [berkdb random_int 0 [expr $nkeys - 1]]
return [lindex $l_keys $x]
}
proc is_err { desired } {
set x [berkdb random_int 1 100]
if { $x <= $desired } {
return 1
} else {
return 0
}
}
proc pick_cursput { } {
set x [berkdb random_int 1 4]
switch $x {
1 { return "-keylast" }
2 { return "-keyfirst" }
3 { return "-before" }
4 { return "-after" }
}
}
proc random_cursor { curslist } {
global l_keys
global nkeys
set x [berkdb random_int 0 [expr [llength $curslist] - 1]]
set dbc [lindex $curslist $x]
# We want to randomly set the cursor. Pick a key.
set k [random_key]
set r [$dbc get "-set" $k]
error_check_good cursor_get:$k [is_substr Error $r] 0
# Now move forward or backward some hops to randomly
# position the cursor.
set dist [berkdb random_int -10 10]
set dir "-next"
set boundary "-first"
if { $dist < 0 } {
set dir "-prev"
set boundary "-last"
set dist [expr 0 - $dist]
}
for { set i 0 } { $i < $dist } { incr i } {
set r [ record $dbc get $dir $k ]
if { [llength $d] == 0 } {
set r [ record $dbc get $k $boundary ]
}
error_check_bad dbcget [llength $r] 0
}
return { [linsert r 0 $dbc] }
}
proc record { args } {
# Recording every operation makes tests ridiculously slow on
# NT, so we are commenting this out; for debugging purposes,
# it will undoubtedly be useful to uncomment this.
# puts $args
# flush stdout
return [eval $args]
}
proc newpair { k data } {
global l_keys
global a_keys
global nkeys
set a_keys($k) $data
lappend l_keys $k
incr nkeys
}
proc rempair { k } {
global l_keys
global a_keys
global nkeys
unset a_keys($k)
set n [lsearch $l_keys $k]
error_check_bad rempair:$k $n -1
set l_keys [lreplace $l_keys $n $n]
incr nkeys -1
}
proc changepair { k data } {
global l_keys
global a_keys
global nkeys
set a_keys($k) $data
}
proc changedup { k olddata newdata } {
global l_keys
global a_keys
global nkeys
set d $a_keys($k)
error_check_bad changedup:$k [llength $d] 0
set n [lsearch $d $olddata]
error_check_bad changedup:$k $n -1
set a_keys($k) [lreplace $a_keys($k) $n $n $newdata]
}
# Insert a dup into the a_keys array with DB_KEYFIRST.
proc adddup { k olddata newdata } {
global l_keys
global a_keys
global nkeys
set d $a_keys($k)
if { [llength $d] == 0 } {
lappend l_keys $k
incr nkeys
set a_keys($k) { $newdata }
}
set ndx 0
set d [linsert d $ndx $newdata]
set a_keys($k) $d
}
proc remdup { k data } {
global l_keys
global a_keys
global nkeys
set d [$a_keys($k)]
error_check_bad changedup:$k [llength $d] 0
set n [lsearch $d $olddata]
error_check_bad changedup:$k $n -1
set a_keys($k) [lreplace $a_keys($k) $n $n]
}
proc dump_full_file { db txn outfile checkfunc start continue } {
source ./include.tcl
set outf [open $outfile w]
# Now we will get each key from the DB and dump to outfile
set c [eval {$db cursor} $txn]
error_check_good dbcursor [is_valid_cursor $c $db] TRUE
for {set d [$c get $start] } { [string length $d] != 0 } {
set d [$c get $continue] } {
set k [lindex [lindex $d 0] 0]
set d2 [lindex [lindex $d 0] 1]
$checkfunc $k $d2
puts $outf "$k\t$d2"
}
close $outf
error_check_good curs_close [$c close] 0
}
proc int_to_char { i } {
global alphabet
return [string index $alphabet $i]
}
proc dbcheck { key data } {
global l_keys
global a_keys
global nkeys
global check_array
if { [lsearch $l_keys $key] == -1 } {
error "FAIL: Key |$key| not in list of valid keys"
}
set d $a_keys($key)
if { [info exists check_array($key) ] } {
set check $check_array($key)
} else {
set check {}
}
if { [llength $d] > 1 } {
if { [llength $check] != [llength $d] } {
# Make the check array the right length
for { set i [llength $check] } { $i < [llength $d] } \
{incr i} {
lappend check 0
}
set check_array($key) $check
}
# Find this data's index
set ndx [lsearch $d $data]
if { $ndx == -1 } {
error "FAIL: \
Data |$data| not found for key $key. Found |$d|"
}
# Set the bit in the check array
set check_array($key) [lreplace $check_array($key) $ndx $ndx 1]
} elseif { [string compare $d $data] != 0 } {
error "FAIL: \
Invalid data |$data| for key |$key|. Expected |$d|."
} else {
set check_array($key) 1
}
}
# Dump out the file and verify it
proc filecheck { file txn args} {
global check_array
global l_keys
global nkeys
global a_keys
source ./include.tcl
if { [info exists check_array] == 1 } {
unset check_array
}
eval open_and_dump_file $file NULL $file.dump dbcheck dump_full_file \
"-first" "-next" $args
# Check that everything we checked had all its data
foreach i [array names check_array] {
set count 0
foreach j $check_array($i) {
if { $j != 1 } {
puts -nonewline "Key |$i| never found datum"
puts " [lindex $a_keys($i) $count]"
}
incr count
}
}
# Check that all keys appeared in the checked array
set count 0
foreach k $l_keys {
if { [info exists check_array($k)] == 0 } {
puts "filecheck: key |$k| not found. Data: $a_keys($k)"
}
incr count
}
if { $count != $nkeys } {
puts "filecheck: Got $count keys; expected $nkeys"
}
}
proc cleanup { dir env { quiet 0 } } {
global gen_upgrade
global gen_dump
global gen_portable
global is_qnx_test
global is_je_test
global old_encrypt
global passwd
source ./include.tcl
if { $gen_upgrade == 1 || $gen_dump == 1 } {
save_upgrade_files $dir
}
if { $gen_portable == 1 } {
save_portable_files $dir
}
# check_handles
set remfiles {}
set ret [catch { glob $dir/* } result]
if { $ret == 0 } {
foreach fileorig $result {
#
# We:
# - Ignore any env-related files, which are
# those that have __db.* or log.* if we are
# running in an env.
# - Call 'dbremove' on any databases.
# Remove any remaining temp files.
#
switch -glob -- $fileorig {
*/__db.* -
*/log.* -
*/*.jdb {
if { $env != "NULL" } {
continue
} else {
if { $is_qnx_test } {
catch {berkdb envremove -force \
-home $dir} r
}
lappend remfiles $fileorig
}
}
*.db {
set envargs ""
set encarg ""
#
# If in an env, it should be open crypto
# or not already.
#
if { $env != "NULL"} {
set file [file tail $fileorig]
set envargs " -env $env "
if { [is_txnenv $env] } {
append envargs " -auto_commit "
}
} else {
if { $old_encrypt != 0 } {
set encarg "-encryptany $passwd"
}
set file $fileorig
}
# If a database is left in a corrupt
# state, dbremove might not be able to handle
# it (it does an open before the remove).
# Be prepared for this, and if necessary,
# just forcibly remove the file with a warning
# message.
set ret [catch \
{eval {berkdb dbremove} $envargs $encarg \
$file} res]
# If dbremove failed and we're not in an env,
# note that we don't have 100% certainty
# about whether the previous run used
# encryption. Try to remove with crypto if
# we tried without, and vice versa.
if { $ret != 0 } {
if { $env == "NULL" && \
$old_encrypt == 0} {
set ret [catch \
{eval {berkdb dbremove} \
-encryptany $passwd \
$file} res]
}
if { $env == "NULL" && \
$old_encrypt == 1 } {
set ret [catch \
{eval {berkdb dbremove} \
$file} res]
}
if { $ret != 0 } {
if { $quiet == 0 } {
puts \
"FAIL: dbremove in cleanup failed: $res"
}
set file $fileorig
lappend remfiles $file
}
}
}
default {
lappend remfiles $fileorig
}
}
}
if {[llength $remfiles] > 0} {
#
# In the HFS file system there are cases where not
# all files are removed on the first attempt. If
# it fails, try again a few times. HFS is found on
# Mac OS X machines only (although not all of them)
# so we can limit the extra delete attempts to that
# platform.
#
# This bug has been compensated for in Tcl with a fix
# checked into Tcl 8.4. When Berkeley DB requires
# Tcl 8.5, we can remove this while loop and replace
# it with a simple 'fileremove -f $remfiles'.
#
set count 0
if { $is_osx_test } {
while { [catch {eval fileremove -f $remfiles}] == 1 \
&& $count < 5 } {
incr count
}
}
# The final attempt to remove files can be for all
# OSes including Darwin. Don't catch failures, we'd
# like to notice them.
eval fileremove -f $remfiles
}
if { $is_je_test } {
set rval [catch {eval {exec \
$util_path/db_dump} -h $dir -l } res]
if { $rval == 0 } {
set envargs " -env $env "
if { [is_txnenv $env] } {
append envargs " -auto_commit "
}
foreach db $res {
set ret [catch {eval \
{berkdb dbremove} $envargs $db } res]
}
}
}
}
}
proc log_cleanup { dir } {
source ./include.tcl
global gen_upgrade_log
global gen_portable
if { $gen_upgrade_log == 1 } {
save_upgrade_files $dir
}
if { $gen_portable == 1 } {
save_portable_files $dir
}
set files [glob -nocomplain $dir/log.*]
if { [llength $files] != 0} {
foreach f $files {
fileremove -f $f
}
}
}
proc env_cleanup { dir } {
global old_encrypt
global passwd
source ./include.tcl
set encarg ""
if { $old_encrypt != 0 } {
set encarg "-encryptany $passwd"
}
set stat [catch {eval {berkdb envremove -home} $dir $encarg} ret]
#
# If something failed and we are left with a region entry
# in /dev/shmem that is zero-length, the envremove will
# succeed, and the shm_unlink will succeed, but it will not
# remove the zero-length entry from /dev/shmem. Remove it
# using fileremove or else all other tests using an env
# will immediately fail.
#
if { $is_qnx_test == 1 } {
set region_files [glob -nocomplain /dev/shmem/$dir*]
if { [llength $region_files] != 0 } {
foreach f $region_files {
fileremove -f $f
}
}
}
log_cleanup $dir
cleanup $dir NULL
}
proc help { cmd } {
if { [info command $cmd] == $cmd } {
set is_proc [lsearch [info procs $cmd] $cmd]
if { $is_proc == -1 } {
# Not a procedure; must be a C command
# Let's hope that it takes some parameters
# and that it prints out a message
puts "Usage: [eval $cmd]"
} else {
# It is a tcl procedure
puts -nonewline "Usage: $cmd"
set args [info args $cmd]
foreach a $args {
set is_def [info default $cmd $a val]
if { $is_def != 0 } {
# Default value
puts -nonewline " $a=$val"
} elseif {$a == "args"} {
# Print out flag values
puts " options"
args
} else {
# No default value
puts -nonewline " $a"
}
}
puts ""
}
} else {
puts "$cmd is not a command"
}
}
# Run a recovery test for a particular operation
# Notice that we catch the return from CP and do not do anything with it.
# This is because Solaris CP seems to exit non-zero on occasion, but
# everything else seems to run just fine.
#
# We split it into two functions so that the preparation and command
# could be executed in a different process than the recovery.
#
proc op_codeparse { encodedop op } {
set op1 ""
set op2 ""
switch $encodedop {
"abort" {
set op1 $encodedop
set op2 ""
}
"commit" {
set op1 $encodedop
set op2 ""
}
"prepare-abort" {
set op1 "prepare"
set op2 "abort"
}
"prepare-commit" {
set op1 "prepare"
set op2 "commit"
}
"prepare-discard" {
set op1 "prepare"
set op2 "discard"
}
}
if { $op == "op" } {
return $op1
} else {
return $op2
}
}
proc op_recover { encodedop dir env_cmd dbfile cmd msg args} {
source ./include.tcl
set op [op_codeparse $encodedop "op"]
set op2 [op_codeparse $encodedop "sub"]
puts "\t$msg $encodedop"
set gidf ""
# puts "op_recover: $op $dir $env_cmd $dbfile $cmd $args"
if { $op == "prepare" } {
sentinel_init
# Fork off a child to run the cmd
# We append the gid, so start here making sure
# we don't have old gid's around.
set outfile $testdir/childlog
fileremove -f $testdir/gidfile
set gidf $testdir/gidfile
set pidlist {}
# puts "$tclsh_path $test_path/recdscript.tcl $testdir/recdout \
# $op $dir $env_cmd $dbfile $gidf $cmd"
set p [exec $tclsh_path $test_path/wrap.tcl recdscript.tcl \
$testdir/recdout $op $dir $env_cmd $dbfile $gidf $cmd $args &]
lappend pidlist $p
watch_procs $pidlist 5
set f1 [open $testdir/recdout r]
set r [read $f1]
puts -nonewline $r
close $f1
fileremove -f $testdir/recdout
} else {
eval {op_recover_prep $op $dir $env_cmd $dbfile $gidf $cmd} $args
}
eval {op_recover_rec $op $op2 $dir $env_cmd $dbfile $gidf} $args
}
proc op_recover_prep { op dir env_cmd dbfile gidf cmd args} {
global log_log_record_types
global recd_debug
global recd_id
global recd_op
source ./include.tcl
# puts "op_recover_prep: $op $dir $env_cmd $dbfile $cmd $args"
set init_file $dir/t1
set afterop_file $dir/t2
set final_file $dir/t3
set db_cursor ""
# Keep track of the log types we've seen
if { $log_log_record_types == 1} {
logtrack_read $dir
}
# Save the initial file and open the environment and the file
catch { file copy -force $dir/$dbfile $dir/$dbfile.init } res
copy_extent_file $dir $dbfile init
convert_encrypt $env_cmd
set env [eval $env_cmd]
error_check_good envopen [is_valid_env $env] TRUE
eval set args $args
set db [eval {berkdb open -auto_commit -env $env} $args {$dbfile}]
error_check_good dbopen [is_valid_db $db] TRUE
# get the type, if heap must do additional prep work
set method [$db get_type]
if { [is_heap $method] == 1 } {
# close db so get a clean copy
error_check_good db_close [$db close] 0
# make copies of other heap files
append dbfile1 $dbfile "1"
catch { file copy -force $dir/$dbfile1 $dir/$dbfile.init1 } res
copy_extent_file $dir $dbfile1 init
append dbfile2 $dbfile "2"
catch { file copy -force $dir/$dbfile2 $dir/$dbfile.init2 } res
copy_extent_file $dir $dbfile2 init
# reopen to put us back to starting point
set db [eval {berkdb open -auto_commit -env $env} \
$args {$dbfile}]
error_check_good dbopen [is_valid_db $db] TRUE
}
# Dump out file contents for initial case
eval open_and_dump_file $dbfile $env $init_file nop \
dump_file_direction "-first" "-next" $args
set t [$env txn]
error_check_bad txn_begin $t NULL
error_check_good txn_begin [is_substr $t "txn"] 1
# Now fill in the db, tmgr, and the txnid in the command
set exec_cmd $cmd
set items [lsearch -all $cmd ENV]
foreach i $items {
set exec_cmd [lreplace $exec_cmd $i $i $env]
}
set items [lsearch -all $cmd TXNID]
foreach i $items {
set exec_cmd [lreplace $exec_cmd $i $i $t]
}
set items [lsearch -all $cmd DB]
foreach i $items {
set exec_cmd [lreplace $exec_cmd $i $i $db]
}
set i [lsearch $cmd DBC]
if { $i != -1 } {
set db_cursor [$db cursor -txn $t]
$db_cursor get -first
}
set adjust 0
set items [lsearch -all $cmd DBC]
foreach i $items {
# make sure the cursor is pointing to something.
set exec_cmd [lreplace $exec_cmd \
[expr $i + $adjust] [expr $i + $adjust] $db_cursor]
set txn_pos [lsearch $exec_cmd -txn]
if { $txn_pos != -1} {
# Strip out the txn parameter, we've applied it to the
# cursor.
set exec_cmd \
[lreplace $exec_cmd $txn_pos [expr $txn_pos + 1]]
# Now the offsets in the items list are out-of-whack,
# keep track of how far.
set adjust [expr $adjust - 2]
}
}
# To test DB_CONSUME, we need to expect a record return, not "0".
set i [lsearch $exec_cmd "-consume"]
if { $i != -1 } {
set record_exec_cmd_ret 1
} else {
set record_exec_cmd_ret 0
}
# For the DB_APPEND test, we need to expect a return other than
# 0; set this flag to be more lenient in the error_check_good.
set i [lsearch $exec_cmd "-append"]
if { $i != -1 } {
set lenient_exec_cmd_ret 1
} else {
set lenient_exec_cmd_ret 0
}
# For some partial tests we want to execute multiple commands. Pull
# pull them out here.
set last 0
set exec_cmd2 ""
set exec_cmds [list]
set items [lsearch -all $exec_cmd NEW_CMD]
foreach i $items {
if { $last == 0 } {
set exec_cmd2 [lrange $exec_cmd 0 [expr $i - 1]]
} else {
lappend exec_cmds [lrange $exec_cmd \
[expr $last + 1] [expr $i - 1]]
}
set last $i
}
if { $last != 0 } {
lappend exec_cmds [lrange $exec_cmd [expr $last + 1] end]
set exec_cmd $exec_cmd2
}
#puts "exec_cmd: $exec_cmd"
#puts "exec_cmds: $exec_cmds"
# Execute command and commit/abort it.
set ret [eval $exec_cmd]
if { $record_exec_cmd_ret == 1 } {
error_check_good "\"$exec_cmd\"" [llength [lindex $ret 0]] 2
} elseif { $lenient_exec_cmd_ret == 1 } {
error_check_good "\"$exec_cmd\"" [expr $ret > 0] 1
} else {
error_check_good "\"$exec_cmd\"" $ret 0
}
# If there are additional commands, run them.
foreach curr_cmd $exec_cmds {
error_check_good "\"$curr_cmd\"" $ret 0
}
# If a cursor was created, close it now.
if {$db_cursor != ""} {
error_check_good close:$db_cursor [$db_cursor close] 0
}
set record_exec_cmd_ret 0
set lenient_exec_cmd_ret 0
# Sync the file so that we can capture a snapshot to test recovery.
error_check_good sync:$db [$db sync] 0
catch { file copy -force $dir/$dbfile $dir/$dbfile.afterop } res
copy_extent_file $dir $dbfile afterop
# If access method is heap, copy other files
if { [is_heap $method] == 1 } {
catch { file copy -force $dir/$dbfile1 \
$dir/$dbfile.afterop1 } res
copy_extent_file $dir $dbfile1 afterop
catch { file copy -force $dir/$dbfile2 \
$dir/$dbfile.afterop2 } res
copy_extent_file $dir $dbfile2 afterop
}
eval open_and_dump_file $dir/$dbfile.afterop NULL \
$afterop_file nop dump_file_direction "-first" "-next" $args
#puts "\t\t\tExecuting txn_$op:$t"
if { $op == "prepare" } {
set gid [make_gid global:$t]
set gfd [open $gidf w+]
puts $gfd $gid
close $gfd
error_check_good txn_$op:$t [$t $op $gid] 0
} else {
error_check_good txn_$op:$t [$t $op] 0
}
switch $op {
"commit" { puts "\t\tCommand executed and committed." }
"abort" { puts "\t\tCommand executed and aborted." }
"prepare" { puts "\t\tCommand executed and prepared." }
}
# Sync the file so that we can capture a snapshot to test recovery.
error_check_good sync:$db [$db sync] 0
catch { file copy -force $dir/$dbfile $dir/$dbfile.final } res
copy_extent_file $dir $dbfile final
# If access method is heap, copy other files
if { [is_heap $method] == 1 } {
catch { file copy -force $dir/$dbfile1 \
$dir/$dbfile.final1 } res
copy_extent_file $dir $dbfile1 afterop
catch { file copy -force $dir/$dbfile2 \
$dir/$dbfile.final2 } res
copy_extent_file $dir $dbfile2 afterop
}
eval open_and_dump_file $dir/$dbfile.final NULL \
$final_file nop dump_file_direction "-first" "-next" $args
# If this is an abort or prepare-abort, it should match the
# original file.
# If this was a commit or prepare-commit, then this file should
# match the afterop file.
# If this was a prepare without an abort or commit, we still
# have transactions active, and peering at the database from
# another environment will show data from uncommitted transactions.
# Thus we just skip this in the prepare-only case; what
# we care about are the results of a prepare followed by a
# recovery, which we test later.
if { $op == "commit" } {
filesort $afterop_file $afterop_file.sort
filesort $final_file $final_file.sort
error_check_good \
diff(post-$op,pre-commit):diff($afterop_file,$final_file) \
[filecmp $afterop_file.sort $final_file.sort] 0
} elseif { $op == "abort" } {
filesort $init_file $init_file.sort
filesort $final_file $final_file.sort
error_check_good \
diff(initial,post-$op):diff($init_file,$final_file) \
[filecmp $init_file.sort $final_file.sort] 0
} else {
# Make sure this really is one of the prepare tests
error_check_good assert:prepare-test $op "prepare"
}
# Running recovery on this database should not do anything.
# Flush all data to disk, close the environment and save the
# file.
# XXX DO NOT CLOSE FILE ON PREPARE -- if you are prepared,
# you really have an active transaction and you're not allowed
# to close files that are being acted upon by in-process
# transactions.
if { $op != "prepare" } {
error_check_good close:$db [$db close] 0
}
#
# If we are running 'prepare' don't close the env with an
# active transaction. Leave it alone so the close won't
# quietly abort it on us.
if { [is_substr $op "prepare"] != 1 } {
error_check_good log_flush [$env log_flush] 0
error_check_good envclose [$env close] 0
}
return
}
proc op_recover_rec { op op2 dir env_cmd dbfile gidf args} {
global log_log_record_types
global recd_debug
global recd_id
global recd_op
global encrypt
global passwd
source ./include.tcl
#puts "op_recover_rec: $op $op2 $dir $env_cmd $dbfile $gidf"
set init_file $dir/t1
set afterop_file $dir/t2
set final_file $dir/t3
# Keep track of the log types we've seen
if { $log_log_record_types == 1} {
logtrack_read $dir
}
berkdb debug_check
puts -nonewline "\t\top_recover_rec: Running recovery ... "
flush stdout
set recargs "-h $dir -c "
if { $encrypt > 0 } {
append recargs " -P $passwd "
}
set stat [catch {eval exec $util_path/db_recover -e $recargs} result]
if { $stat == 1 } {
error "FAIL: Recovery error: $result."
}
puts -nonewline "complete ... "
#
# We cannot run db_recover here because that will open an env, run
# recovery, then close it, which will abort the outstanding txns.
# We want to do it ourselves.
#
set env [eval $env_cmd]
error_check_good dbenv [is_valid_widget $env env] TRUE
if {[is_partition_callback $args] == 1 } {
set nodump 1
} else {
set nodump 0
}
error_check_good db_verify [verify_dir $testdir "\t\t" 0 1 $nodump] 0
puts "verified"
# If we left a txn as prepared, but not aborted or committed,
# we need to do a txn_recover. Make sure we have the same
# number of txns we want.
if { $op == "prepare"} {
set txns [$env txn_recover]
error_check_bad txnrecover [llength $txns] 0
set gfd [open $gidf r]
set origgid [read -nonewline $gfd]
close $gfd
set txnlist [lindex $txns 0]
set t [lindex $txnlist 0]
set gid [lindex $txnlist 1]
error_check_good gidcompare $gid $origgid
puts "\t\t\tExecuting txn_$op2:$t"
error_check_good txn_$op2:$t [$t $op2] 0
#
# If we are testing discard, we do need to resolve
# the txn, so get the list again and now abort it.
#
if { $op2 == "discard" } {
set txns [$env txn_recover]
error_check_bad txnrecover [llength $txns] 0
set txnlist [lindex $txns 0]
set t [lindex $txnlist 0]
set gid [lindex $txnlist 1]
error_check_good gidcompare $gid $origgid
puts "\t\t\tExecuting txn_abort:$t"
error_check_good disc_txn_abort:$t [$t abort] 0
}
}
eval set args $args
eval open_and_dump_file $dir/$dbfile NULL $final_file nop \
dump_file_direction "-first" "-next" $args
if { $op == "commit" || $op2 == "commit" } {
filesort $afterop_file $afterop_file.sort
filesort $final_file $final_file.sort
error_check_good \
diff(post-$op,pre-commit):diff($afterop_file,$final_file) \
[filecmp $afterop_file.sort $final_file.sort] 0
} else {
filesort $init_file $init_file.sort
filesort $final_file $final_file.sort
error_check_good \
diff(initial,post-$op):diff($init_file,$final_file) \
[filecmp $init_file.sort $final_file.sort] 0
}
# Now close the environment, substitute a file that will need
# recovery and try running recovery again.
reset_env $env
if { $op == "commit" || $op2 == "commit" } {
catch { file copy -force $dir/$dbfile.init $dir/$dbfile } res
move_file_extent $dir $dbfile init copy
} else {
catch { file copy -force $dir/$dbfile.afterop $dir/$dbfile } res
move_file_extent $dir $dbfile afterop copy
}
berkdb debug_check
puts -nonewline "\t\tRunning recovery on pre-op database ... "
flush stdout
set stat [catch {eval exec $util_path/db_recover $recargs} result]
if { $stat == 1 } {
error "FAIL: Recovery error: $result."
}
puts -nonewline "complete ... "
error_check_good db_verify_preop \
[verify_dir $testdir "\t\t" 0 1 $nodump] 0
puts "verified"
set env [eval $env_cmd]
eval open_and_dump_file $dir/$dbfile NULL $final_file nop \
dump_file_direction "-first" "-next" $args
if { $op == "commit" || $op2 == "commit" } {
filesort $final_file $final_file.sort
filesort $afterop_file $afterop_file.sort
error_check_good \
diff(post-$op,recovered):diff($afterop_file,$final_file) \
[filecmp $afterop_file.sort $final_file.sort] 0
} else {
filesort $init_file $init_file.sort
filesort $final_file $final_file.sort
error_check_good \
diff(initial,post-$op):diff($init_file,$final_file) \
[filecmp $init_file.sort $final_file.sort] 0
}
# This should just close the environment, not blow it away.
reset_env $env
}
proc populate { db method txn n dups bigdata } {
source ./include.tcl
# Handle non-transactional cases, too.
set t ""
if { [llength $txn] > 0 } {
set t " -txn $txn "
}
set did [open $dict]
set count 0
while { [gets $did str] != -1 && $count < $n } {
if { [is_record_based $method] == 1 } {
set key [expr $count + 1]
} elseif { $dups == 1 } {
set key duplicate_key
} else {
set key $str
}
if { $bigdata == 1 && [berkdb random_int 1 3] == 1} {
set str [replicate $str 1000]
}
set ret [eval {$db put} $t {$key [chop_data $method $str]}]
error_check_good db_put:$key $ret 0
incr count
}
close $did
return 0
}
proc big_populate { db txn n } {
source ./include.tcl
set did [open $dict]
set count 0
while { [gets $did str] != -1 && $count < $n } {
set key [replicate $str 50]
set ret [$db put -txn $txn $key $str]
error_check_good db_put:$key $ret 0
incr count
}
close $did
return 0
}
proc unpopulate { db txn num } {
source ./include.tcl
set c [eval {$db cursor} "-txn $txn"]
error_check_bad $db:cursor $c NULL
error_check_good $db:cursor [is_substr $c $db] 1
set i 0
for {set d [$c get -first] } { [llength $d] != 0 } {
set d [$c get -next] } {
$c del
incr i
if { $num != 0 && $i >= $num } {
break
}
}
error_check_good cursor_close [$c close] 0
return 0
}
# Flush logs for txn envs only.
proc reset_env { env } {
if { [is_txnenv $env] } {
error_check_good log_flush [$env log_flush] 0
}
error_check_good env_close [$env close] 0
}
proc maxlocks { myenv locker_id obj_id num } {
return [countlocks $myenv $locker_id $obj_id $num ]
}
proc maxwrites { myenv locker_id obj_id num } {
return [countlocks $myenv $locker_id $obj_id $num ]
}
proc minlocks { myenv locker_id obj_id num } {
return [countlocks $myenv $locker_id $obj_id $num ]
}
proc minwrites { myenv locker_id obj_id num } {
return [countlocks $myenv $locker_id $obj_id $num ]
}
proc countlocks { myenv locker_id obj_id num } {
set locklist ""
for { set i 0} {$i < [expr $obj_id * 4]} { incr i } {
set r [catch {$myenv lock_get read $locker_id \
[expr $obj_id * 1000 + $i]} l ]
if { $r != 0 } {
puts $l
return ERROR
} else {
error_check_good lockget:$obj_id [is_substr $l $myenv] 1
lappend locklist $l
}
}
# Now acquire one write lock, except for obj_id 1, which doesn't
# acquire any. We'll use obj_id 1 to test minwrites.
if { $obj_id != 1 } {
set r [catch {$myenv lock_get write $locker_id \
[expr $obj_id * 1000 + 10]} l ]
if { $r != 0 } {
puts $l
return ERROR
} else {
error_check_good lockget:$obj_id [is_substr $l $myenv] 1
lappend locklist $l
}
}
# Get one extra write lock for obj_id 2. We'll use
# obj_id 2 to test maxwrites.
#
if { $obj_id == 2 } {
set extra [catch {$myenv lock_get write \
$locker_id [expr $obj_id * 1000 + 11]} l ]
if { $extra != 0 } {
puts $l
return ERROR
} else {
error_check_good lockget:$obj_id [is_substr $l $myenv] 1
lappend locklist $l
}
}
set ret [ring $myenv $locker_id $obj_id $num]
foreach l $locklist {
error_check_good lockput:$l [$l put] 0
}
return $ret
}
# This routine will let us obtain a ring of deadlocks.
# Each locker will get a lock on obj_id, then sleep, and
# then try to lock (obj_id + 1) % num.
# When the lock is finally granted, we release our locks and
# return 1 if we got both locks and DEADLOCK if we deadlocked.
# The results here should be that 1 locker deadlocks and the
# rest all finish successfully.
proc ring { myenv locker_id obj_id num } {
source ./include.tcl
if {[catch {$myenv lock_get write $locker_id $obj_id} lock1] != 0} {
puts $lock1
return ERROR
} else {
error_check_good lockget:$obj_id [is_substr $lock1 $myenv] 1
}
tclsleep 30
set nextobj [expr ($obj_id + 1) % $num]
set ret 1
if {[catch {$myenv lock_get write $locker_id $nextobj} lock2] != 0} {
if {[string match "*DEADLOCK*" $lock2] == 1} {
set ret DEADLOCK
} else {
if {[string match "*NOTGRANTED*" $lock2] == 1} {
set ret DEADLOCK
} else {
puts $lock2
set ret ERROR
}
}
} else {
error_check_good lockget:$obj_id [is_substr $lock2 $myenv] 1
}
# Now release the first lock
error_check_good lockput:$lock1 [$lock1 put] 0
if {$ret == 1} {
error_check_bad lockget:$obj_id $lock2 NULL
error_check_good lockget:$obj_id [is_substr $lock2 $myenv] 1
error_check_good lockput:$lock2 [$lock2 put] 0
}
return $ret
}
# This routine will create massive deadlocks.
# Each locker will get a readlock on obj_id, then sleep, and
# then try to upgrade the readlock to a write lock.
# When the lock is finally granted, we release our first lock and
# return 1 if we got both locks and DEADLOCK if we deadlocked.
# The results here should be that 1 locker succeeds in getting all
# the locks and everyone else deadlocks.
proc clump { myenv locker_id obj_id num } {
source ./include.tcl
set obj_id 10
if {[catch {$myenv lock_get read $locker_id $obj_id} lock1] != 0} {
puts $lock1
return ERROR
} else {
error_check_good lockget:$obj_id \
[is_valid_lock $lock1 $myenv] TRUE
}
tclsleep 30
set ret 1
if {[catch {$myenv lock_get write $locker_id $obj_id} lock2] != 0} {
if {[string match "*DEADLOCK*" $lock2] == 1} {
set ret DEADLOCK
} else {
if {[string match "*NOTGRANTED*" $lock2] == 1} {
set ret DEADLOCK
} else {
puts $lock2
set ret ERROR
}
}
} else {
error_check_good \
lockget:$obj_id [is_valid_lock $lock2 $myenv] TRUE
}
# Now release the first lock
error_check_good lockput:$lock1 [$lock1 put] 0
if {$ret == 1} {
error_check_good \
lockget:$obj_id [is_valid_lock $lock2 $myenv] TRUE
error_check_good lockput:$lock2 [$lock2 put] 0
}
return $ret
}
proc dead_check { t procs timeout dead clean other } {
error_check_good $t:$procs:other $other 0
switch $t {
ring {
# With timeouts the number of deadlocks is
# unpredictable: test for at least one deadlock.
if { $timeout != 0 && $dead > 1 } {
set clean [ expr $clean + $dead - 1]
set dead 1
}
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
clump {
# With timeouts the number of deadlocks is
# unpredictable: test for no more than one
# successful lock.
if { $timeout != 0 && $dead == $procs } {
set clean 1
set dead [expr $procs - 1]
}
error_check_good $t:$procs:deadlocks $dead \
[expr $procs - 1]
error_check_good $t:$procs:success $clean 1
}
oldyoung {
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
maxlocks {
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
maxwrites {
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
minlocks {
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
minwrites {
error_check_good $t:$procs:deadlocks $dead 1
error_check_good $t:$procs:success $clean \
[expr $procs - 1]
}
default {
error "Test $t not implemented"
}
}
}
proc rdebug { id op where } {
global recd_debug
global recd_id
global recd_op
set recd_debug $where
set recd_id $id
set recd_op $op
}
proc rtag { msg id } {
set tag [lindex $msg 0]
set tail [expr [string length $tag] - 2]
set tag [string range $tag $tail $tail]
if { $id == $tag } {
return 1
} else {
return 0
}
}
proc zero_list { n } {
set ret ""
while { $n > 0 } {
lappend ret 0
incr n -1
}
return $ret
}
proc check_dump { k d } {
puts "key: $k data: $d"
}
proc reverse { s } {
set res ""
for { set i 0 } { $i < [string length $s] } { incr i } {
set res "[string index $s $i]$res"
}
return $res
}
#
# This is a internal only proc. All tests should use 'is_valid_db' etc.
#
proc is_valid_widget { w expected } {
# First N characters must match "expected"
set l [string length $expected]
incr l -1
if { [string compare [string range $w 0 $l] $expected] != 0 } {
return $w
}
# Remaining characters must be digits
incr l 1
for { set i $l } { $i < [string length $w] } { incr i} {
set c [string index $w $i]
if { $c < "0" || $c > "9" } {
return $w
}
}
return TRUE
}
proc is_valid_db { db } {
return [is_valid_widget $db db]
}
proc is_valid_env { env } {
return [is_valid_widget $env env]
}
proc is_valid_cursor { dbc db } {
return [is_valid_widget $dbc $db.c]
}
proc is_valid_lock { lock env } {
return [is_valid_widget $lock $env.lock]
}
proc is_valid_logc { logc env } {
return [is_valid_widget $logc $env.logc]
}
proc is_valid_mpool { mpool env } {
return [is_valid_widget $mpool $env.mp]
}
proc is_valid_page { page mpool } {
return [is_valid_widget $page $mpool.pg]
}
proc is_valid_txn { txn env } {
return [is_valid_widget $txn $env.txn]
}
proc is_valid_locker {l } {
return [is_valid_widget $l ""]
}
proc is_valid_seq { seq } {
return [is_valid_widget $seq seq]
}
proc send_cmd { fd cmd {sleep 2}} {
source ./include.tcl
puts $fd "if \[catch {set v \[$cmd\] ; puts \$v} ret\] { \
puts \"FAIL: \$ret\" \
}"
puts $fd "flush stdout"
flush $fd
berkdb debug_check
tclsleep $sleep
set r [rcv_result $fd]
return $r
}
proc rcv_result { fd } {
global errorInfo
set r [gets $fd result]
if { $r == -1 } {
puts "FAIL: gets returned -1 (EOF)"
puts "FAIL: errorInfo is $errorInfo"
}
return $result
}
proc send_timed_cmd { fd rcv_too cmd } {
set c1 "set start \[timestamp -r\]; "
set c2 "puts \[expr \[timestamp -r\] - \$start\]"
set full_cmd [concat $c1 $cmd ";" $c2]
puts $fd $full_cmd
puts $fd "flush stdout"
flush $fd
return 0
}
#
# The rationale behind why we have *two* "data padding" routines is outlined
# below:
#
# Both pad_data and chop_data truncate data that is too long. However,
# pad_data also adds the pad character to pad data out to the fixed length
# record length.
#
# Which routine you call does not depend on the length of the data you're
# using, but on whether you're doing a put or a get. When we do a put, we
# have to make sure the data isn't longer than the size of a record because
# otherwise we'll get an error (use chop_data). When we do a get, we want to
# check that db padded everything correctly (use pad_data on the value against
# which we are comparing).
#
# We don't want to just use the pad_data routine for both purposes, because
# we want to be able to test whether or not db is padding correctly. For
# example, the queue access method had a bug where when a record was
# overwritten (*not* a partial put), only the first n bytes of the new entry
# were written, n being the new entry's (unpadded) length. So, if we did
# a put with key,value pair (1, "abcdef") and then a put (1, "z"), we'd get
# back (1,"zbcdef"). If we had used pad_data instead of chop_data, we would
# have gotten the "correct" result, but we wouldn't have found this bug.
proc chop_data {method data} {
global fixed_len
if {[is_fixed_length $method] == 1 && \
[string length $data] > $fixed_len} {
return [eval {binary format a$fixed_len $data}]
} else {
return $data
}
}
proc pad_data {method data} {
global fixed_len
if {[is_fixed_length $method] == 1} {
return [eval {binary format a$fixed_len $data}]
} else {
return $data
}
}
#
# The make_fixed_length proc is used in special circumstances where we
# absolutely need to send in data that is already padded out to the fixed
# length with a known pad character. Most tests should use chop_data and
# pad_data, not this.
#
proc make_fixed_length {method data {pad 0}} {
global fixed_len
if {[is_fixed_length $method] == 1} {
set data [chop_data $method $data]
while { [string length $data] < $fixed_len } {
set data [format $data%c $pad]
}
}
return $data
}
proc make_gid {data} {
while { [string length $data] < 128 } {
set data [format ${data}0]
}
return $data
}
# shift data for partial
# pad with fixed pad (which is NULL)
proc partial_shift { data offset direction} {
global fixed_len
set len [expr $fixed_len - 1]
if { [string compare $direction "right"] == 0 } {
for { set i 1} { $i <= $offset } {incr i} {
set data [binary format x1a$len $data]
}
} elseif { [string compare $direction "left"] == 0 } {
for { set i 1} { $i <= $offset } {incr i} {
set data [string range $data 1 end]
set data [binary format a$len $data]
}
}
return $data
}
# string compare does not always work to compare
# this data, nor does expr (==)
# specialized routine for comparison
# (for use in fixed len recno and q)
proc binary_compare { data1 data2 } {
if { [string length $data1] != [string length $data2] || \
[string compare -length \
[string length $data1] $data1 $data2] != 0 } {
return 1
} else {
return 0
}
}
# This is a comparison function used with the lsort command.
# It treats its inputs as 32 bit signed integers for comparison,
# and is coded to work with both 32 bit and 64 bit versions of tclsh.
proc int32_compare { val1 val2 } {
# Big is set to 2^32 on a 64 bit machine, or 0 on 32 bit machine.
set big [expr 0xffffffff + 1]
if { $val1 >= 0x80000000 } {
set val1 [expr $val1 - $big]
}
if { $val2 >= 0x80000000 } {
set val2 [expr $val2 - $big]
}
return [expr $val1 - $val2]
}
proc convert_method { method } {
switch -- $method {
-btree -
-dbtree -
dbtree -
-ddbtree -
ddbtree -
-rbtree -
BTREE -
DB_BTREE -
DB_RBTREE -
RBTREE -
bt -
btree -
db_btree -
db_rbtree -
rbt -
rbtree { return "-btree" }
-dhash -
-ddhash -
-hash -
DB_HASH -
HASH -
dhash -
ddhash -
db_hash -
h -
hash { return "-hash" }
-queue -
DB_QUEUE -
QUEUE -
db_queue -
q -
qam -
queue -
-iqueue -
DB_IQUEUE -
IQUEUE -
db_iqueue -
iq -
iqam -
iqueue { return "-queue" }
-queueextent -
QUEUEEXTENT -
qe -
qamext -
-queueext -
queueextent -
queueext -
-iqueueextent -
IQUEUEEXTENT -
iqe -
iqamext -
-iqueueext -
iqueueextent -
iqueueext { return "-queue" }
-frecno -
-recno -
-rrecno -
DB_FRECNO -
DB_RECNO -
DB_RRECNO -
FRECNO -
RECNO -
RRECNO -
db_frecno -
db_recno -
db_rrecno -
frec -
frecno -
rec -
recno -
rrec -
rrecno { return "-recno" }
-heap -
-db_heap -
heap -
db_heap -
HEAP -
DB_HEAP {return "-heap" }
default { error "FAIL:[timestamp] $method: unknown method" }
}
}
proc split_partition_args { largs } {
# First check for -partition_callback, in which case we
# need to remove three args.
set index [lsearch $largs "-partition_callback"]
if { $index == -1 } {
set newl $largs
} else {
set end [expr $index + 2]
set newl [lreplace $largs $index $end]
}
# Then check for -partition, and remove two args.
set index [lsearch $newl "-partition"]
if { $index > -1 } {
set end [expr $index + 1]
set newl [lreplace $largs $index $end]
}
return $newl
}
# Strip "-compress" out of a string of args.
proc strip_compression_args { largs } {
set cindex [lsearch $largs "-compress"]
if { $cindex == -1 } {
set newargs $largs
} else {
set newargs [lreplace $largs $cindex $cindex]
}
return $newargs
}
proc split_encargs { largs encargsp } {
global encrypt
upvar $encargsp e
set eindex [lsearch $largs "-encrypta*"]
if { $eindex == -1 } {
set e ""
set newl $largs
} else {
set eend [expr $eindex + 1]
set e [lrange $largs $eindex $eend]
set newl [lreplace $largs $eindex $eend "-encrypt"]
}
return $newl
}
proc split_pageargs { largs pageargsp } {
upvar $pageargsp e
set eindex [lsearch $largs "-pagesize"]
if { $eindex == -1 } {
set e ""
set newl $largs
} else {
set eend [expr $eindex + 1]
set e [lrange $largs $eindex $eend]
set newl [lreplace $largs $eindex $eend ""]
}
return $newl
}
proc convert_encrypt { largs } {
global encrypt
global old_encrypt
set old_encrypt $encrypt
set encrypt 0
if { [lsearch $largs "-encrypt*"] != -1 } {
set encrypt 1
}
}
# If recno-with-renumbering or btree-with-renumbering is specified, then
# fix the arguments to specify the DB_RENUMBER/DB_RECNUM option for the
# -flags argument.
proc convert_args { method {largs ""} } {
global fixed_len
global gen_upgrade
global upgrade_be
source ./include.tcl
if { [string first - $largs] == -1 &&\
[string compare $largs ""] != 0 &&\
[string compare $largs {{}}] != 0 } {
set errstring "args must contain a hyphen; does this test\
have no numeric args?"
puts "FAIL:[timestamp] $errstring (largs was $largs)"
return -code return
}
convert_encrypt $largs
if { $gen_upgrade == 1 && $upgrade_be == 1 } {
append largs " -lorder 4321 "
} elseif { $gen_upgrade == 1 && $upgrade_be != 1 } {
append largs " -lorder 1234 "
}
if { [is_rrecno $method] == 1 } {
append largs " -renumber "
} elseif { [is_rbtree $method] == 1 } {
append largs " -recnum "
} elseif { [is_dbtree $method] == 1 } {
append largs " -dup "
} elseif { [is_ddbtree $method] == 1 } {
append largs " -dup "
append largs " -dupsort "
} elseif { [is_dhash $method] == 1 } {
append largs " -dup "
} elseif { [is_ddhash $method] == 1 } {
append largs " -dup "
append largs " -dupsort "
} elseif { [is_queueext $method] == 1 } {
append largs " -extent 4 "
}
if { [is_iqueue $method] == 1 || [is_iqueueext $method] == 1 } {
append largs " -inorder "
}
# Default padding character is ASCII nul.
set fixed_pad 0
if {[is_fixed_length $method] == 1} {
append largs " -len $fixed_len -pad $fixed_pad "
}
return $largs
}
proc is_btree { method } {
set names { -btree BTREE DB_BTREE bt btree }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_dbtree { method } {
set names { -dbtree dbtree }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_ddbtree { method } {
set names { -ddbtree ddbtree }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_rbtree { method } {
set names { -rbtree rbtree RBTREE db_rbtree DB_RBTREE rbt }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_heap { method } {
set names { -heap DB_HEAP HEAP db_heap heap}
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_recno { method } {
set names { -recno DB_RECNO RECNO db_recno rec recno}
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_rrecno { method } {
set names { -rrecno rrecno RRECNO db_rrecno DB_RRECNO rrec }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_frecno { method } {
set names { -frecno frecno frec FRECNO db_frecno DB_FRECNO}
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_hash { method } {
set names { -hash DB_HASH HASH db_hash h hash }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_dhash { method } {
set names { -dhash dhash }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_ddhash { method } {
set names { -ddhash ddhash }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_queue { method } {
if { [is_queueext $method] == 1 || [is_iqueue $method] == 1 || \
[is_iqueueext $method] == 1 } {
return 1
}
set names { -queue DB_QUEUE QUEUE db_queue q queue qam }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_queueext { method } {
if { [is_iqueueext $method] == 1 } {
return 1
}
set names { -queueextent queueextent QUEUEEXTENT qe qamext \
queueext -queueext }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_iqueue { method } {
if { [is_iqueueext $method] == 1 } {
return 1
}
set names { -iqueue DB_IQUEUE IQUEUE db_iqueue iq iqueue iqam }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_iqueueext { method } {
set names { -iqueueextent iqueueextent IQUEUEEXTENT iqe iqamext \
iqueueext -iqueueext }
if { [lsearch $names $method] >= 0 } {
return 1
} else {
return 0
}
}
proc is_record_based { method } {
if { [is_recno $method] || [is_frecno $method] ||
[is_heap $method] ||
[is_rrecno $method] || [is_queue $method] } {
return 1
} else {
return 0
}
}
proc is_fixed_length { method } {
if { [is_queue $method] || [is_frecno $method] } {
return 1
} else {
return 0
}
}
proc is_compressed { args } {
if { [string first "-compress" $args] >= 0 } {
return 1
} else {
return 0
}
}
proc is_partitioned { args } {
if { [string first "-partition" $args] >= 0 } {
return 1
} else {
return 0
}
}
proc is_partition_callback { args } {
if { [string first "-partition_callback" $args] >= 0 } {
return 1
} else {
return 0
}
}
# Sort lines in file $in and write results to file $out.
# This is a more portable alternative to execing the sort command,
# which has assorted issues on NT [#1576].
# The addition of a "-n" argument will sort numerically.
proc filesort { in out { arg "" } } {
set i [open $in r]
set ilines {}
while { [gets $i line] >= 0 } {
lappend ilines $line
}
if { [string compare $arg "-n"] == 0 } {
set olines [lsort -integer $ilines]
} else {
set olines [lsort $ilines]
}
close $i
set o [open $out w]
foreach line $olines {
puts $o $line
}
close $o
}
# Print lines up to the nth line of infile out to outfile, inclusive.
# The optional beg argument tells us where to start.
proc filehead { n infile outfile { beg 0 } } {
set in [open $infile r]
set out [open $outfile w]
# Sed uses 1-based line numbers, and so we do too.
for { set i 1 } { $i < $beg } { incr i } {
if { [gets $in junk] < 0 } {
break
}
}
for { } { $i <= $n } { incr i } {
if { [gets $in line] < 0 } {
break
}
puts $out $line
}
close $in
close $out
}
# Remove file (this replaces $RM).
# Usage: fileremove filenames =~ rm; fileremove -f filenames =~ rm -rf.
proc fileremove { args } {
set forceflag ""
foreach a $args {
if { [string first - $a] == 0 } {
# It's a flag. Better be f.
if { [string first f $a] != 1 } {
return -code error "bad flag to fileremove"
} else {
set forceflag "-force"
}
} else {
eval {file delete $forceflag $a}
}
}
}
# Look for a certain character string on a single line in one file.
proc findstring { string file } {
set found 0
if { [file exists $file] == 0 } {
error "FAIL: file $file does not exist"
}
set f [open $file r]
while { [gets $f line] >= 0 } {
if { [is_substr $line $string] == 1 } {
set found 1
close $f
return $found
}
}
close $f
return $found
}
proc findfail { args } {
set errstring {}
foreach a $args {
if { [file exists $a] == 0 } {
continue
}
set f [open $a r]
while { [gets $f line] >= 0 } {
if { [string first FAIL $line] == 0 } {
lappend errstring $a:$line
}
}
close $f
}
return $errstring
}
# Sleep for s seconds.
proc tclsleep { s } {
# On Windows, the system time-of-day clock may update as much
# as 55 ms late due to interrupt timing. Don't take any
# chances; sleep extra-long so that when tclsleep 1 returns,
# it's guaranteed to be a new second.
after [expr $s * 1000 + 56]
}
# Kill a process.
proc tclkill { id } {
source ./include.tcl
while { [ catch {exec $KILL -0 $id} ] == 0 } {
catch {exec $KILL -9 $id}
tclsleep 5
}
}
# Compare two files, a la diff. Returns 1 if non-identical, 0 if identical.
proc filecmp { file_a file_b } {
set fda [open $file_a r]
set fdb [open $file_b r]
fconfigure $fda -translation binary
fconfigure $fdb -translation binary
set nra 0
set nrb 0
# The gets can't be in the while condition because we'll
# get short-circuit evaluated.
while { $nra >= 0 && $nrb >= 0 } {
set nra [gets $fda aline]
set nrb [gets $fdb bline]
if { $nra != $nrb || [string compare $aline $bline] != 0} {
close $fda
close $fdb
return 1
}
}
close $fda
close $fdb
return 0
}
# Compare the log files from 2 envs. Returns 1 if non-identical,
# 0 if identical.
proc logcmp { env1 env2 { compare_shared_portion 0 } } {
set lc1 [$env1 log_cursor]
set lc2 [$env2 log_cursor]
# If we're comparing the full set of logs in both envs,
# set the starting point by looking at the first LSN in the
# first env's logs.
#
# If we are comparing only the shared portion, look at the
# starting LSN of the second env as well, and select the
# LSN that is larger.
set start [lindex [$lc1 get -first] 0]
if { $compare_shared_portion } {
set e2_lsn [lindex [$lc2 get -first] 0]
if { [$env1 log_compare $start $e2_lsn] < 0 } {
set start $e2_lsn
}
}
# Read through and compare the logs record by record.
for { set l1 [$lc1 get -set $start] ; set l2 [$lc2 get -set $start] }\
{ [llength $l1] > 0 && [llength $l2] > 0 }\
{ set l1 [$lc1 get -next] ; set l2 [$lc2 get -next] } {
if { [string equal $l1 $l2] != 1 } {
$lc1 close
$lc2 close
#puts "l1 is $l1"
#puts "l2 is $l2"
return 1
}
}
$lc1 close
$lc2 close
return 0
}
# Give two SORTED files, one of which is a complete superset of the other,
# extract out the unique portions of the superset and put them in
# the given outfile.
proc fileextract { superset subset outfile } {
set sup [open $superset r]
set sub [open $subset r]
set outf [open $outfile w]
# The gets can't be in the while condition because we'll
# get short-circuit evaluated.
set nrp [gets $sup pline]
set nrb [gets $sub bline]
while { $nrp >= 0 } {
if { $nrp != $nrb || [string compare $pline $bline] != 0} {
puts $outf $pline
} else {
set nrb [gets $sub bline]
}
set nrp [gets $sup pline]
}
close $sup
close $sub
close $outf
return 0
}
# Verify all .db files in the specified directory.
proc verify_dir { {directory $testdir} { pref "" } \
{ noredo 0 } { quiet 0 } { nodump 0 } { cachesize 0 } { unref 1 } } {
global encrypt
global passwd
# If we're doing database verification between tests, we don't
# want to do verification twice without an intervening cleanup--some
# test was skipped. Always verify by default (noredo == 0) so
# that explicit calls to verify_dir during tests don't require
# cleanup commands.
if { $noredo == 1 } {
if { [file exists $directory/NOREVERIFY] == 1 } {
if { $quiet == 0 } {
puts "Skipping verification."
}
return 0
}
set f [open $directory/NOREVERIFY w]
close $f
}
if { [catch {glob $directory/*.db} dbs] != 0 } {
# No files matched
return 0
}
set ret 0
# Open an env, so that we have a large enough cache. Pick
# a fairly generous default if we haven't specified something else.
if { $cachesize == 0 } {
set cachesize [expr 1024 * 1024]
}
set encarg ""
if { $encrypt != 0 } {
set encarg "-encryptaes $passwd"
}
set env [eval {berkdb_env -create -private} $encarg \
{-cachesize [list 0 $cachesize 0]}]
set earg " -env $env "
# The 'unref' flag means that we report unreferenced pages
# at all times. This is the default behavior.
# If we have a test which leaves unreferenced pages on systems
# where HAVE_FTRUNCATE is not on, then we call verify_dir with
# unref == 0.
set uflag "-unref"
if { $unref == 0 } {
set uflag ""
}
foreach db $dbs {
# Replication's temp db uses a custom comparison function,
# so we can't verify it.
#
if { [file tail $db] == "__db.rep.db" } {
continue
}
if { [catch \
{eval {berkdb dbverify} $uflag $earg $db} res] != 0 } {
puts $res
puts "FAIL:[timestamp] Verification of $db failed."
set ret 1
continue
} else {
error_check_good verify:$db $res 0
if { $quiet == 0 } {
puts "${pref}Verification of $db succeeded."
}
}
# Skip the dump if it's dangerous to do it.
if { $nodump == 0 } {
if { [catch {eval dumploadtest $db} res] != 0 } {
puts $res
puts "FAIL:[timestamp] Dump/load of $db failed."
set ret 1
continue
} else {
error_check_good dumpload:$db $res 0
if { $quiet == 0 } {
puts \
"${pref}Dump/load of $db succeeded."
}
}
}
}
error_check_good vrfyenv_close [$env close] 0
return $ret
}
# Is the database handle in $db a master database containing subdbs?
proc check_for_subdbs { db } {
set stat [$db stat]
for { set i 0 } { [string length [lindex $stat $i]] > 0 } { incr i } {
set elem [lindex $stat $i]
if { [string compare [lindex $elem 0] Flags] == 0 } {
# This is the list of flags; look for
# "subdatabases".
if { [is_substr [lindex $elem 1] subdatabases] } {
return 1
}
}
}
return 0
}
proc db_compare { olddb newdb olddbname newdbname } {
# Walk through olddb and newdb and make sure their contents
# are identical.
set oc [$olddb cursor]
set nc [$newdb cursor]
error_check_good orig_cursor($olddbname) \
[is_valid_cursor $oc $olddb] TRUE
error_check_good new_cursor($olddbname) \
[is_valid_cursor $nc $newdb] TRUE
for { set odbt [$oc get -first -nolease] } { [llength $odbt] > 0 } \
{ set odbt [$oc get -next -nolease] } {
set ndbt [$nc get -get_both -nolease \
[lindex [lindex $odbt 0] 0] [lindex [lindex $odbt 0] 1]]
if { [binary_compare $ndbt $odbt] == 1 } {
error_check_good oc_close [$oc close] 0
error_check_good nc_close [$nc close] 0
# puts "FAIL: $odbt does not match $ndbt"
return 1
}
}
for { set ndbt [$nc get -first -nolease] } { [llength $ndbt] > 0 } \
{ set ndbt [$nc get -next -nolease] } {
set odbt [$oc get -get_both -nolease \
[lindex [lindex $ndbt 0] 0] [lindex [lindex $ndbt 0] 1]]
if { [binary_compare $ndbt $odbt] == 1 } {
error_check_good oc_close [$oc close] 0
error_check_good nc_close [$nc close] 0
# puts "FAIL: $odbt does not match $ndbt"
return 1
}
}
error_check_good orig_cursor_close($olddbname) [$oc close] 0
error_check_good new_cursor_close($newdbname) [$nc close] 0
return 0
}
proc dumploadtest { db } {
global util_path
global encrypt
global passwd
set newdbname $db-dumpload.db
set dbarg ""
set utilflag ""
set keyflag "-k"
set heapdb 0
if { $encrypt != 0 } {
set dbarg "-encryptany $passwd"
set utilflag "-P $passwd"
}
# Open original database to find dbtype.
set olddb [eval {berkdb_open -rdonly} $dbarg $db]
error_check_good olddb($db) [is_valid_db $olddb] TRUE
if { [is_heap [$olddb get_type]] } {
set heapdb 1
set keyflag ""
}
error_check_good orig_db_close($db) [$olddb close] 0
set dumpflags "$utilflag $keyflag"
# Dump/load the whole file, including all subdbs.
set rval [catch {eval {exec $util_path/db_dump} $dumpflags \
$db | $util_path/db_load $utilflag $newdbname} res]
error_check_good db_dump/db_load($db:$res) $rval 0
# If the old file was empty, there's no new file and we're done.
if { [file exists $newdbname] == 0 } {
return 0
}
# Dump/load doesn't preserve order in a heap db, don't run db_compare
if { $heapdb == 1 } {
eval berkdb dbremove $dbarg $newdbname
return 0
}
# Open original database.
set olddb [eval {berkdb_open -rdonly} $dbarg $db]
error_check_good olddb($db) [is_valid_db $olddb] TRUE
if { [check_for_subdbs $olddb] } {
# If $db has subdatabases, compare each one separately.
set oc [$olddb cursor]
error_check_good orig_cursor($db) \
[is_valid_cursor $oc $olddb] TRUE
for { set dbt [$oc get -first] } \
{ [llength $dbt] > 0 } \
{ set dbt [$oc get -next] } {
set subdb [lindex [lindex $dbt 0] 0]
set oldsubdb \
[eval {berkdb_open -rdonly} $dbarg {$db $subdb}]
error_check_good olddb($db) [is_valid_db $oldsubdb] TRUE
# Open the new database.
set newdb \
[eval {berkdb_open -rdonly} $dbarg {$newdbname $subdb}]
error_check_good newdb($db) [is_valid_db $newdb] TRUE
db_compare $oldsubdb $newdb $db $newdbname
error_check_good new_db_close($db) [$newdb close] 0
error_check_good old_subdb_close($oldsubdb) [$oldsubdb close] 0
}
error_check_good oldcclose [$oc close] 0
} else {
# Open the new database.
set newdb [eval {berkdb_open -rdonly} $dbarg $newdbname]
error_check_good newdb($db) [is_valid_db $newdb] TRUE
db_compare $olddb $newdb $db $newdbname
error_check_good new_db_close($db) [$newdb close] 0
}
error_check_good orig_db_close($db) [$olddb close] 0
eval berkdb dbremove $dbarg $newdbname
}
# Test regular and aggressive salvage procedures for all databases
# in a directory.
proc salvage_dir { dir { noredo 0 } { quiet 0 } } {
global util_path
global encrypt
global passwd
# If we're doing salvage testing between tests, don't do it
# twice without an intervening cleanup.
if { $noredo == 1 } {
if { [file exists $dir/NOREDO] == 1 } {
if { $quiet == 0 } {
puts "Skipping salvage testing."
}
return 0
}
set f [open $dir/NOREDO w]
close $f
}
if { [catch {glob $dir/*.db} dbs] != 0 } {
# No files matched
return 0
}
foreach db $dbs {
set dumpfile $db-dump
set sorteddump $db-dump-sorted
set salvagefile $db-salvage
set sortedsalvage $db-salvage-sorted
set aggsalvagefile $db-aggsalvage
set dbarg ""
set utilflag ""
if { $encrypt != 0 } {
set dbarg "-encryptany $passwd"
set utilflag "-P $passwd"
}
# Dump the database with salvage, with aggressive salvage,
# and without salvage.
#
set rval [catch {eval {exec $util_path/db_dump} $utilflag -r \
-f $salvagefile $db} res]
error_check_good salvage($db:$res) $rval 0
filesort $salvagefile $sortedsalvage
# We can't avoid occasional verify failures in aggressive
# salvage. Make sure it's the expected failure.
set rval [catch {eval {exec $util_path/db_dump} $utilflag -R \
-f $aggsalvagefile $db} res]
if { $rval == 1 } {
#puts "res is $res"
error_check_good agg_failure \
[is_substr $res "DB_VERIFY_BAD"] 1
} else {
error_check_good aggressive_salvage($db:$res) $rval 0
}
# Queue databases must be dumped with -k to display record
# numbers if we're not in salvage mode.
if { [isqueuedump $salvagefile] == 1 } {
append utilflag " -k "
}
# Discard db_pagesize lines from file dumped with ordinary
# db_dump -- they are omitted from a salvage dump.
set rval [catch {eval {exec $util_path/db_dump} $utilflag \
-f $dumpfile $db} res]
error_check_good dump($db:$res) $rval 0
filesort $dumpfile $sorteddump
discardline $sorteddump TEMPFILE "db_pagesize="
file copy -force TEMPFILE $sorteddump
# A non-aggressively salvaged file should match db_dump.
error_check_good compare_dump_and_salvage \
[filecmp $sorteddump $sortedsalvage] 0
puts "Salvage tests of $db succeeded."
}
}
# Reads infile, writes to outfile, discarding any line whose
# beginning matches the given string.
proc discardline { infile outfile discard } {
set fdin [open $infile r]
set fdout [open $outfile w]
while { [gets $fdin str] >= 0 } {
if { [string match $discard* $str] != 1 } {
puts $fdout $str
}
}
close $fdin
close $fdout
}
# Inspects dumped file for "type=" line. Returns 1 if type=queue.
proc isqueuedump { file } {
set fd [open $file r]
while { [gets $fd str] >= 0 } {
if { [string match type=* $str] == 1 } {
if { [string match "type=queue" $str] == 1 } {
close $fd
return 1
} else {
close $fd
return 0
}
}
}
close $fd
}
# Generate randomly ordered, guaranteed-unique four-character strings that can
# be used to differentiate duplicates without creating duplicate duplicates.
# (test031 & test032) randstring_init is required before the first call to
# randstring and initializes things for up to $i distinct strings; randstring
# gets the next string.
proc randstring_init { i } {
global rs_int_list alphabet
# Fail if we can't generate sufficient unique strings.
if { $i > [expr 26 * 26 * 26 * 26] } {
set errstring\
"Duplicate set too large for random string generator"
puts "FAIL:[timestamp] $errstring"
return -code return $errstring
}
set rs_int_list {}
# generate alphabet array
for { set j 0 } { $j < 26 } { incr j } {
set a($j) [string index $alphabet $j]
}
# Generate a list with $i elements, { aaaa, aaab, ... aaaz, aaba ...}
for { set d1 0 ; set j 0 } { $d1 < 26 && $j < $i } { incr d1 } {
for { set d2 0 } { $d2 < 26 && $j < $i } { incr d2 } {
for { set d3 0 } { $d3 < 26 && $j < $i } { incr d3 } {
for { set d4 0 } { $d4 < 26 && $j < $i } \
{ incr d4 } {
lappend rs_int_list \
$a($d1)$a($d2)$a($d3)$a($d4)
incr j
}
}
}
}
# Randomize the list.
set rs_int_list [randomize_list $rs_int_list]
}
# Randomize a list. Returns a randomly-reordered copy of l.
proc randomize_list { l } {
set i [llength $l]
for { set j 0 } { $j < $i } { incr j } {
# Pick a random element from $j to the end
set k [berkdb random_int $j [expr $i - 1]]
# Swap it with element $j
set t1 [lindex $l $j]
set t2 [lindex $l $k]
set l [lreplace $l $j $j $t2]
set l [lreplace $l $k $k $t1]
}
return $l
}
proc randstring {} {
global rs_int_list
if { [info exists rs_int_list] == 0 || [llength $rs_int_list] == 0 } {
set errstring "randstring uninitialized or used too often"
puts "FAIL:[timestamp] $errstring"
return -code return $errstring
}
set item [lindex $rs_int_list 0]
set rs_int_list [lreplace $rs_int_list 0 0]
return $item
}
# Takes a variable-length arg list, and returns a list containing the list of
# the non-hyphenated-flag arguments, followed by a list of each alphanumeric
# flag it finds.
proc extractflags { args } {
set inflags 1
set flags {}
while { $inflags == 1 } {
set curarg [lindex $args 0]
if { [string first "-" $curarg] == 0 } {
set i 1
while {[string length [set f \
[string index $curarg $i]]] > 0 } {
incr i
if { [string compare $f "-"] == 0 } {
set inflags 0
break
} else {
lappend flags $f
}
}
set args [lrange $args 1 end]
} else {
set inflags 0
}
}
return [list $args $flags]
}
# Wrapper for berkdb open, used throughout the test suite so that we can
# set an errfile/errpfx as appropriate.
proc berkdb_open { args } {
global is_envmethod
if { [info exists is_envmethod] == 0 } {
set is_envmethod 0
}
set errargs {}
if { $is_envmethod == 0 } {
append errargs " -errfile /dev/stderr "
append errargs " -errpfx \\F\\A\\I\\L"
}
eval {berkdb open} $errargs $args
}
# Version without errpfx/errfile, used when we're expecting a failure.
proc berkdb_open_noerr { args } {
eval {berkdb open} $args
}
# Wrapper for berkdb env, used throughout the test suite so that we can
# set an errfile/errpfx as appropriate.
proc berkdb_env { args } {
global is_envmethod
if { [info exists is_envmethod] == 0 } {
set is_envmethod 0
}
set errargs {}
if { $is_envmethod == 0 } {
append errargs " -errfile /dev/stderr "
append errargs " -errpfx \\F\\A\\I\\L"
}
eval {berkdb env} $errargs $args
}
# Version without errpfx/errfile, used when we're expecting a failure.
proc berkdb_env_noerr { args } {
eval {berkdb env} $args
}
proc check_handles { {outf stdout} } {
global ohandles
set handles [berkdb handles]
if {[llength $handles] != [llength $ohandles]} {
puts $outf "WARNING: Open handles during cleanup: $handles"
}
set ohandles $handles
}
proc open_handles { } {
return [llength [berkdb handles]]
}
# Will close any database and cursor handles, cursors first.
# Ignores other handles, like env handles.
proc close_db_handles { } {
set handles [berkdb handles]
set db_handles {}
set cursor_handles {}
# Find the handles we want to process. We can't use
# is_valid_cursor to find cursors because we don't know
# the cursor's parent database handle.
foreach handle $handles {
if {[string range $handle 0 1] == "db"} {
if { [string first "c" $handle] != -1} {
lappend cursor_handles $handle
} else {
lappend db_handles $handle
}
}
}
foreach handle $cursor_handles {
error_check_good cursor_close [$handle close] 0
}
foreach handle $db_handles {
error_check_good db_close [$handle close] 0
}
}
proc move_file_extent { dir dbfile tag op } {
set curfiles [get_extfiles $dir $dbfile ""]
set tagfiles [get_extfiles $dir $dbfile $tag]
#
# We want to copy or rename only those that have been saved,
# so delete all the current extent files so that we don't
# end up with extra ones we didn't restore from our saved ones.
foreach extfile $curfiles {
file delete -force $extfile
}
foreach extfile $tagfiles {
set dbq [make_ext_filename $dir $dbfile $extfile]
#
# We can either copy or rename
#
file $op -force $extfile $dbq
}
}
proc copy_extent_file { dir dbfile tag { op copy } } {
set files [get_extfiles $dir $dbfile ""]
foreach extfile $files {
set dbq [make_ext_filename $dir $dbfile $extfile $tag]
file $op -force $extfile $dbq
}
}
proc get_extfiles { dir dbfile tag } {
if { $tag == "" } {
set filepat $dir/__db?.$dbfile.\[0-9\]*
} else {
set filepat $dir/__db?.$dbfile.$tag.\[0-9\]*
}
return [glob -nocomplain -- $filepat]
}
proc make_ext_filename { dir dbfile extfile {tag ""}} {
set i [string last "." $extfile]
incr i
set extnum [string range $extfile $i end]
set j [string last "/" $extfile]
incr j
set i [string first "." [string range $extfile $j end]]
incr i $j
incr i -1
set prefix [string range $extfile $j $i]
if {$tag == "" } {
return $dir/$prefix.$dbfile.$extnum
} else {
return $dir/$prefix.$dbfile.$tag.$extnum
}
}
# All pids for Windows 9X are negative values. When we want to have
# unsigned int values, unique to the process, we'll take the absolute
# value of the pid. This avoids unsigned/signed mistakes, yet
# guarantees uniqueness, since each system has pids that are all
# either positive or negative.
#
proc sanitized_pid { } {
set mypid [pid]
if { $mypid < 0 } {
set mypid [expr - $mypid]
}
puts "PID: [pid] $mypid\n"
return $mypid
}
#
# Extract the page size field from a stat record. Return -1 if
# none is found.
#
proc get_pagesize { stat } {
foreach field $stat {
set title [lindex $field 0]
if {[string compare $title "Page size"] == 0} {
return [lindex $field 1]
}
}
return -1
}
# Get a globbed list of source files and executables to use as large
# data items in overflow page tests.
proc get_file_list { {small 0} } {
global is_windows_test
global is_qnx_test
global is_je_test
global src_root
# Skip libraries if we have a debug build.
if { $is_qnx_test || $is_je_test || [is_debug] == 1 } {
set small 1
}
if { $small && $is_windows_test } {
set templist [glob $src_root/*/*.c $src_root/*/*/*.c \
*/*/*/env*.obj]
} elseif { $small } {
set templist [glob $src_root/*/*.c $src_root/*/*/*.c \
./.libs/env*.o]
} elseif { $is_windows_test } {
set templist \
[glob $src_root/*/*.c $src_root/*/*/*.c */*/*/*.obj \
*/*/*.exe */*/libdb??.dll */*/libdb??d.dll]
} else {
set templist [glob $src_root/*/*.c $src_root/*/*/*.c \
./.libs/*.o ./.libs/libdb-?.?.s?]
}
# We don't want a huge number of files, but we do want a nice
# variety. If there are more than nfiles files, pick out a list
# by taking every other, or every third, or every nth file.
set filelist {}
set nfiles 500
if { [llength $templist] > $nfiles } {
set skip \
[expr [llength $templist] / [expr [expr $nfiles / 3] * 2]]
set i $skip
while { $i < [llength $templist] } {
lappend filelist [lindex $templist $i]
incr i $skip
}
} else {
set filelist $templist
}
return $filelist
}
proc is_cdbenv { env } {
set sys [$env attributes]
if { [lsearch $sys -cdb] != -1 } {
return 1
} else {
return 0
}
}
proc is_lockenv { env } {
set sys [$env attributes]
if { [lsearch $sys -lock] != -1 } {
return 1
} else {
return 0
}
}
proc is_logenv { env } {
set sys [$env attributes]
if { [lsearch $sys -log] != -1 } {
return 1
} else {
return 0
}
}
proc is_mpoolenv { env } {
set sys [$env attributes]
if { [lsearch $sys -mpool] != -1 } {
return 1
} else {
return 0
}
}
proc is_repenv { env } {
set sys [$env attributes]
if { [lsearch $sys -rep] != -1 } {
return 1
} else {
return 0
}
}
proc is_secenv { env } {
set sys [$env attributes]
if { [lsearch $sys -crypto] != -1 } {
return 1
} else {
return 0
}
}
proc is_txnenv { env } {
set sys [$env attributes]
if { [lsearch $sys -txn] != -1 } {
return 1
} else {
return 0
}
}
proc get_home { env } {
set sys [$env attributes]
set h [lsearch $sys -home]
if { $h == -1 } {
return NULL
}
incr h
return [lindex $sys $h]
}
proc reduce_dups { nent ndp } {
upvar $nent nentries
upvar $ndp ndups
# If we are using a txnenv, assume it is using
# the default maximum number of locks, cut back
# so that we don't run out of locks. Reduce
# by 25% until we fit.
#
while { [expr $nentries * $ndups] > 5000 } {
set nentries [expr ($nentries / 4) * 3]
set ndups [expr ($ndups / 4) * 3]
}
}
proc getstats { statlist field } {
foreach pair $statlist {
set txt [lindex $pair 0]
if { [string equal $txt $field] == 1 } {
return [lindex $pair 1]
}
}
return -1
}
# Return the value for a particular field in a set of statistics.
# Works for regular db stat as well as env stats (log_stat,
# lock_stat, txn_stat, rep_stat, etc.).
proc stat_field { handle which_stat field } {
set stat [$handle $which_stat]
return [getstats $stat $field ]
}
proc big_endian { } {
global tcl_platform
set e $tcl_platform(byteOrder)
if { [string compare $e littleEndian] == 0 } {
return 0
} elseif { [string compare $e bigEndian] == 0 } {
return 1
} else {
error "FAIL: Unknown endianness $e"
}
}
# Check if this is a debug build. Use 'string equal' so we
# don't get fooled by debug_rop and debug_wop.
proc is_debug { } {
set conf [berkdb getconfig]
foreach item $conf {
if { [string equal $item "debug"] } {
return 1
}
}
return 0
}
proc adjust_logargs { logtype {lbufsize 0} } {
if { $logtype == "in-memory" } {
if { $lbufsize == 0 } {
set lbuf [expr 1 * [expr 1024 * 1024]]
set logargs " -log_inmemory -log_buffer $lbuf "
} else {
set logargs " -log_inmemory -log_buffer $lbufsize "
}
} elseif { $logtype == "on-disk" } {
set logargs ""
} else {
error "FAIL: unrecognized log type $logtype"
}
return $logargs
}
proc adjust_txnargs { logtype } {
if { $logtype == "in-memory" } {
set txnargs " -txn "
} elseif { $logtype == "on-disk" } {
set txnargs " -txn nosync "
} else {
error "FAIL: unrecognized log type $logtype"
}
return $txnargs
}
proc get_logfile { env where } {
# Open a log cursor.
set m_logc [$env log_cursor]
error_check_good m_logc [is_valid_logc $m_logc $env] TRUE
# Check that we're in the expected virtual log file.
if { $where == "first" } {
set rec [$m_logc get -first]
} else {
set rec [$m_logc get -last]
}
error_check_good cursor_close [$m_logc close] 0
set lsn [lindex $rec 0]
set log [lindex $lsn 0]
return $log
}
# Determine whether logs are in-mem or on-disk.
# This requires the existence of logs to work correctly.
proc check_log_location { env } {
if { [catch {get_logfile $env first} res] } {
puts "FAIL: env $env not configured for logging"
}
set inmemory [$env log_get_config inmemory]
set env_home [get_home $env]
set logfiles [glob -nocomplain $env_home/log.*]
if { $inmemory == 1 } {
error_check_good no_logs_on_disk [llength $logfiles] 0
} else {
error_check_bad logs_on_disk [llength $logfiles] 0
}
}
# Verify the logs.
# By default, if we do not specify the directory for temporary environment,
# the temporary databases will be in-memory, which is not good for test,
# Since there may be a lot of logs for verification, which makes the
# temporary databases very large.
proc verify_log { {env_dir $testdir} { tmp_dir lgverify_dir } \
{ mcachesize 10 } { cont 1 } } {
global encrypt
global passwd
global EXE
source ./include.tcl
set succ_patt {Log verification ended and SUCCEEDED}
if { $mcachesize == 0 } {
set mcachesize 10
}
set encarg ""
if { $encrypt != 0 } {
set encarg "-encryptaes $passwd"
}
set contarg ""
if { $cont == 1 } {
set contarg "-c"
}
if { $tmp_dir == ""} {
set tmp_dir "lgverify_dir"
}
file delete -force $tmp_dir
file mkdir $tmp_dir
puts -nonewline "Verifying log files .... "
set ret [catch {eval exec $util_path/db_log_verify {-C $mcachesize} \
$encarg $contarg {-h $testdir} {-H $tmp_dir} >& lgvrfy.log } msg ]
puts "done."
if {$ret} {
puts "FAIL:db_log_verify: $msg"
return 1
}
# Check if we could find the message for success.
set logf [open lgvrfy.log "r"]
set line {}
set found 0
while {[gets $logf line] >= 0} {
if {[regexp $succ_patt $line]} {
set found 1
break
}
}
close $logf
error_check_good log_verify $found 1
return 0
}
# This proc is to verify that all the keys in secondary
# exist in the foreign database.
proc verify_foreign {txn fdb sdb puterr} {
set fkeys {}
set fdbc [eval $fdb cursor $txn]
error_check_good check_fdbc [is_valid_cursor $fdbc $fdb] TRUE
for {set ret [$fdbc get -first]} {[llength $ret] > 0} \
{set ret [$fdbc get -next]} {
lappend fkeys [lindex [lindex $ret 0] 0]
}
error_check_good close_fdbc [$fdbc close] 0
set skeys {}
set sdbc [eval $sdb cursor $txn]
error_check_good check_sdbc [is_valid_cursor $sdbc $sdb] TRUE
for {set ret [$sdbc get -first]} {[llength $ret] > 0} \
{set ret [$sdbc get -nextnodup]} {
lappend skeys [lindex [lindex $ret 0] 0]
}
error_check_good close_sdbc [$sdbc close] 0
foreach fkey $fkeys {
set has_keys($fkey) 1
}
foreach skey $skeys {
if {![info exists has_keys($skey)]} {
if {$puterr} {
puts "FAIL: VERIFY_FOREIGN_BAD"
}
return 1
}
}
return 0
}
# Given the env and file name, verify that a given database is on-disk
# or in-memory as expected. If "db_on_disk" is 1, "databases_in_memory"
# is 0 and vice versa, so we use error_check_bad.
proc check_db_location { env { dbname "test.db" } { datadir "" } } {
global databases_in_memory
if { $datadir != "" } {
set env_home $datadir
} else {
set env_home [get_home $env]
}
set db_on_disk [file exists $env_home/$dbname]
error_check_bad db_location $db_on_disk $databases_in_memory
}
# If we have a private env, check that no region files are found on-disk.
proc no_region_files_on_disk { dir } {
set regionfiles [glob -nocomplain $dir/__db.???]
error_check_good regionfiles [llength $regionfiles] 0
global env_private
if { $env_private } {
set regionfiles [glob -nocomplain $dir/__db.???]
error_check_good regionfiles [llength $regionfiles] 0
}
}
proc find_valid_methods { test } {
global checking_valid_methods
global valid_methods
# To find valid methods, call the test with checking_valid_methods
# on. It doesn't matter what method we use for this call, so we
# arbitrarily pick btree.
#
set checking_valid_methods 1
set test_methods [$test btree]
set checking_valid_methods 0
if { $test_methods == "ALL" } {
return $valid_methods
} else {
return $test_methods
}
}
proc part {data} {
if { [string length $data] < 2 } {
return 0
}
binary scan $data s res
return $res
}
proc my_isalive { pid } {
source ./include.tcl
if {[catch {exec $KILL -0 $pid}]} {
return 0
}
return 1
}
Reference in a new issue Copy permalink