summaryrefslogtreecommitdiff
path: root/db/test/test.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'db/test/test.tcl')
-rw-r--r--db/test/test.tcl1297
1 files changed, 1297 insertions, 0 deletions
diff --git a/db/test/test.tcl b/db/test/test.tcl
new file mode 100644
index 000000000..7678f2fcb
--- /dev/null
+++ b/db/test/test.tcl
@@ -0,0 +1,1297 @@
+# See the file LICENSE for redistribution information.
+#
+# Copyright (c) 1996, 1997, 1998, 1999, 2000
+# Sleepycat Software. All rights reserved.
+#
+# $Id: test.tcl,v 11.114 2001/01/09 21:28:52 sue Exp $
+
+source ./include.tcl
+
+# Load DB's TCL API.
+load $tcllib
+
+if { [file exists $testdir] != 1 } {
+ file mkdir $testdir
+}
+
+global __debug_print
+global __debug_on
+global util_path
+
+#
+# Test if utilities work to figure out the path. Most systems
+# use ., but QNX has a problem with execvp of shell scripts which
+# causes it to break.
+#
+set stat [catch {exec ./db_printlog -?} ret]
+if { [string first "exec format error" $ret] != -1 } {
+ set util_path ./.libs
+} else {
+ set util_path .
+}
+set __debug_print 0
+set __debug_on 0
+
+# This is where the test numbering and parameters now live.
+source $test_path/testparams.tcl
+
+for { set i 1 } { $i <= $deadtests } {incr i} {
+ set name [format "dead%03d.tcl" $i]
+ source $test_path/$name
+}
+for { set i 1 } { $i <= $envtests } {incr i} {
+ set name [format "env%03d.tcl" $i]
+ source $test_path/$name
+}
+for { set i 1 } { $i <= $recdtests } {incr i} {
+ set name [format "recd%03d.tcl" $i]
+ source $test_path/$name
+}
+for { set i 1 } { $i <= $rpctests } {incr i} {
+ set name [format "rpc%03d.tcl" $i]
+ source $test_path/$name
+}
+for { set i 1 } { $i <= $rsrctests } {incr i} {
+ set name [format "rsrc%03d.tcl" $i]
+ source $test_path/$name
+}
+for { set i 1 } { $i <= $runtests } {incr i} {
+ set name [format "test%03d.tcl" $i]
+ # Test numbering may be sparse.
+ if { [file exists $test_path/$name] == 1 } {
+ source $test_path/$name
+ }
+}
+for { set i 1 } { $i <= $subdbtests } {incr i} {
+ set name [format "sdb%03d.tcl" $i]
+ source $test_path/$name
+}
+
+source $test_path/archive.tcl
+source $test_path/byteorder.tcl
+source $test_path/dbm.tcl
+source $test_path/hsearch.tcl
+source $test_path/join.tcl
+source $test_path/lock001.tcl
+source $test_path/lock002.tcl
+source $test_path/lock003.tcl
+source $test_path/log.tcl
+source $test_path/logtrack.tcl
+source $test_path/mpool.tcl
+source $test_path/mutex.tcl
+source $test_path/ndbm.tcl
+source $test_path/sdbtest001.tcl
+source $test_path/sdbtest002.tcl
+source $test_path/sdbutils.tcl
+source $test_path/testutils.tcl
+source $test_path/txn.tcl
+source $test_path/upgrade.tcl
+
+set dict $test_path/wordlist
+set alphabet "abcdefghijklmnopqrstuvwxyz"
+
+# Random number seed.
+global rand_init
+set rand_init 1013
+
+# Default record length and padding character for
+# fixed record length access method(s)
+set fixed_len 20
+set fixed_pad 0
+
+set recd_debug 0
+set log_log_record_types 0
+set ohandles {}
+
+# Set up any OS-specific values
+global tcl_platform
+set is_windows_test [is_substr $tcl_platform(os) "Win"]
+set is_hp_test [is_substr $tcl_platform(os) "HP-UX"]
+set is_qnx_test [is_substr $tcl_platform(os) "QNX"]
+
+# From here on out, test.tcl contains the procs that are used to
+# run all or part of the test suite.
+
+proc run_am { } {
+ global runtests
+ source ./include.tcl
+
+ fileremove -f ALL.OUT
+
+ # Access method tests.
+ #
+ # XXX
+ # Broken up into separate tclsh instantiations so we don't require
+ # so much memory.
+ foreach i "btree rbtree hash queue queueext recno frecno rrecno" {
+ puts "Running $i tests"
+ for { set j 1 } { $j <= $runtests } {incr j} {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ run_method -$i $j $j" >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: [format "test%03d" $j] $i"
+ close $o
+ }
+ }
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ subdb -$i 0 1" >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: subdb -$i test"
+ close $o
+ }
+ }
+}
+
+proc run_std { args } {
+ global runtests
+ global subdbtests
+ source ./include.tcl
+
+ set exflgs [eval extractflags $args]
+ set args [lindex $exflgs 0]
+ set flags [lindex $exflgs 1]
+
+ set display 1
+ set run 1
+ set am_only 0
+ set std_only 1
+ set rflags {--}
+ foreach f $flags {
+ switch $f {
+ A {
+ set std_only 0
+ }
+ m {
+ set am_only 1
+ puts "run_std: access method tests only."
+ }
+ n {
+ set display 1
+ set run 0
+ set rflags [linsert $rflags 0 "-n"]
+ }
+ }
+ }
+
+ if { $std_only == 1 } {
+ fileremove -f ALL.OUT
+
+ set o [open ALL.OUT a]
+ if { $run == 1 } {
+ puts -nonewline "Test suite run started at: "
+ puts [clock format [clock seconds] -format "%H:%M %D"]
+ puts [berkdb version -string]
+
+ puts -nonewline $o "Test suite run started at: "
+ puts $o [clock format [clock seconds] -format "%H:%M %D"]
+ puts $o [berkdb version -string]
+ }
+ close $o
+ }
+
+ set test_list {
+ {"environment" "env"}
+ {"archive" "archive"}
+ {"locking" "lock"}
+ {"logging" "log"}
+ {"memory pool" "mpool"}
+ {"mutex" "mutex"}
+ {"transaction" "txn"}
+ {"deadlock detection" "dead"}
+ {"subdatabase" "subdb_gen"}
+ {"byte-order" "byte"}
+ {"recno backing file" "rsrc"}
+ {"DBM interface" "dbm"}
+ {"NDBM interface" "ndbm"}
+ {"Hsearch interface" "hsearch"}
+ }
+
+ if { $am_only == 0 } {
+
+ foreach pair $test_list {
+ set msg [lindex $pair 0]
+ set cmd [lindex $pair 1]
+ puts "Running $msg tests"
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; r $rflags $cmd" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: $cmd test"
+ close $o
+ }
+ }
+
+ # Run recovery tests.
+ #
+ # XXX These too are broken into separate tclsh instantiations
+ # so we don't require so much memory, but I think it's cleaner
+ # and more useful to do it down inside proc r than here,
+ # since "r recd" gets done a lot and needs to work.
+ puts "Running recovery tests"
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ r $rflags recd" >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: recd test"
+ close $o
+ }
+
+ # Run join test
+ #
+ # XXX
+ # Broken up into separate tclsh instantiations so we don't
+ # require so much memory.
+ puts "Running join test"
+ foreach i "join1 join2 join3 join4 join5 join6" {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; r $rflags $i" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: $i test"
+ close $o
+ }
+ }
+ }
+
+ # Access method tests.
+ #
+ # XXX
+ # Broken up into separate tclsh instantiations so we don't require
+ # so much memory.
+ foreach i "btree rbtree hash queue queueext recno frecno rrecno" {
+ puts "Running $i tests"
+ for { set j 1 } { $j <= $runtests } {incr j} {
+ if { $run == 0 } {
+ set o [open ALL.OUT a]
+ run_method -$i $j $j $display $run $o
+ close $o
+ }
+ if { $run } {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ run_method -$i $j $j $display $run" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o \
+ "FAIL: [format "test%03d" $j] $i"
+ close $o
+ }
+ }
+ }
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ subdb -$i $display $run" >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: subdb -$i test"
+ close $o
+ }
+ }
+
+ # If not actually running, no need to check for failure.
+ # If running in the context of the larger 'run_all' we don't
+ # check for failure here either.
+ if { $run == 0 || $std_only == 0 } {
+ return
+ }
+
+ set failed 0
+ set o [open ALL.OUT r]
+ while { [gets $o line] >= 0 } {
+ if { [regexp {^FAIL} $line] != 0 } {
+ set failed 1
+ }
+ }
+ close $o
+ set o [open ALL.OUT a]
+ if { $failed == 0 } {
+ puts "Regression Tests Succeeded"
+ puts $o "Regression Tests Succeeded"
+ } else {
+ puts "Regression Tests Failed; see ALL.OUT for log"
+ puts $o "Regression Tests Failed"
+ }
+
+ puts -nonewline "Test suite run completed at: "
+ puts [clock format [clock seconds] -format "%H:%M %D"]
+ puts -nonewline $o "Test suite run completed at: "
+ puts $o [clock format [clock seconds] -format "%H:%M %D"]
+ close $o
+}
+
+proc r { args } {
+ global envtests
+ global recdtests
+ global subdbtests
+ global deadtests
+ source ./include.tcl
+
+ set exflgs [eval extractflags $args]
+ set args [lindex $exflgs 0]
+ set flags [lindex $exflgs 1]
+
+ set display 1
+ set run 1
+ set saveflags "--"
+ foreach f $flags {
+ switch $f {
+ n {
+ set display 1
+ set run 0
+ set saveflags "-n $saveflags"
+ }
+ }
+ }
+
+ if {[catch {
+ set l [ lindex $args 0 ]
+ switch $l {
+ archive {
+ if { $display } {
+ puts "eval archive [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval archive [lrange $args 1 end]
+ }
+ }
+ byte {
+ foreach method \
+ "-hash -btree -recno -queue -queueext -frecno" {
+ if { $display } {
+ puts "byteorder $method"
+ }
+ if { $run } {
+ check_handles
+ byteorder $method
+ }
+ }
+ }
+ dbm {
+ if { $display } {
+ puts "dbm"
+ }
+ if { $run } {
+ check_handles
+ dbm
+ }
+ }
+ dead {
+ for { set i 1 } { $i <= $deadtests } \
+ { incr i } {
+ if { $display } {
+ puts "eval dead00$i\
+ [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval dead00$i\
+ [lrange $args 1 end]
+ }
+ }
+ }
+ env {
+ for { set i 1 } { $i <= $envtests } {incr i} {
+ if { $display } {
+ puts "eval env00$i"
+ }
+ if { $run } {
+ check_handles
+ eval env00$i
+ }
+ }
+ }
+ hsearch {
+ if { $display } { puts "hsearch" }
+ if { $run } {
+ check_handles
+ hsearch
+ }
+ }
+ join {
+ eval r $saveflags join1
+ eval r $saveflags join2
+ eval r $saveflags join3
+ eval r $saveflags join4
+ eval r $saveflags join5
+ eval r $saveflags join6
+ }
+ join1 {
+ if { $display } { puts jointest }
+ if { $run } {
+ check_handles
+ jointest
+ }
+ }
+ joinbench {
+ puts "[timestamp]"
+ eval r $saveflags join1
+ eval r $saveflags join2
+ puts "[timestamp]"
+ }
+ join2 {
+ if { $display } { puts "jointest 512" }
+ if { $run } {
+ check_handles
+ jointest 512
+ }
+ }
+ join3 {
+ if { $display } {
+ puts "jointest 8192 0 -join_item"
+ }
+ if { $run } {
+ check_handles
+ jointest 8192 0 -join_item
+ }
+ }
+ join4 {
+ if { $display } { puts "jointest 8192 2" }
+ if { $run } {
+ check_handles
+ jointest 8192 2
+ }
+ }
+ join5 {
+ if { $display } { puts "jointest 8192 3" }
+ if { $run } {
+ check_handles
+ jointest 8192 3
+ }
+ }
+ join6 {
+ if { $display } { puts "jointest 512 3" }
+ if { $run } {
+ check_handles
+ jointest 512 3
+ }
+ }
+ lock {
+ if { $display } {
+ puts \
+ "eval locktest [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval locktest [lrange $args 1 end]
+ }
+ }
+ log {
+ if { $display } {
+ puts "eval logtest [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval logtest [lrange $args 1 end]
+ }
+ }
+ mpool {
+ eval r $saveflags mpool1
+ eval r $saveflags mpool2
+ eval r $saveflags mpool3
+ }
+ mpool1 {
+ if { $display } {
+ puts "eval mpool [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval mpool [lrange $args 1 end]
+ }
+ }
+ mpool2 {
+ if { $display } {
+ puts "eval mpool\
+ -mem system [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval mpool\
+ -mem system [lrange $args 1 end]
+ }
+ }
+ mpool3 {
+ if { $display } {
+ puts "eval mpool\
+ -mem private [lrange $args 1 end]"
+ }
+ if { $run } {
+ eval mpool\
+ -mem private [lrange $args 1 end]
+ }
+ }
+ mutex {
+ if { $display } {
+ puts "eval mutex [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval mutex [lrange $args 1 end]
+ }
+ }
+ ndbm {
+ if { $display } { puts ndbm }
+ if { $run } {
+ check_handles
+ ndbm
+ }
+ }
+ recd {
+ if { $display } { puts run_recds }
+ if { $run } {
+ check_handles
+ run_recds
+ }
+ }
+ rpc {
+ # RPC must be run as one unit due to server,
+ # so just print "r rpc" in the display case.
+ if { $display } { puts "r rpc" }
+ if { $run } {
+ check_handles
+ eval rpc001
+ check_handles
+ eval rpc002
+ if { [catch {run_rpcmethod -txn} ret]\
+ != 0 } {
+ puts $ret
+ }
+ foreach method \
+ "hash queue queueext recno frecno rrecno rbtree btree" {
+ if { [catch {run_rpcmethod \
+ -$method} ret] != 0 } {
+ puts $ret
+ }
+ }
+ }
+ }
+ rsrc {
+ if { $display } { puts "rsrc001\nrsrc002" }
+ if { $run } {
+ check_handles
+ rsrc001
+ check_handles
+ rsrc002
+ }
+ }
+ subdb {
+ eval r $saveflags subdb_gen
+
+ foreach method \
+ "btree rbtree hash queue queueext recno frecno rrecno" {
+ check_handles
+ eval subdb -$method $display $run
+ }
+ }
+ subdb_gen {
+ if { $display } {
+ puts "subdbtest001 ; verify_dir"
+ puts "subdbtest002 ; verify_dir"
+ }
+ if { $run } {
+ check_handles
+ eval subdbtest001
+ verify_dir
+ check_handles
+ eval subdbtest002
+ verify_dir
+ }
+ }
+ txn {
+ if { $display } {
+ puts "txntest [lrange $args 1 end]"
+ }
+ if { $run } {
+ check_handles
+ eval txntest [lrange $args 1 end]
+ }
+ }
+
+ btree -
+ rbtree -
+ hash -
+ queue -
+ queueext -
+ recno -
+ frecno -
+ rrecno {
+ eval run_method [lindex $args 0] \
+ 1 0 $display $run [lrange $args 1 end]
+ }
+
+ default {
+ error \
+ "FAIL:[timestamp] r: $args: unknown command"
+ }
+ }
+ flush stdout
+ flush stderr
+ } res] != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp] r: $args: $theError"
+ } else {
+ error $theError;
+ }
+ }
+}
+
+proc run_method { method {start 1} {stop 0} {display 0} {run 1} \
+ { outfile stdout } args } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global runtests
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $runtests
+ }
+ if { $run == 1 } {
+ puts $outfile "run_method: $method $start $stop $args"
+ }
+
+ if {[catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ set name [format "test%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Test%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ if { $display } {
+ puts -nonewline $outfile "eval $name $method"
+ puts -nonewline $outfile " $parms($name) $args"
+ puts $outfile " ; verify_dir $testdir \"\" 1"
+ }
+ if { $run } {
+ check_handles $outfile
+ puts $outfile "[timestamp]"
+ eval $name $method $parms($name) $args
+ if { $__debug_print != 0 } {
+ puts $outfile ""
+ }
+ # verify all databases the test leaves behind
+ verify_dir $testdir "" 1
+ if { $__debug_on != 0 } {
+ debug
+ }
+ }
+ flush stdout
+ flush stderr
+ }
+ } res] != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_method: $method $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+}
+
+proc run_rpcmethod { type {start 1} {stop 0} {largs ""} } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global runtests
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $runtests
+ }
+ puts "run_rpcmethod: $type $start $stop $largs"
+
+ set save_largs $largs
+ if { [string compare $rpc_server "localhost"] == 0 } {
+ set dpid [exec $util_path/berkeley_db_svc -h $rpc_testdir &]
+ } else {
+ set dpid [exec rsh $rpc_server $rpc_path/berkeley_db_svc \
+ -h $rpc_testdir &]
+ }
+ puts "\tRun_rpcmethod.a: starting server, pid $dpid"
+ tclsleep 2
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+
+ set home [file tail $rpc_testdir]
+
+ set txn ""
+ set use_txn 0
+ if { [string first "txn" $type] != -1 } {
+ set use_txn 1
+ }
+ if { $use_txn == 1 } {
+ if { $start == 1 } {
+ set ntxns 32
+ } else {
+ set ntxns $start
+ }
+ set i 1
+ check_handles
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+ set env [eval {berkdb env -create -mode 0644 -home $home \
+ -server $rpc_server -client_timeout 10000} -txn]
+ error_check_good env_open [is_valid_env $env] TRUE
+
+ set stat [catch {eval txn001_suba $ntxns $env} res]
+ if { $stat == 0 } {
+ set stat [catch {eval txn001_subb $ntxns $env} res]
+ }
+ error_check_good envclose [$env close] 0
+ } else {
+ set stat [catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ check_handles
+ set name [format "test%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Test%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+ #
+ # Set server cachesize to 1Mb. Otherwise some
+ # tests won't fit (like test084 -btree).
+ #
+ set env [eval {berkdb env -create -mode 0644 \
+ -home $home -server $rpc_server \
+ -client_timeout 10000 \
+ -cachesize {0 1048576 1} }]
+ error_check_good env_open \
+ [is_valid_env $env] TRUE
+ append largs " -env $env "
+
+ puts "[timestamp]"
+ eval $name $type $parms($name) $largs
+ if { $__debug_print != 0 } {
+ puts ""
+ }
+ if { $__debug_on != 0 } {
+ debug
+ }
+ flush stdout
+ flush stderr
+ set largs $save_largs
+ error_check_good envclose [$env close] 0
+ }
+ } res]
+ }
+ if { $stat != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ exec $KILL $dpid
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_rpcmethod: $type $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+ exec $KILL $dpid
+
+}
+
+proc run_rpcnoserver { type {start 1} {stop 0} {largs ""} } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global runtests
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $runtests
+ }
+ puts "run_rpcnoserver: $type $start $stop $largs"
+
+ set save_largs $largs
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+ set home [file tail $rpc_testdir]
+
+ set txn ""
+ set use_txn 0
+ if { [string first "txn" $type] != -1 } {
+ set use_txn 1
+ }
+ if { $use_txn == 1 } {
+ if { $start == 1 } {
+ set ntxns 32
+ } else {
+ set ntxns $start
+ }
+ set i 1
+ check_handles
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+ set env [eval {berkdb env -create -mode 0644 -home $home \
+ -server $rpc_server -client_timeout 10000} -txn]
+ error_check_good env_open [is_valid_env $env] TRUE
+
+ set stat [catch {eval txn001_suba $ntxns $env} res]
+ if { $stat == 0 } {
+ set stat [catch {eval txn001_subb $ntxns $env} res]
+ }
+ error_check_good envclose [$env close] 0
+ } else {
+ set stat [catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ check_handles
+ set name [format "test%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Test%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ remote_cleanup $rpc_server $rpc_testdir $testdir
+ #
+ # Set server cachesize to 1Mb. Otherwise some
+ # tests won't fit (like test084 -btree).
+ #
+ set env [eval {berkdb env -create -mode 0644 \
+ -home $home -server $rpc_server \
+ -client_timeout 10000 \
+ -cachesize {0 1048576 1} }]
+ error_check_good env_open \
+ [is_valid_env $env] TRUE
+ append largs " -env $env "
+
+ puts "[timestamp]"
+ eval $name $type $parms($name) $largs
+ if { $__debug_print != 0 } {
+ puts ""
+ }
+ if { $__debug_on != 0 } {
+ debug
+ }
+ flush stdout
+ flush stderr
+ set largs $save_largs
+ error_check_good envclose [$env close] 0
+ }
+ } res]
+ }
+ if { $stat != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_rpcnoserver: $type $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+
+}
+
+#
+# Run method tests in one environment. (As opposed to run_envmethod1
+# which runs each test in its own, new environment.)
+#
+proc run_envmethod { type {start 1} {stop 0} {largs ""} } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global runtests
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $runtests
+ }
+ puts "run_envmethod: $type $start $stop $largs"
+
+ set save_largs $largs
+ env_cleanup $testdir
+ set txn ""
+ set stat [catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ check_handles
+ set env [eval {berkdb env -create -mode 0644 \
+ -home $testdir}]
+ error_check_good env_open [is_valid_env $env] TRUE
+ append largs " -env $env "
+
+ puts "[timestamp]"
+ set name [format "test%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Test%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ eval $name $type $parms($name) $largs
+ if { $__debug_print != 0 } {
+ puts ""
+ }
+ if { $__debug_on != 0 } {
+ debug
+ }
+ flush stdout
+ flush stderr
+ set largs $save_largs
+ error_check_good envclose [$env close] 0
+ error_check_good envremove [berkdb envremove \
+ -home $testdir] 0
+ }
+ } res]
+ if { $stat != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_envmethod: $type $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+
+}
+
+proc subdb { method display run {outfile stdout} args} {
+ global subdbtests testdir
+ global parms
+
+ for { set i 1 } {$i <= $subdbtests} {incr i} {
+ set name [format "subdb%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Subdb%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ if { $display } {
+ puts -nonewline $outfile "eval $name $method"
+ puts -nonewline $outfile " $parms($name) $args;"
+ puts $outfile "verify_dir $testdir \"\" 1"
+ }
+ if { $run } {
+ check_handles $outfile
+ eval $name $method $parms($name) $args
+ verify_dir $testdir "" 1
+ }
+ flush stdout
+ flush stderr
+ }
+}
+
+proc run_recd { method {start 1} {stop 0} args } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global recdtests
+ global log_log_record_types
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $recdtests
+ }
+ puts "run_recd: $method $start $stop $args"
+
+ if {[catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ check_handles
+ puts "[timestamp]"
+ set name [format "recd%03d" $i]
+ # By redirecting stdout to stdout, we make exec
+ # print output rather than simply returning it.
+ exec $tclsh_path << "source $test_path/test.tcl; \
+ set log_log_record_types $log_log_record_types; \
+ eval $name $method" >@ stdout
+ if { $__debug_print != 0 } {
+ puts ""
+ }
+ if { $__debug_on != 0 } {
+ debug
+ }
+ flush stdout
+ flush stderr
+ }
+ } res] != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_recd: $method $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+}
+
+proc run_recds { } {
+ global log_log_record_types
+
+ set log_log_record_types 1
+ logtrack_init
+ foreach method \
+ "btree rbtree hash queue queueext recno frecno rrecno" {
+ check_handles
+ if { [catch \
+ {run_recd -$method} ret ] != 0 } {
+ puts $ret
+ }
+ }
+ logtrack_summary
+ set log_log_record_types 0
+}
+
+proc run_all { args } {
+ global runtests
+ global subdbtests
+ source ./include.tcl
+
+ fileremove -f ALL.OUT
+
+ set exflgs [eval extractflags $args]
+ set flags [lindex $exflgs 1]
+ set display 1
+ set run 1
+ set am_only 0
+ set rflags {--}
+ foreach f $flags {
+ switch $f {
+ m {
+ set am_only 1
+ }
+ n {
+ set display 1
+ set run 0
+ set rflags [linsert $rflags 0 "-n"]
+ }
+ }
+ }
+
+ set o [open ALL.OUT a]
+ if { $run == 1 } {
+ puts -nonewline "Test suite run started at: "
+ puts [clock format [clock seconds] -format "%H:%M %D"]
+ puts [berkdb version -string]
+
+ puts -nonewline $o "Test suite run started at: "
+ puts $o [clock format [clock seconds] -format "%H:%M %D"]
+ puts $o [berkdb version -string]
+ }
+ close $o
+ #
+ # First run standard tests. Send in a -A to let run_std know
+ # that it is part of the "run_all" run, so that it doesn't
+ # print out start/end times.
+ #
+ lappend args -A
+ eval {run_std} $args
+
+ set test_pagesizes { 512 8192 65536 }
+ set args [lindex $exflgs 0]
+ set save_args $args
+
+ foreach pgsz $test_pagesizes {
+ set args $save_args
+ append args " -pagesize $pgsz"
+ if { $am_only == 0 } {
+ # Run recovery tests.
+ #
+ # XXX These too are broken into separate tclsh
+ # instantiations so we don't require so much
+ # memory, but I think it's cleaner
+ # and more useful to do it down inside proc r than here,
+ # since "r recd" gets done a lot and needs to work.
+ puts "Running recovery tests with pagesize $pgsz"
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ r $rflags recd $args" >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: recd test"
+ close $o
+ }
+ }
+
+ # Access method tests.
+ #
+ # XXX
+ # Broken up into separate tclsh instantiations so
+ # we don't require so much memory.
+ foreach i \
+ "btree rbtree hash queue queueext recno frecno rrecno" {
+ puts "Running $i tests with pagesize $pgsz"
+ for { set j 1 } { $j <= $runtests } {incr j} {
+ if { $run == 0 } {
+ set o [open ALL.OUT a]
+ run_method -$i $j $j $display \
+ $run $o $args
+ close $o
+ }
+ if { $run } {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ run_method -$i $j $j $display \
+ $run stdout $args" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o \
+ "FAIL: [format \
+ "test%03d" $j] $i"
+ close $o
+ }
+ }
+ }
+
+ #
+ # Run subdb tests with varying pagesizes too.
+ #
+ if { $run == 0 } {
+ set o [open ALL.OUT a]
+ subdb -$i $display $run $o $args
+ close $o
+ }
+ if { $run == 1 } {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ subdb -$i $display $run stdout $args" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o "FAIL: subdb -$i test"
+ close $o
+ }
+ }
+ }
+ }
+ set args $save_args
+ #
+ # Run access method tests at default page size in one env.
+ #
+ foreach i "btree rbtree hash queue queueext recno frecno rrecno" {
+ puts "Running $i tests in an env"
+ if { $run == 0 } {
+ set o [open ALL.OUT a]
+ run_envmethod1 -$i 1 $runtests $display \
+ $run $o $args
+ close $o
+ }
+ if { $run } {
+ if [catch {exec $tclsh_path \
+ << "source $test_path/test.tcl; \
+ run_envmethod1 -$i 1 $runtests $display \
+ $run stdout $args" \
+ >>& ALL.OUT } res] {
+ set o [open ALL.OUT a]
+ puts $o \
+ "FAIL: run_envmethod1 $i"
+ close $o
+ }
+ }
+ }
+
+ # If not actually running, no need to check for failure.
+ if { $run == 0 } {
+ return
+ }
+
+ set failed 0
+ set o [open ALL.OUT r]
+ while { [gets $o line] >= 0 } {
+ if { [regexp {^FAIL} $line] != 0 } {
+ set failed 1
+ }
+ }
+ close $o
+ set o [open ALL.OUT a]
+ if { $failed == 0 } {
+ puts "Regression Tests Succeeded"
+ puts $o "Regression Tests Succeeded"
+ } else {
+ puts "Regression Tests Failed; see ALL.OUT for log"
+ puts $o "Regression Tests Failed"
+ }
+
+ puts -nonewline "Test suite run completed at: "
+ puts [clock format [clock seconds] -format "%H:%M %D"]
+ puts -nonewline $o "Test suite run completed at: "
+ puts $o [clock format [clock seconds] -format "%H:%M %D"]
+ close $o
+}
+
+#
+# Run method tests in one environment. (As opposed to run_envmethod
+# which runs each test in its own, new environment.)
+#
+proc run_envmethod1 { method {start 1} {stop 0} {display 0} {run 1} \
+ { outfile stdout } args } {
+ global __debug_on
+ global __debug_print
+ global parms
+ global runtests
+ source ./include.tcl
+
+ if { $stop == 0 } {
+ set stop $runtests
+ }
+ if { $run == 1 } {
+ puts "run_envmethod1: $method $start $stop $args"
+ }
+
+ set txn ""
+ if { $run == 1 } {
+ check_handles
+ env_cleanup $testdir
+ error_check_good envremove [berkdb envremove -home $testdir] 0
+ set env [eval {berkdb env -create -mode 0644 -home $testdir}]
+ error_check_good env_open [is_valid_env $env] TRUE
+ append largs " -env $env "
+ }
+
+ set stat [catch {
+ for { set i $start } { $i <= $stop } {incr i} {
+ set name [format "test%03d" $i]
+ if { [info exists parms($name)] != 1 } {
+ puts "[format Test%03d $i] disabled in\
+ testparams.tcl; skipping."
+ continue
+ }
+ if { $display } {
+ puts -nonewline $outfile "eval $name $method"
+ puts -nonewline $outfile " $parms($name) $args"
+ puts $outfile " ; verify_dir $testdir \"\" 1"
+ }
+ if { $run } {
+ check_handles $outfile
+ puts $outfile "[timestamp]"
+ eval $name $method $parms($name) $largs
+ if { $__debug_print != 0 } {
+ puts $outfile ""
+ }
+ if { $__debug_on != 0 } {
+ debug
+ }
+ }
+ flush stdout
+ flush stderr
+ }
+ } res]
+ if { $run == 1 } {
+ error_check_good envclose [$env close] 0
+ }
+ if { $stat != 0} {
+ global errorInfo;
+
+ set fnl [string first "\n" $errorInfo]
+ set theError [string range $errorInfo 0 [expr $fnl - 1]]
+ if {[string first FAIL $errorInfo] == -1} {
+ error "FAIL:[timestamp]\
+ run_envmethod1: $method $i: $theError"
+ } else {
+ error $theError;
+ }
+ }
+
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 19:55:04 +0000