MySQL数据库

开发平台：
Visual C++

test.tcl：源码内容
							# 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 "rsrc001nrsrc002" }
				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;
		}
	}
}

						