mirror of
https://github.com/berkeleydb/libdb.git
synced 2024-11-16 17:16:25 +00:00
2924 lines
78 KiB
Tcl
2924 lines
78 KiB
Tcl
# See the file LICENSE for redistribution information.
|
|
#
|
|
# Copyright (c) 2001, 2011 Oracle and/or its affiliates. All rights reserved.
|
|
#
|
|
# $Id$
|
|
#
|
|
# Replication testing utilities
|
|
|
|
# Environment handle for the env containing the replication "communications
|
|
# structure" (really a CDB environment).
|
|
|
|
# The test environment consists of a queue and a # directory (environment)
|
|
# per replication site. The queue is used to hold messages destined for a
|
|
# particular site and the directory will contain the environment for the
|
|
# site. So the environment looks like:
|
|
# $testdir
|
|
# ___________|______________________________
|
|
# / | \ \
|
|
# MSGQUEUEDIR MASTERDIR CLIENTDIR.0 ... CLIENTDIR.N-1
|
|
# | | ... |
|
|
# 1 2 .. N+1
|
|
#
|
|
# The master is site 1 in the MSGQUEUEDIR and clients 1-N map to message
|
|
# queues 2 - N+1.
|
|
#
|
|
# The globals repenv(1-N) contain the environment handles for the sites
|
|
# with a given id (i.e., repenv(1) is the master's environment.
|
|
|
|
|
|
# queuedbs is an array of DB handles, one per machine ID/machine ID pair,
|
|
# for the databases that contain messages from one machine to another.
|
|
# We omit the cases where the "from" and "to" machines are the same.
|
|
#
|
|
global queuedbs
|
|
global machids
|
|
global perm_response_list
|
|
set perm_response_list {}
|
|
global perm_sent_list
|
|
set perm_sent_list {}
|
|
global electable_pri
|
|
set electable_pri 5
|
|
set drop 0
|
|
global anywhere
|
|
set anywhere 0
|
|
|
|
global rep_verbose
|
|
set rep_verbose 0
|
|
global verbose_type
|
|
set verbose_type "rep"
|
|
|
|
# To run a replication test with verbose messages, type
|
|
# 'run_verbose' and then the usual test command string enclosed
|
|
# in double quotes or curly braces. For example:
|
|
#
|
|
# run_verbose "rep001 btree"
|
|
#
|
|
# run_verbose {run_repmethod btree test001}
|
|
#
|
|
# To run a replication test with one of the subsets of verbose
|
|
# messages, use the same syntax with 'run_verbose_elect',
|
|
# 'run_verbose_lease', etc.
|
|
|
|
proc run_verbose { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_elect { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_elect"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_lease { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_lease"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_misc { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_misc"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_msgs { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_msgs"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_sync { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_sync"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_test { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "rep_test"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verbose_repmgr_misc { commandstring } {
|
|
global verbose_type
|
|
set verbose_type "repmgr_misc"
|
|
run_verb $commandstring
|
|
}
|
|
|
|
proc run_verb { commandstring } {
|
|
global rep_verbose
|
|
global verbose_type
|
|
|
|
set rep_verbose 1
|
|
if { [catch {
|
|
eval $commandstring
|
|
flush stdout
|
|
flush stderr
|
|
} res] != 0 } {
|
|
global errorInfo
|
|
|
|
set rep_verbose 0
|
|
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_verbose: $commandstring: $theError"
|
|
} else {
|
|
error $theError;
|
|
}
|
|
}
|
|
set rep_verbose 0
|
|
}
|
|
|
|
# Databases are on-disk by default for replication testing.
|
|
# Some replication tests have been converted to run with databases
|
|
# in memory instead.
|
|
|
|
global databases_in_memory
|
|
set databases_in_memory 0
|
|
|
|
proc run_inmem_db { test method } {
|
|
run_inmem $test $method 1 0 0 0
|
|
}
|
|
|
|
# Replication files are on-disk by default for replication testing.
|
|
# Some replication tests have been converted to run with rep files
|
|
# in memory instead.
|
|
|
|
global repfiles_in_memory
|
|
set repfiles_in_memory 0
|
|
|
|
proc run_inmem_rep { test method } {
|
|
run_inmem $test $method 0 0 1 0
|
|
}
|
|
|
|
# Region files are on-disk by default for replication testing.
|
|
# Replication tests can force the region files in-memory by setting
|
|
# the -private flag when opening an env.
|
|
|
|
global env_private
|
|
set env_private 0
|
|
|
|
proc run_env_private { test method } {
|
|
global test_names
|
|
|
|
if { [is_substr $test_names(skip_for_env_private) $test] == 1 } {
|
|
puts "Test $test is not set up to use private envs."
|
|
return
|
|
} else {
|
|
run_inmem $test $method 0 0 0 1
|
|
}
|
|
}
|
|
|
|
# Logs are on-disk by default for replication testing.
|
|
# Mixed-mode log testing provides a mixture of on-disk and
|
|
# in-memory logging, or even all in-memory. When testing on a
|
|
# 1-master/1-client test, we try all four options. On a test
|
|
# with more clients, we still try four options, randomly
|
|
# selecting whether the later clients are on-disk or in-memory.
|
|
#
|
|
|
|
global mixed_mode_logging
|
|
set mixed_mode_logging 0
|
|
|
|
proc create_logsets { nsites } {
|
|
global mixed_mode_logging
|
|
global logsets
|
|
global rand_init
|
|
|
|
error_check_good set_random_seed [berkdb srand $rand_init] 0
|
|
if { $mixed_mode_logging == 0 || $mixed_mode_logging == 2 } {
|
|
if { $mixed_mode_logging == 0 } {
|
|
set logmode "on-disk"
|
|
} else {
|
|
set logmode "in-memory"
|
|
}
|
|
set loglist {}
|
|
for { set i 0 } { $i < $nsites } { incr i } {
|
|
lappend loglist $logmode
|
|
}
|
|
set logsets [list $loglist]
|
|
}
|
|
if { $mixed_mode_logging == 1 } {
|
|
set set1 {on-disk on-disk}
|
|
set set2 {on-disk in-memory}
|
|
set set3 {in-memory on-disk}
|
|
set set4 {in-memory in-memory}
|
|
|
|
# Start with nsites at 2 since we already set up
|
|
# the master and first client.
|
|
for { set i 2 } { $i < $nsites } { incr i } {
|
|
foreach set { set1 set2 set3 set4 } {
|
|
if { [berkdb random_int 0 1] == 0 } {
|
|
lappend $set "on-disk"
|
|
} else {
|
|
lappend $set "in-memory"
|
|
}
|
|
}
|
|
}
|
|
set logsets [list $set1 $set2 $set3 $set4]
|
|
}
|
|
return $logsets
|
|
}
|
|
|
|
proc run_inmem_log { test method } {
|
|
run_inmem $test $method 0 1 0 0
|
|
}
|
|
|
|
# Run_mixedmode_log is a little different from the other run_inmem procs:
|
|
# it provides a mixture of in-memory and on-disk logging on the different
|
|
# hosts in a replication group.
|
|
proc run_mixedmode_log { test method {display 0} {run 1} \
|
|
{outfile stdout} {largs ""} } {
|
|
global mixed_mode_logging
|
|
set mixed_mode_logging 1
|
|
|
|
set prefix [string range $test 0 2]
|
|
if { $prefix != "rep" } {
|
|
puts "Skipping mixed-mode log testing for non-rep test."
|
|
set mixed_mode_logging 0
|
|
return
|
|
}
|
|
|
|
eval run_method $method $test $display $run $outfile $largs
|
|
|
|
# Reset to default values after run.
|
|
set mixed_mode_logging 0
|
|
}
|
|
|
|
# The procs run_inmem_db, run_inmem_log, run_inmem_rep, and run_env_private
|
|
# put databases, logs, rep files, or region files in-memory. (Setting up
|
|
# an env with the -private flag puts region files in memory.)
|
|
# The proc run_inmem allows you to put any or all of these in-memory
|
|
# at the same time.
|
|
|
|
proc run_inmem { test method\
|
|
{dbinmem 1} {logsinmem 1} {repinmem 1} {envprivate 1} } {
|
|
|
|
set prefix [string range $test 0 2]
|
|
if { $prefix != "rep" } {
|
|
puts "Skipping in-memory testing for non-rep test."
|
|
return
|
|
}
|
|
global databases_in_memory
|
|
global mixed_mode_logging
|
|
global repfiles_in_memory
|
|
global env_private
|
|
global test_names
|
|
|
|
if { $dbinmem } {
|
|
if { [is_substr $test_names(skip_for_inmem_db) $test] == 1 } {
|
|
puts "Test $test does not support in-memory databases."
|
|
puts "Putting databases on-disk."
|
|
set databases_in_memory 0
|
|
} else {
|
|
set databases_in_memory 1
|
|
}
|
|
}
|
|
if { $logsinmem } {
|
|
set mixed_mode_logging 2
|
|
}
|
|
if { $repinmem } {
|
|
set repfiles_in_memory 1
|
|
}
|
|
if { $envprivate } {
|
|
set env_private 1
|
|
}
|
|
|
|
if { [catch {eval run_method $method $test} res] } {
|
|
set databases_in_memory 0
|
|
set mixed_mode_logging 0
|
|
set repfiles_in_memory 0
|
|
set env_private 0
|
|
puts "FAIL: $res"
|
|
}
|
|
|
|
set databases_in_memory 0
|
|
set mixed_mode_logging 0
|
|
set repfiles_in_memory 0
|
|
set env_private 0
|
|
}
|
|
|
|
# The proc run_diskless runs run_inmem with its default values.
|
|
# It's useful to have this name to remind us of its testing purpose,
|
|
# which is to mimic a diskless host.
|
|
|
|
proc run_diskless { test method } {
|
|
run_inmem $test $method 1 1 1 1
|
|
}
|
|
|
|
# Open the master and client environments; store these in the global repenv
|
|
# Return the master's environment: "-env masterenv"
|
|
proc repl_envsetup { envargs largs test {nclients 1} {droppct 0} { oob 0 } } {
|
|
source ./include.tcl
|
|
global clientdir
|
|
global drop drop_msg
|
|
global masterdir
|
|
global repenv
|
|
global rep_verbose
|
|
global verbose_type
|
|
|
|
set verbargs ""
|
|
if { $rep_verbose == 1 } {
|
|
set verbargs " -verbose {$verbose_type on}"
|
|
}
|
|
|
|
env_cleanup $testdir
|
|
|
|
replsetup $testdir/MSGQUEUEDIR
|
|
|
|
set masterdir $testdir/MASTERDIR
|
|
file mkdir $masterdir
|
|
if { $droppct != 0 } {
|
|
set drop 1
|
|
set drop_msg [expr 100 / $droppct]
|
|
} else {
|
|
set drop 0
|
|
}
|
|
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
set clientdir($i) $testdir/CLIENTDIR.$i
|
|
file mkdir $clientdir($i)
|
|
}
|
|
|
|
# Some tests that use a small db pagesize need a small
|
|
# mpool pagesize as well -- otherwise we'll run out of
|
|
# mutexes. First determine the natural pagesize, so
|
|
# that can be used in the normal case, then adjust where
|
|
# needed.
|
|
|
|
set env [berkdb_env -create -home $testdir]
|
|
set pagesize [$env get_mp_pagesize]
|
|
error_check_good env_close [$env close] 0
|
|
berkdb envremove -home $testdir
|
|
|
|
set small_pagesize_tests [list test035 test096 test112 test113 test114]
|
|
if { [lsearch -exact $small_pagesize_tests $test] != -1 } {
|
|
set pagesize 512
|
|
}
|
|
|
|
# Open a master.
|
|
repladd 1
|
|
#
|
|
# Set log smaller than default to force changing files,
|
|
# but big enough so that the tests that use binary files
|
|
# as keys/data can run. Increase the size of the log region --
|
|
# sdb004 needs this, now that subdatabase names are stored
|
|
# in the env region.
|
|
#
|
|
set logmax [expr 3 * 1024 * 1024]
|
|
set lockmax 40000
|
|
set logregion 2097152
|
|
|
|
set ma_cmd "berkdb_env_noerr -create -log_max $logmax $envargs \
|
|
-cachesize { 0 4194304 1 } -log_regionmax $logregion \
|
|
-lock_max_objects $lockmax -lock_max_locks $lockmax \
|
|
-errpfx $masterdir $verbargs -pagesize $pagesize \
|
|
-home $masterdir -txn nosync -rep_master -rep_transport \
|
|
\[list 1 replsend\]"
|
|
set masterenv [eval $ma_cmd]
|
|
error_check_good master_env [is_valid_env $masterenv] TRUE
|
|
set repenv(master) $masterenv
|
|
|
|
# Open clients
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
set envid [expr $i + 2]
|
|
repladd $envid
|
|
set cl_cmd "berkdb_env_noerr -create $envargs -txn nosync \
|
|
-cachesize { 0 10000000 0 } -log_regionmax $logregion \
|
|
-lock_max_objects $lockmax -lock_max_locks $lockmax \
|
|
-errpfx $clientdir($i) $verbargs -pagesize $pagesize \
|
|
-home $clientdir($i) -rep_client -rep_transport \
|
|
\[list $envid replsend\]"
|
|
set clientenv [eval $cl_cmd]
|
|
error_check_good client_env [is_valid_env $clientenv] TRUE
|
|
set repenv($i) $clientenv
|
|
}
|
|
set repenv($i) NULL
|
|
append largs " -env $masterenv "
|
|
|
|
# Process startup messages
|
|
repl_envprocq $test $nclients $oob
|
|
|
|
# Clobber replication's 30-second anti-archive timer, which
|
|
# will have been started by client sync-up internal init, in
|
|
# case the test we're about to run wants to do any log
|
|
# archiving, or database renaming and/or removal.
|
|
$masterenv test force noarchive_timeout
|
|
|
|
return $largs
|
|
}
|
|
|
|
# Process all incoming messages. Iterate until there are no messages left
|
|
# in anyone's queue so that we capture all message exchanges. We verify that
|
|
# the requested number of clients matches the number of client environments
|
|
# we have. The oob parameter indicates if we should process the queue
|
|
# with out-of-order delivery. The replprocess procedure actually does
|
|
# the real work of processing the queue -- this routine simply iterates
|
|
# over the various queues and does the initial setup.
|
|
proc repl_envprocq { test { nclients 1 } { oob 0 }} {
|
|
global repenv
|
|
global drop
|
|
|
|
set masterenv $repenv(master)
|
|
for { set i 0 } { 1 } { incr i } {
|
|
if { $repenv($i) == "NULL"} {
|
|
break
|
|
}
|
|
}
|
|
error_check_good i_nclients $nclients $i
|
|
|
|
berkdb debug_check
|
|
puts -nonewline "\t$test: Processing master/$i client queues"
|
|
set rand_skip 0
|
|
if { $oob } {
|
|
puts " out-of-order"
|
|
} else {
|
|
puts " in order"
|
|
}
|
|
set droprestore $drop
|
|
while { 1 } {
|
|
set nproced 0
|
|
|
|
if { $oob } {
|
|
set rand_skip [berkdb random_int 2 10]
|
|
}
|
|
incr nproced [replprocessqueue $masterenv 1 $rand_skip]
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
set envid [expr $i + 2]
|
|
if { $oob } {
|
|
set rand_skip [berkdb random_int 2 10]
|
|
}
|
|
set n [replprocessqueue $repenv($i) \
|
|
$envid $rand_skip]
|
|
incr nproced $n
|
|
}
|
|
|
|
if { $nproced == 0 } {
|
|
# Now that we delay requesting records until
|
|
# we've had a few records go by, we should always
|
|
# see that the number of requests is lower than the
|
|
# number of messages that were enqueued.
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
set clientenv $repenv($i)
|
|
set queued [stat_field $clientenv rep_stat \
|
|
"Total log records queued"]
|
|
error_check_bad queued_stats \
|
|
$queued -1
|
|
set requested [stat_field $clientenv rep_stat \
|
|
"Log records requested"]
|
|
error_check_bad requested_stats \
|
|
$requested -1
|
|
|
|
#
|
|
# Set to 100 usecs. An average ping
|
|
# to localhost should be a few 10s usecs.
|
|
#
|
|
$clientenv rep_request 100 400
|
|
}
|
|
|
|
# If we were dropping messages, we might need
|
|
# to flush the log so that we get everything
|
|
# and end up in the right state.
|
|
if { $drop != 0 } {
|
|
set drop 0
|
|
$masterenv rep_flush
|
|
berkdb debug_check
|
|
puts "\t$test: Flushing Master"
|
|
} else {
|
|
break
|
|
}
|
|
}
|
|
}
|
|
|
|
# Reset the clients back to the default state in case we
|
|
# have more processing to do.
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
set clientenv $repenv($i)
|
|
$clientenv rep_request 40000 1280000
|
|
}
|
|
set drop $droprestore
|
|
}
|
|
|
|
# Verify that the directories in the master are exactly replicated in
|
|
# each of the client environments.
|
|
proc repl_envver0 { test method { nclients 1 } } {
|
|
global masterdir
|
|
global repenv
|
|
|
|
# Verify the database in the client dir.
|
|
# First dump the master.
|
|
set t1 $masterdir/t1
|
|
set t2 $masterdir/t2
|
|
set t3 $masterdir/t3
|
|
set omethod [convert_method $method]
|
|
|
|
#
|
|
# We are interested in the keys of whatever databases are present
|
|
# in the master environment, so we just call a no-op check function
|
|
# since we have no idea what the contents of this database really is.
|
|
# We just need to walk the master and the clients and make sure they
|
|
# have the same contents.
|
|
#
|
|
set cwd [pwd]
|
|
cd $masterdir
|
|
set stat [catch {glob test*.db} dbs]
|
|
cd $cwd
|
|
if { $stat == 1 } {
|
|
return
|
|
}
|
|
foreach testfile $dbs {
|
|
open_and_dump_file $testfile $repenv(master) $masterdir/t2 \
|
|
repl_noop dump_file_direction "-first" "-next"
|
|
|
|
if { [string compare [convert_method $method] -recno] != 0 } {
|
|
filesort $t2 $t3
|
|
file rename -force $t3 $t2
|
|
}
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
puts "\t$test: Verifying client $i database $testfile contents."
|
|
open_and_dump_file $testfile $repenv($i) \
|
|
$t1 repl_noop dump_file_direction "-first" "-next"
|
|
|
|
if { [string compare $omethod "-recno"] != 0 } {
|
|
filesort $t1 $t3
|
|
} else {
|
|
catch {file copy -force $t1 $t3} ret
|
|
}
|
|
error_check_good diff_files($t2,$t3) [filecmp $t2 $t3] 0
|
|
}
|
|
}
|
|
}
|
|
|
|
# Remove all the elements from the master and verify that these
|
|
# deletions properly propagated to the clients.
|
|
proc repl_verdel { test method { nclients 1 } } {
|
|
source ./include.tcl
|
|
|
|
global clientdir
|
|
global masterdir
|
|
global repenv
|
|
global encrypt
|
|
global passwd
|
|
global util_path
|
|
|
|
# Delete all items in the master.
|
|
set cwd [pwd]
|
|
cd $masterdir
|
|
set stat [catch {glob test*.db} dbs]
|
|
cd $cwd
|
|
if { $stat == 1 } {
|
|
return
|
|
}
|
|
set utilflag ""
|
|
if { $encrypt != 0 } {
|
|
set utilflag "-P $passwd"
|
|
}
|
|
foreach testfile $dbs {
|
|
|
|
# Dump the database to determine whether there are subdbs.
|
|
#
|
|
set ret [catch {eval {exec $util_path/db_dump} $utilflag\
|
|
-f $testdir/dumpfile $masterdir/$testfile} res]
|
|
error_check_good dump($testfile:$res) $ret 0
|
|
|
|
set subdbs ""
|
|
set fd [open $testdir/dumpfile r]
|
|
while { [gets $fd str] != -1 } {
|
|
if { [string match database=* $str] } {
|
|
set subdbname [string range $str 9 end]
|
|
lappend subdbs $subdbname
|
|
}
|
|
}
|
|
close $fd
|
|
|
|
# Set up filenames depending on whether there are
|
|
# subdatabases or not.
|
|
set files ""
|
|
if { [llength $subdbs] > 0 } {
|
|
foreach sub $subdbs {
|
|
set filename "$testfile $sub"
|
|
lappend files $filename
|
|
}
|
|
} else {
|
|
set files $testfile
|
|
}
|
|
|
|
foreach f $files {
|
|
puts "\t$test: Deleting all items from the master."
|
|
set txn [$repenv(master) txn]
|
|
error_check_good txn_begin [is_valid_txn $txn \
|
|
$repenv(master)] TRUE
|
|
set db [eval {berkdb_open} -txn $txn -env $repenv(master) $f]
|
|
error_check_good reopen_master [is_valid_db $db] TRUE
|
|
set dbc [$db cursor -txn $txn]
|
|
error_check_good reopen_master_cursor \
|
|
[is_valid_cursor $dbc $db] TRUE
|
|
for { set dbt [$dbc get -first] } { [llength $dbt] > 0 } \
|
|
{ set dbt [$dbc get -next] } {
|
|
error_check_good del_item [$dbc del] 0
|
|
}
|
|
error_check_good dbc_close [$dbc close] 0
|
|
error_check_good txn_commit [$txn commit] 0
|
|
error_check_good db_close [$db close] 0
|
|
}
|
|
|
|
repl_envprocq $test $nclients
|
|
|
|
# Check clients.
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
foreach f $files {
|
|
puts "\t$test: Verifying client database $i is empty."
|
|
|
|
set db [eval berkdb_open -env $repenv($i) $f]
|
|
error_check_good reopen_client($i) \
|
|
[is_valid_db $db] TRUE
|
|
set dbc [$db cursor]
|
|
error_check_good reopen_client_cursor($i) \
|
|
[is_valid_cursor $dbc $db] TRUE
|
|
|
|
error_check_good client($i)_empty \
|
|
[llength [$dbc get -first]] 0
|
|
|
|
error_check_good dbc_close [$dbc close] 0
|
|
error_check_good db_close [$db close] 0
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Replication "check" function for the dump procs that expect to
|
|
# be able to verify the keys and data.
|
|
proc repl_noop { k d } {
|
|
return
|
|
}
|
|
|
|
# Close all the master and client environments in a replication test directory.
|
|
proc repl_envclose { test envargs } {
|
|
source ./include.tcl
|
|
global clientdir
|
|
global encrypt
|
|
global masterdir
|
|
global repenv
|
|
global drop
|
|
|
|
if { [lsearch $envargs "-encrypta*"] !=-1 } {
|
|
set encrypt 1
|
|
}
|
|
|
|
# In order to make sure that we have fully-synced and ready-to-verify
|
|
# databases on all the clients, do a checkpoint on the master and
|
|
# process messages in order to flush all the clients.
|
|
set drop 0
|
|
berkdb debug_check
|
|
puts "\t$test: Checkpointing master."
|
|
error_check_good masterenv_ckp [$repenv(master) txn_checkpoint] 0
|
|
|
|
# Count clients.
|
|
for { set ncli 0 } { 1 } { incr ncli } {
|
|
if { $repenv($ncli) == "NULL" } {
|
|
break
|
|
}
|
|
$repenv($ncli) rep_request 100 100
|
|
}
|
|
repl_envprocq $test $ncli
|
|
|
|
error_check_good masterenv_close [$repenv(master) close] 0
|
|
verify_dir $masterdir "\t$test: " 0 0 1
|
|
for { set i 0 } { $i < $ncli } { incr i } {
|
|
error_check_good client($i)_close [$repenv($i) close] 0
|
|
verify_dir $clientdir($i) "\t$test: " 0 0 1
|
|
}
|
|
replclose $testdir/MSGQUEUEDIR
|
|
|
|
}
|
|
|
|
# Replnoop is a dummy function to substitute for replsend
|
|
# when replication is off.
|
|
proc replnoop { control rec fromid toid flags lsn } {
|
|
return 0
|
|
}
|
|
|
|
proc replclose { queuedir } {
|
|
global queueenv queuedbs machids
|
|
|
|
foreach m $machids {
|
|
set db $queuedbs($m)
|
|
error_check_good dbr_close [$db close] 0
|
|
}
|
|
error_check_good qenv_close [$queueenv close] 0
|
|
set machids {}
|
|
}
|
|
|
|
# Create a replication group for testing.
|
|
proc replsetup { queuedir } {
|
|
global queueenv queuedbs machids
|
|
|
|
file mkdir $queuedir
|
|
set max_locks 20000
|
|
set queueenv [berkdb_env \
|
|
-create -txn nosync -lock_max_locks $max_locks -home $queuedir]
|
|
error_check_good queueenv [is_valid_env $queueenv] TRUE
|
|
|
|
if { [info exists queuedbs] } {
|
|
unset queuedbs
|
|
}
|
|
set machids {}
|
|
|
|
return $queueenv
|
|
}
|
|
|
|
# Send function for replication.
|
|
proc replsend { control rec fromid toid flags lsn } {
|
|
global queuedbs queueenv machids
|
|
global drop drop_msg
|
|
global perm_sent_list
|
|
global anywhere
|
|
|
|
set permflags [lsearch $flags "perm"]
|
|
if { [llength $perm_sent_list] != 0 && $permflags != -1 } {
|
|
# puts "replsend sent perm message, LSN $lsn"
|
|
lappend perm_sent_list $lsn
|
|
}
|
|
|
|
#
|
|
# If we are testing with dropped messages, then we drop every
|
|
# $drop_msg time. If we do that just return 0 and don't do
|
|
# anything. However, avoid dropping PAGE_REQ and LOG_REQ, because
|
|
# currently recovering from those cases can take a while, and some tests
|
|
# rely on the assumption that a single log_flush from the master clears
|
|
# up any missing messages.
|
|
#
|
|
if { $drop != 0 &&
|
|
!([berkdb msgtype $control] eq "page_req" ||
|
|
[berkdb msgtype $control] eq "log_req")} {
|
|
incr drop
|
|
if { $drop == $drop_msg } {
|
|
set drop 1
|
|
return 0
|
|
}
|
|
}
|
|
# XXX
|
|
# -1 is DB_BROADCAST_EID
|
|
if { $toid == -1 } {
|
|
set machlist $machids
|
|
} else {
|
|
if { [info exists queuedbs($toid)] != 1 } {
|
|
error "replsend: machid $toid not found"
|
|
}
|
|
set m NULL
|
|
if { $anywhere != 0 } {
|
|
#
|
|
# If we can send this anywhere, send it to the first
|
|
# id we find that is neither toid or fromid.
|
|
#
|
|
set anyflags [lsearch $flags "any"]
|
|
if { $anyflags != -1 } {
|
|
foreach m $machids {
|
|
if { $m == $fromid || $m == $toid } {
|
|
continue
|
|
}
|
|
set machlist [list $m]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
#
|
|
# If we didn't find a different site, then we must
|
|
# fallback to the toid.
|
|
#
|
|
if { $m == "NULL" } {
|
|
set machlist [list $toid]
|
|
}
|
|
}
|
|
|
|
foreach m $machlist {
|
|
# do not broadcast to self.
|
|
if { $m == $fromid } {
|
|
continue
|
|
}
|
|
|
|
set db $queuedbs($m)
|
|
set txn [$queueenv txn]
|
|
$db put -txn $txn -append [list $control $rec $fromid]
|
|
error_check_good replsend_commit [$txn commit] 0
|
|
}
|
|
|
|
queue_logcheck
|
|
return 0
|
|
}
|
|
|
|
#
|
|
# If the message queue log files are getting too numerous, checkpoint
|
|
# and archive them. Some tests are so large (particularly from
|
|
# run_repmethod) that they can consume far too much disk space.
|
|
proc queue_logcheck { } {
|
|
global queueenv
|
|
|
|
|
|
set logs [$queueenv log_archive -arch_log]
|
|
set numlogs [llength $logs]
|
|
if { $numlogs > 10 } {
|
|
$queueenv txn_checkpoint
|
|
$queueenv log_archive -arch_remove
|
|
}
|
|
}
|
|
|
|
# Discard all the pending messages for a particular site.
|
|
proc replclear { machid } {
|
|
global queuedbs queueenv
|
|
|
|
if { [info exists queuedbs($machid)] != 1 } {
|
|
error "FAIL: replclear: machid $machid not found"
|
|
}
|
|
|
|
set db $queuedbs($machid)
|
|
set txn [$queueenv txn]
|
|
set dbc [$db cursor -txn $txn]
|
|
for { set dbt [$dbc get -rmw -first] } { [llength $dbt] > 0 } \
|
|
{ set dbt [$dbc get -rmw -next] } {
|
|
error_check_good replclear($machid)_del [$dbc del] 0
|
|
}
|
|
error_check_good replclear($machid)_dbc_close [$dbc close] 0
|
|
error_check_good replclear($machid)_txn_commit [$txn commit] 0
|
|
}
|
|
|
|
# Add a machine to a replication environment.
|
|
proc repladd { machid } {
|
|
global queueenv queuedbs machids
|
|
|
|
if { [info exists queuedbs($machid)] == 1 } {
|
|
error "FAIL: repladd: machid $machid already exists"
|
|
}
|
|
|
|
set queuedbs($machid) [berkdb open -auto_commit \
|
|
-env $queueenv -create -recno -renumber repqueue$machid.db]
|
|
error_check_good repqueue_create [is_valid_db $queuedbs($machid)] TRUE
|
|
|
|
lappend machids $machid
|
|
}
|
|
|
|
# Acquire a handle to work with an existing machine's replication
|
|
# queue. This is for situations where more than one process
|
|
# is working with a message queue. In general, having more than one
|
|
# process handle the queue is wrong. However, in order to test some
|
|
# things, we need two processes (since Tcl doesn't support threads). We
|
|
# go to great pain in the test harness to make sure this works, but we
|
|
# don't let customers do it.
|
|
proc repljoin { machid } {
|
|
global queueenv queuedbs machids
|
|
|
|
set queuedbs($machid) [berkdb open -auto_commit \
|
|
-env $queueenv repqueue$machid.db]
|
|
error_check_good repqueue_create [is_valid_db $queuedbs($machid)] TRUE
|
|
|
|
lappend machids $machid
|
|
}
|
|
|
|
# Process a queue of messages, skipping every "skip_interval" entry.
|
|
# We traverse the entire queue, but since we skip some messages, we
|
|
# may end up leaving things in the queue, which should get picked up
|
|
# on a later run.
|
|
proc replprocessqueue { dbenv machid { skip_interval 0 } { hold_electp NONE } \
|
|
{ dupmasterp NONE } { errp NONE } } {
|
|
global queuedbs queueenv errorCode
|
|
global perm_response_list
|
|
|
|
# hold_electp is a call-by-reference variable which lets our caller
|
|
# know we need to hold an election.
|
|
if { [string compare $hold_electp NONE] != 0 } {
|
|
upvar $hold_electp hold_elect
|
|
}
|
|
set hold_elect 0
|
|
|
|
# dupmasterp is a call-by-reference variable which lets our caller
|
|
# know we have a duplicate master.
|
|
if { [string compare $dupmasterp NONE] != 0 } {
|
|
upvar $dupmasterp dupmaster
|
|
}
|
|
set dupmaster 0
|
|
|
|
# errp is a call-by-reference variable which lets our caller
|
|
# know we have gotten an error (that they expect).
|
|
if { [string compare $errp NONE] != 0 } {
|
|
upvar $errp errorp
|
|
}
|
|
set errorp 0
|
|
|
|
set nproced 0
|
|
|
|
set txn [$queueenv txn]
|
|
|
|
# If we are running separate processes, the second process has
|
|
# to join an existing message queue.
|
|
if { [info exists queuedbs($machid)] == 0 } {
|
|
repljoin $machid
|
|
}
|
|
|
|
set dbc [$queuedbs($machid) cursor -txn $txn]
|
|
|
|
error_check_good process_dbc($machid) \
|
|
[is_valid_cursor $dbc $queuedbs($machid)] TRUE
|
|
|
|
for { set dbt [$dbc get -first] } \
|
|
{ [llength $dbt] != 0 } \
|
|
{ } {
|
|
set data [lindex [lindex $dbt 0] 1]
|
|
set recno [lindex [lindex $dbt 0] 0]
|
|
|
|
# If skip_interval is nonzero, we want to process messages
|
|
# out of order. We do this in a simple but slimy way--
|
|
# continue walking with the cursor without processing the
|
|
# message or deleting it from the queue, but do increment
|
|
# "nproced". The way this proc is normally used, the
|
|
# precise value of nproced doesn't matter--we just don't
|
|
# assume the queues are empty if it's nonzero. Thus,
|
|
# if we contrive to make sure it's nonzero, we'll always
|
|
# come back to records we've skipped on a later call
|
|
# to replprocessqueue. (If there really are no records,
|
|
# we'll never get here.)
|
|
#
|
|
# Skip every skip_interval'th record (and use a remainder other
|
|
# than zero so that we're guaranteed to really process at least
|
|
# one record on every call).
|
|
if { $skip_interval != 0 } {
|
|
if { $nproced % $skip_interval == 1 } {
|
|
incr nproced
|
|
set dbt [$dbc get -next]
|
|
continue
|
|
}
|
|
}
|
|
|
|
# We need to remove the current message from the queue,
|
|
# because we're about to end the transaction and someone
|
|
# else processing messages might come in and reprocess this
|
|
# message which would be bad.
|
|
error_check_good queue_remove [$dbc del] 0
|
|
|
|
# We have to play an ugly cursor game here: we currently
|
|
# hold a lock on the page of messages, but rep_process_message
|
|
# might need to lock the page with a different cursor in
|
|
# order to send a response. So save the next recno, close
|
|
# the cursor, and then reopen and reset the cursor.
|
|
# If someone else is processing this queue, our entry might
|
|
# have gone away, and we need to be able to handle that.
|
|
|
|
error_check_good dbc_process_close [$dbc close] 0
|
|
error_check_good txn_commit [$txn commit] 0
|
|
|
|
set ret [catch {$dbenv rep_process_message \
|
|
[lindex $data 2] [lindex $data 0] [lindex $data 1]} res]
|
|
|
|
# Save all ISPERM and NOTPERM responses so we can compare their
|
|
# LSNs to the LSN in the log. The variable perm_response_list
|
|
# holds the entire response so we can extract responses and
|
|
# LSNs as needed.
|
|
#
|
|
if { [llength $perm_response_list] != 0 && \
|
|
([is_substr $res ISPERM] || [is_substr $res NOTPERM]) } {
|
|
lappend perm_response_list $res
|
|
}
|
|
|
|
if { $ret != 0 } {
|
|
if { [string compare $errp NONE] != 0 } {
|
|
set errorp "$dbenv $machid $res"
|
|
} else {
|
|
error "FAIL:[timestamp]\
|
|
rep_process_message returned $res"
|
|
}
|
|
}
|
|
|
|
incr nproced
|
|
|
|
# Now, re-establish the cursor position. We fetch the
|
|
# current record number. If there is something there,
|
|
# that is the record for the next iteration. If there
|
|
# is nothing there, then we've consumed the last item
|
|
# in the queue.
|
|
|
|
set txn [$queueenv txn]
|
|
set dbc [$queuedbs($machid) cursor -txn $txn]
|
|
set dbt [$dbc get -set_range $recno]
|
|
|
|
if { $ret == 0 } {
|
|
set rettype [lindex $res 0]
|
|
set retval [lindex $res 1]
|
|
#
|
|
# Do nothing for 0 and NEWSITE
|
|
#
|
|
if { [is_substr $rettype HOLDELECTION] } {
|
|
set hold_elect 1
|
|
}
|
|
if { [is_substr $rettype DUPMASTER] } {
|
|
set dupmaster "1 $dbenv $machid"
|
|
}
|
|
if { [is_substr $rettype NOTPERM] || \
|
|
[is_substr $rettype ISPERM] } {
|
|
set lsnfile [lindex $retval 0]
|
|
set lsnoff [lindex $retval 1]
|
|
}
|
|
}
|
|
|
|
if { $errorp != 0 } {
|
|
# Break also on an error, caller wants to handle it.
|
|
break
|
|
}
|
|
if { $hold_elect == 1 } {
|
|
# Break also on a HOLDELECTION, for the same reason.
|
|
break
|
|
}
|
|
if { $dupmaster == 1 } {
|
|
# Break also on a DUPMASTER, for the same reason.
|
|
break
|
|
}
|
|
|
|
}
|
|
|
|
error_check_good dbc_close [$dbc close] 0
|
|
error_check_good txn_commit [$txn commit] 0
|
|
|
|
# Return the number of messages processed.
|
|
return $nproced
|
|
}
|
|
|
|
|
|
set run_repl_flag "-run_repl"
|
|
|
|
proc extract_repl_args { args } {
|
|
global run_repl_flag
|
|
|
|
for { set arg [lindex $args [set i 0]] } \
|
|
{ [string length $arg] > 0 } \
|
|
{ set arg [lindex $args [incr i]] } {
|
|
if { [string compare $arg $run_repl_flag] == 0 } {
|
|
return [lindex $args [expr $i + 1]]
|
|
}
|
|
}
|
|
return ""
|
|
}
|
|
|
|
proc delete_repl_args { args } {
|
|
global run_repl_flag
|
|
|
|
set ret {}
|
|
|
|
for { set arg [lindex $args [set i 0]] } \
|
|
{ [string length $arg] > 0 } \
|
|
{ set arg [lindex $args [incr i]] } {
|
|
if { [string compare $arg $run_repl_flag] != 0 } {
|
|
lappend ret $arg
|
|
} else {
|
|
incr i
|
|
}
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
global elect_serial
|
|
global elections_in_progress
|
|
set elect_serial 0
|
|
|
|
# Start an election in a sub-process.
|
|
proc start_election { \
|
|
pfx qdir home envid nsites nvotes pri timeout {err "none"} {crash 0}} {
|
|
source ./include.tcl
|
|
global elect_serial elections_in_progress machids
|
|
global rep_verbose
|
|
global verbose_type
|
|
|
|
set filelist {}
|
|
set ret [catch {glob $testdir/ELECTION*.$elect_serial} result]
|
|
if { $ret == 0 } {
|
|
set filelist [concat $filelist $result]
|
|
}
|
|
foreach f $filelist {
|
|
fileremove -f $f
|
|
}
|
|
|
|
set oid [open $testdir/ELECTION_SOURCE.$elect_serial w]
|
|
|
|
puts $oid "source $test_path/test.tcl"
|
|
puts $oid "set is_repchild 1"
|
|
puts $oid "replsetup $qdir"
|
|
foreach i $machids { puts $oid "repladd $i" }
|
|
set env_cmd "berkdb env -event -home $home -txn \
|
|
-rep_transport {$envid replsend} -errpfx $pfx"
|
|
if { $rep_verbose == 1 } {
|
|
append env_cmd " -errfile /dev/stdout -verbose {$verbose_type on}"
|
|
} else {
|
|
append env_cmd " -errfile $testdir/ELECTION_ERRFILE.$elect_serial"
|
|
}
|
|
puts $oid "set dbenv \[ $env_cmd \]"
|
|
|
|
puts $oid "\$dbenv test abort $err"
|
|
puts $oid "set res \[catch \{\$dbenv rep_elect $nsites \
|
|
$nvotes $pri $timeout\} ret\]"
|
|
puts $oid "set r \[open \$testdir/ELECTION_RESULT.$elect_serial w\]"
|
|
puts $oid "if \{\$res == 0 \} \{"
|
|
puts $oid "puts \$r \"SUCCESS \$ret\""
|
|
puts $oid "\} else \{"
|
|
puts $oid "puts \$r \"ERROR \$ret\""
|
|
puts $oid "\}"
|
|
#
|
|
# This loop calls rep_elect a second time with the error cleared.
|
|
# We don't want to do that if we are simulating a crash.
|
|
if { $err != "none" && $crash != 1 } {
|
|
puts $oid "\$dbenv test abort none"
|
|
puts $oid "set res \[catch \{\$dbenv rep_elect $nsites \
|
|
$nvotes $pri $timeout\} ret\]"
|
|
puts $oid "if \{\$res == 0 \} \{"
|
|
puts $oid "puts \$r \"SUCCESS \$ret\""
|
|
puts $oid "\} else \{"
|
|
puts $oid "puts \$r \"ERROR \$ret\""
|
|
puts $oid "\}"
|
|
}
|
|
|
|
puts $oid "if \{ \[is_elected \$dbenv\] \} \{"
|
|
puts $oid "puts \$r \"ELECTED \$dbenv\""
|
|
puts $oid "\}"
|
|
|
|
puts $oid "close \$r"
|
|
close $oid
|
|
|
|
set t [open "|$tclsh_path >& $testdir/ELECTION_OUTPUT.$elect_serial" w]
|
|
if { $rep_verbose } {
|
|
set t [open "|$tclsh_path" w]
|
|
}
|
|
puts $t "source ./include.tcl"
|
|
puts $t "source $testdir/ELECTION_SOURCE.$elect_serial"
|
|
flush $t
|
|
|
|
set elections_in_progress($elect_serial) $t
|
|
return $elect_serial
|
|
}
|
|
|
|
#
|
|
# If we are doing elections during upgrade testing, set
|
|
# upgrade to 1. Doing that sets the priority to the
|
|
# test priority in rep_elect, which will simulate a
|
|
# 0-priority but electable site.
|
|
#
|
|
proc setpriority { priority nclients winner {start 0} {upgrade 0} } {
|
|
global electable_pri
|
|
upvar $priority pri
|
|
|
|
for { set i $start } { $i < [expr $nclients + $start] } { incr i } {
|
|
if { $i == $winner } {
|
|
set pri($i) 100
|
|
} else {
|
|
if { $upgrade } {
|
|
set pri($i) $electable_pri
|
|
} else {
|
|
set pri($i) 10
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# run_election has the following arguments:
|
|
# Arrays:
|
|
# celist List of env_handle, EID pairs.
|
|
# errcmd Array of where errors should be forced.
|
|
# priority Array of the priorities of each client env.
|
|
# crash If an error is forced, should we crash or recover?
|
|
# The upvar command takes care of making these arrays available to
|
|
# the procedure.
|
|
#
|
|
# Ordinary variables:
|
|
# qdir Directory where the message queue is located.
|
|
# msg Message prefixed to the output.
|
|
# elector This client calls the first election.
|
|
# nsites Number of sites in the replication group.
|
|
# nvotes Number of votes required to win the election.
|
|
# nclients Number of clients participating in the election.
|
|
# win The expected winner of the election.
|
|
# reset_role Should the new master (i.e. winner) be reset
|
|
# to client role after the election?
|
|
# dbname Name of the underlying database. The caller
|
|
# should send in "NULL" if the database has not
|
|
# yet been created.
|
|
# ignore Should the winner ignore its own election?
|
|
# If ignore is 1, the winner is not made master.
|
|
# timeout_ok We expect that this election will not succeed
|
|
# in electing a new master (perhaps because there
|
|
# already is a master).
|
|
# elect_timeout Timeout value to pass to rep_elect, which may be
|
|
# a 2-element list in case "full election timeouts"
|
|
# are in use.
|
|
|
|
proc run_election { celist errcmd priority crsh\
|
|
qdir msg elector nsites nvotes nclients win reset_role\
|
|
dbname {ignore 0} {timeout_ok 0} {elect_timeout 15000000} } {
|
|
|
|
global elect_serial
|
|
global is_hp_test
|
|
global is_windows_test
|
|
global rand_init
|
|
upvar $celist cenvlist
|
|
upvar $errcmd err_cmd
|
|
upvar $priority pri
|
|
upvar $crsh crash
|
|
|
|
# Windows and HP-UX require a longer timeout.
|
|
if { [llength $elect_timeout] == 1 &&
|
|
($is_windows_test == 1 || $is_hp_test == 1) } {
|
|
set elect_timeout [expr $elect_timeout * 2]
|
|
}
|
|
|
|
# Initialize tries based on timeout. We use tries to loop looking for
|
|
# messages because as sites are sleeping waiting for their timeout to
|
|
# expire we need to keep checking for messages.
|
|
# The $elect_timeout might be either a scalar number, or a
|
|
# two-element list in the case where we're interested in testing full
|
|
# election timeouts. Either is fine for passing to rep_elect (via
|
|
# start_election); but of course for computing "$tries" we need just a
|
|
# simple number.
|
|
#
|
|
if {[llength $elect_timeout] > 1} {
|
|
set t [lindex $elect_timeout 1]
|
|
} else {
|
|
set t $elect_timeout
|
|
}
|
|
set tries [expr ($t * 4) / 1000000]
|
|
|
|
# Initialize each client participating in this election. While we're at
|
|
# it, save a copy of the envlist pair for the elector site, because
|
|
# we'll need its EID and env handle in a moment (for the initial call to
|
|
# start_election). Note that $elector couldn't simple be used to index
|
|
# into the list, because for example the envlist could look something
|
|
# like this:
|
|
#
|
|
# { { cenv4 4 } { cenv5 5 } { cenv6 6 } }
|
|
#
|
|
# and then "4" could be a valid $elector value (meaning EID 6).
|
|
#
|
|
set elector_pair NOTFOUND
|
|
set win_pair NOTFOUND
|
|
foreach pair $cenvlist {
|
|
set id [lindex $pair 1]
|
|
set i [expr $id - 2]
|
|
if { $i == $elector } {
|
|
set elector_pair $pair
|
|
}
|
|
set elect_pipe($i) INVALID
|
|
set env [lindex $pair 0]
|
|
$env event_info -clear
|
|
replclear $id
|
|
if { $i == $win } {
|
|
set win_pair $pair
|
|
set orig_pfx [$env get_errpfx]
|
|
}
|
|
}
|
|
error_check_bad unknown_elector $elector_pair NOTFOUND
|
|
error_check_good unknown_winner \
|
|
[expr { $win_pair != "NOTFOUND" || ! $reset_role }] 1
|
|
|
|
#
|
|
# XXX
|
|
# We need to somehow check for the warning if nvotes is not
|
|
# a majority. Problem is that warning will go into the child
|
|
# process' output. Furthermore, we need a mechanism that can
|
|
# handle both sending the output to a file and sending it to
|
|
# /dev/stderr when debugging without failing the
|
|
# error_check_good check.
|
|
#
|
|
puts "\t\t$msg.1: Election with nsites=$nsites,\
|
|
nvotes=$nvotes, nclients=$nclients"
|
|
puts "\t\t$msg.2: First elector is $elector,\
|
|
expected winner is $win (eid [expr $win + 2])"
|
|
incr elect_serial
|
|
set pfx "CHILD$elector.$elect_serial"
|
|
set env [lindex $elector_pair 0]
|
|
set envid [lindex $elector_pair 1]
|
|
set home [$env get_home]
|
|
set elect_pipe($elector) [start_election \
|
|
$pfx $qdir $home $envid $nsites $nvotes $pri($elector) \
|
|
$elect_timeout $err_cmd($elector) $crash($elector)]
|
|
tclsleep 2
|
|
|
|
set got_newmaster 0
|
|
|
|
# If we're simulating a crash, skip the while loop and
|
|
# just give the initial election a chance to complete.
|
|
set crashing 0
|
|
for { set i 0 } { $i < $nclients } { incr i } {
|
|
if { $crash($i) == 1 } {
|
|
set crashing 1
|
|
}
|
|
}
|
|
|
|
set child_elected 0
|
|
|
|
if { $crashing == 1 } {
|
|
tclsleep 10
|
|
} else {
|
|
set abandoned ""
|
|
while { 1 } {
|
|
set nproced 0
|
|
set he 0
|
|
|
|
foreach pair $cenvlist {
|
|
set he 0
|
|
set unavail 0
|
|
set envid [lindex $pair 1]
|
|
set i [expr $envid - 2]
|
|
set clientenv($i) [lindex $pair 0]
|
|
|
|
# If the "elected" event is received by the
|
|
# child process, it writes to a file and we
|
|
# use check_election to get the message. In
|
|
# that case, the env set up in that child
|
|
# is the elected env.
|
|
set child_done [check_election $elect_pipe($i)\
|
|
unavail child_elected]
|
|
|
|
incr nproced [replprocessqueue \
|
|
$clientenv($i) $envid 0 he]
|
|
|
|
# We use normal event processing to detect
|
|
# an "elected" event received by the parent
|
|
# process.
|
|
set parent_elected [is_elected $clientenv($i)]
|
|
|
|
# puts "Tries $tries:\
|
|
# Processed queue for client $i, $nproced msgs he $he unavail $unavail"
|
|
|
|
# Check for completed election. If it's the
|
|
# first time we've noticed it, deal with it.
|
|
if { ( $child_elected || $parent_elected ) && \
|
|
$got_newmaster == 0 } {
|
|
set got_newmaster 1
|
|
|
|
# Make sure it's the expected winner.
|
|
error_check_good right_winner \
|
|
$envid [expr $win + 2]
|
|
|
|
# Reconfigure winning env as master.
|
|
if { $ignore == 0 } {
|
|
$clientenv($i) errpfx \
|
|
NEWMASTER
|
|
error_check_good \
|
|
make_master($i) \
|
|
[$clientenv($i) \
|
|
rep_start -master] 0
|
|
|
|
wait_all_startup $cenvlist $envid
|
|
|
|
# Don't hold another election
|
|
# yet if we are setting up a
|
|
# new master. This could
|
|
# cause the new master to
|
|
# declare itself a client
|
|
# during internal init.
|
|
set he 0
|
|
}
|
|
|
|
# Occasionally force new log records
|
|
# to be written, unless the database
|
|
# has not yet been created.
|
|
set write [berkdb random_int 1 10]
|
|
if { $write == 1 && $dbname != "NULL" } {
|
|
set db [eval berkdb_open_noerr \
|
|
-env $clientenv($i) \
|
|
-auto_commit $dbname]
|
|
error_check_good dbopen \
|
|
[is_valid_db $db] TRUE
|
|
error_check_good dbclose \
|
|
[$db close] 0
|
|
}
|
|
}
|
|
|
|
if { $he == 1 && $got_newmaster == 0 } {
|
|
#
|
|
# Only close down the election pipe if the
|
|
# previously created one is done and
|
|
# waiting for new commands, otherwise
|
|
# if we try to close it while it's in
|
|
# progress we hang this main tclsh. If
|
|
# it's not done, hold onto it in an
|
|
# "abandoned" list, where we'll clean it
|
|
# up later.
|
|
#
|
|
if { $elect_pipe($i) != "INVALID" && \
|
|
$child_done == 1 } {
|
|
close_election $elect_pipe($i)
|
|
set elect_pipe($i) "INVALID"
|
|
} elseif { $elect_pipe($i) != "INVALID" } {
|
|
lappend abandoned $elect_pipe($i)
|
|
set elect_pipe($i) "INVALID"
|
|
}
|
|
# puts "Starting election on client $i"
|
|
incr elect_serial
|
|
set pfx "CHILD$i.$elect_serial"
|
|
set home [$clientenv($i) get_home]
|
|
set elect_pipe($i) [start_election \
|
|
$pfx $qdir \
|
|
$home $envid $nsites \
|
|
$nvotes $pri($i) $elect_timeout]
|
|
set got_hold_elect($i) 1
|
|
}
|
|
}
|
|
|
|
# We need to wait around to make doubly sure that the
|
|
# election has finished...
|
|
if { $nproced == 0 } {
|
|
incr tries -1
|
|
#
|
|
# If we have a newmaster already, set tries
|
|
# down to just allow straggling messages to
|
|
# be processed. Tries could be a very large
|
|
# number if we have long timeouts.
|
|
#
|
|
if { $got_newmaster != 0 && $tries > 10 } {
|
|
set tries 10
|
|
}
|
|
if { $tries == 0 } {
|
|
break
|
|
} else {
|
|
tclsleep 1
|
|
}
|
|
} else {
|
|
set tries $tries
|
|
}
|
|
set abandoned [cleanup_abandoned $abandoned]
|
|
}
|
|
|
|
# If we did get a new master, its identity was checked
|
|
# at that time. But we still have to make sure that we
|
|
# didn't just time out.
|
|
|
|
if { $got_newmaster == 0 && $timeout_ok == 0 } {
|
|
error "FAIL: Did not elect new master."
|
|
}
|
|
}
|
|
cleanup_elections
|
|
|
|
#
|
|
# Make sure we've really processed all the post-election
|
|
# sync-up messages. If we're simulating a crash, don't process
|
|
# any more messages.
|
|
#
|
|
if { $crashing == 0 } {
|
|
process_msgs $cenvlist
|
|
}
|
|
|
|
if { $reset_role == 1 } {
|
|
puts "\t\t$msg.3: Changing new master to client role"
|
|
error_check_good log_flush [$clientenv($win) log_flush] 0
|
|
error_check_good role_chg [$clientenv($win) rep_start -client] 0
|
|
$clientenv($win) errpfx $orig_pfx
|
|
|
|
if { $crashing == 0 } {
|
|
process_msgs $cenvlist
|
|
}
|
|
}
|
|
}
|
|
|
|
proc wait_all_startup { envlist master } {
|
|
process_msgs $envlist
|
|
|
|
for { set tries 0 } { $tries < 10 } { incr tries } {
|
|
# Find a client that has not yet reached startupdone.
|
|
#
|
|
set found 0
|
|
foreach pair $envlist {
|
|
foreach {env eid} $pair {}
|
|
if { $eid == $master } {
|
|
continue
|
|
}
|
|
if {![stat_field $env rep_stat "Startup complete"]} {
|
|
set found 1
|
|
break
|
|
}
|
|
}
|
|
|
|
# We couldn't find a client who hadn't got startup done. That
|
|
# means we're all done and happy.
|
|
#
|
|
if {!$found} {
|
|
return
|
|
}
|
|
tclsleep 1
|
|
process_msgs $envlist
|
|
}
|
|
error "FAIL: Clients could not get startupdone after master elected."
|
|
}
|
|
|
|
proc cleanup_abandoned { es } {
|
|
set remaining ""
|
|
foreach e $es {
|
|
if { [check_election $e unused1 unused2] } {
|
|
close_election $e
|
|
} else {
|
|
lappend remaining $e
|
|
}
|
|
}
|
|
return $remaining
|
|
}
|
|
|
|
# Retrieve election results that may have been reported by a child process. The
|
|
# child process communicates the results to us (the parent process) by writing
|
|
# them into a file.
|
|
#
|
|
proc check_election { id unavailp elected_flagp } {
|
|
source ./include.tcl
|
|
|
|
if { $id == "INVALID" } {
|
|
return 0
|
|
}
|
|
upvar $unavailp unavail
|
|
upvar $elected_flagp elected_flag
|
|
|
|
set unavail 0
|
|
set elected_flag 0
|
|
|
|
set res [catch {open $testdir/ELECTION_RESULT.$id} nmid]
|
|
if { $res != 0 } {
|
|
return 0
|
|
}
|
|
while { [gets $nmid val] != -1 } {
|
|
# puts "result $id: $val"
|
|
set str [lindex $val 0]
|
|
if { [is_substr $val UNAVAIL] } {
|
|
set unavail 1
|
|
}
|
|
if { [is_substr $val ELECTED] } {
|
|
set elected_flag 1
|
|
}
|
|
}
|
|
close $nmid
|
|
return 1
|
|
}
|
|
|
|
proc is_elected { env } {
|
|
return [is_event_present $env "elected"]
|
|
}
|
|
|
|
proc is_startup_done { env } {
|
|
return [is_event_present $env "startupdone"]
|
|
}
|
|
|
|
proc is_event_present { env event_name } {
|
|
set event_info [find_event [$env event_info] $event_name]
|
|
return [expr [llength $event_info] > 0]
|
|
}
|
|
|
|
# Extracts info about a given event type from a list of events that have
|
|
# occurred in an environment. The event_info might look something like this:
|
|
#
|
|
# {startupdone {}} {newmaster 2}
|
|
#
|
|
# A key would be something like "startupdone" or "newmaster". The return value
|
|
# might look like "newmaster 2". In other words, we return the complete
|
|
# information about a single event -- the event named by the key. If the event
|
|
# named by the key does not appear in the event_info, we return "".
|
|
#
|
|
proc find_event { event_info key } {
|
|
|
|
# Search for a glob pattern: a string beginning with the key name, and
|
|
# containing anything after it.
|
|
#
|
|
return [lsearch -inline $event_info [append key *]]
|
|
}
|
|
|
|
proc close_election { i } {
|
|
global elections_in_progress
|
|
global noenv_messaging
|
|
global qtestdir
|
|
|
|
if { $noenv_messaging == 1 } {
|
|
set testdir $qtestdir
|
|
}
|
|
|
|
set t $elections_in_progress($i)
|
|
puts $t "replclose \$testdir/MSGQUEUEDIR"
|
|
puts $t "\$dbenv close"
|
|
close $t
|
|
unset elections_in_progress($i)
|
|
}
|
|
|
|
proc cleanup_elections { } {
|
|
global elect_serial elections_in_progress
|
|
|
|
for { set i 0 } { $i <= $elect_serial } { incr i } {
|
|
if { [info exists elections_in_progress($i)] != 0 } {
|
|
close_election $i
|
|
}
|
|
}
|
|
|
|
set elect_serial 0
|
|
}
|
|
|
|
#
|
|
# This is essentially a copy of test001, but it only does the put/get
|
|
# loop AND it takes an already-opened db handle.
|
|
#
|
|
proc rep_test { method env repdb {nentries 10000} \
|
|
{start 0} {skip 0} {needpad 0} args } {
|
|
|
|
source ./include.tcl
|
|
global databases_in_memory
|
|
|
|
#
|
|
# Open the db if one isn't given. Close before exit.
|
|
#
|
|
if { $repdb == "NULL" } {
|
|
if { $databases_in_memory == 1 } {
|
|
set testfile { "" "test.db" }
|
|
} else {
|
|
set testfile "test.db"
|
|
}
|
|
set largs [convert_args $method $args]
|
|
set omethod [convert_method $method]
|
|
set db [eval {berkdb_open_noerr} -env $env -auto_commit\
|
|
-create -mode 0644 $omethod $largs $testfile]
|
|
error_check_good reptest_db [is_valid_db $db] TRUE
|
|
} else {
|
|
set db $repdb
|
|
}
|
|
|
|
puts "\t\tRep_test: $method $nentries key/data pairs starting at $start"
|
|
set did [open $dict]
|
|
|
|
# The "start" variable determines the record number to start
|
|
# with, if we're using record numbers. The "skip" variable
|
|
# determines which dictionary entry to start with. In normal
|
|
# use, skip is equal to start.
|
|
|
|
if { $skip != 0 } {
|
|
for { set count 0 } { $count < $skip } { incr count } {
|
|
gets $did str
|
|
}
|
|
}
|
|
set pflags ""
|
|
set gflags ""
|
|
set txn ""
|
|
|
|
if { [is_record_based $method] == 1 } {
|
|
append gflags " -recno"
|
|
}
|
|
puts "\t\tRep_test.a: put/get loop"
|
|
# Here is the loop where we put and get each key/data pair
|
|
set count 0
|
|
|
|
# Checkpoint 10 times during the run, but not more
|
|
# frequently than every 5 entries.
|
|
set checkfreq [expr $nentries / 10]
|
|
|
|
# Abort occasionally during the run.
|
|
set abortfreq [expr $nentries / 15]
|
|
|
|
while { [gets $did str] != -1 && $count < $nentries } {
|
|
if { [is_record_based $method] == 1 } {
|
|
global kvals
|
|
|
|
set key [expr $count + 1 + $start]
|
|
if { 0xffffffff > 0 && $key > 0xffffffff } {
|
|
set key [expr $key - 0x100000000]
|
|
}
|
|
if { $key == 0 || $key - 0xffffffff == 1 } {
|
|
incr key
|
|
incr count
|
|
}
|
|
set kvals($key) [pad_data $method $str]
|
|
} else {
|
|
set key $str
|
|
set str [reverse $str]
|
|
}
|
|
#
|
|
# We want to make sure we send in exactly the same
|
|
# length data so that LSNs match up for some tests
|
|
# in replication (rep021).
|
|
#
|
|
if { [is_fixed_length $method] == 1 && $needpad } {
|
|
#
|
|
# Make it something visible and obvious, 'A'.
|
|
#
|
|
set p 65
|
|
set str [make_fixed_length $method $str $p]
|
|
set kvals($key) $str
|
|
}
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set txn "-txn $t"
|
|
set ret [eval \
|
|
{$db put} $txn $pflags {$key [chop_data $method $str]}]
|
|
error_check_good put $ret 0
|
|
error_check_good txn [$t commit] 0
|
|
|
|
if { $checkfreq < 5 } {
|
|
set checkfreq 5
|
|
}
|
|
if { $abortfreq < 3 } {
|
|
set abortfreq 3
|
|
}
|
|
#
|
|
# Do a few aborted transactions to test that
|
|
# aborts don't get processed on clients and the
|
|
# master handles them properly. Just abort
|
|
# trying to delete the key we just added.
|
|
#
|
|
if { $count % $abortfreq == 0 } {
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set ret [$db del -txn $t $key]
|
|
error_check_good txn [$t abort] 0
|
|
}
|
|
if { $count % $checkfreq == 0 } {
|
|
error_check_good txn_checkpoint($count) \
|
|
[$env txn_checkpoint] 0
|
|
}
|
|
incr count
|
|
}
|
|
close $did
|
|
if { $repdb == "NULL" } {
|
|
error_check_good rep_close [$db close] 0
|
|
}
|
|
}
|
|
|
|
#
|
|
# This is essentially a copy of rep_test, but it only does the put/get
|
|
# loop in a long running txn to an open db. We use it for bulk testing
|
|
# because we want to fill the bulk buffer some before sending it out.
|
|
# Bulk buffer gets transmitted on every commit.
|
|
#
|
|
proc rep_test_bulk { method env repdb {nentries 10000} \
|
|
{start 0} {skip 0} {useoverflow 0} args } {
|
|
source ./include.tcl
|
|
|
|
global overflowword1
|
|
global overflowword2
|
|
global databases_in_memory
|
|
|
|
if { [is_fixed_length $method] && $useoverflow == 1 } {
|
|
puts "Skipping overflow for fixed length method $method"
|
|
return
|
|
}
|
|
#
|
|
# Open the db if one isn't given. Close before exit.
|
|
#
|
|
if { $repdb == "NULL" } {
|
|
if { $databases_in_memory == 1 } {
|
|
set testfile { "" "test.db" }
|
|
} else {
|
|
set testfile "test.db"
|
|
}
|
|
set largs [convert_args $method $args]
|
|
set omethod [convert_method $method]
|
|
set db [eval {berkdb_open_noerr -env $env -auto_commit -create \
|
|
-mode 0644} $largs $omethod $testfile]
|
|
error_check_good reptest_db [is_valid_db $db] TRUE
|
|
} else {
|
|
set db $repdb
|
|
}
|
|
|
|
#
|
|
# If we are using an env, then testfile should just be the db name.
|
|
# Otherwise it is the test directory and the name.
|
|
# If we are not using an external env, then test setting
|
|
# the database cache size and using multiple caches.
|
|
puts \
|
|
"\t\tRep_test_bulk: $method $nentries key/data pairs starting at $start"
|
|
set did [open $dict]
|
|
|
|
# The "start" variable determines the record number to start
|
|
# with, if we're using record numbers. The "skip" variable
|
|
# determines which dictionary entry to start with. In normal
|
|
# use, skip is equal to start.
|
|
|
|
if { $skip != 0 } {
|
|
for { set count 0 } { $count < $skip } { incr count } {
|
|
gets $did str
|
|
}
|
|
}
|
|
set pflags ""
|
|
set gflags ""
|
|
set txn ""
|
|
|
|
if { [is_record_based $method] == 1 } {
|
|
append gflags " -recno"
|
|
}
|
|
puts "\t\tRep_test_bulk.a: put/get loop in 1 txn"
|
|
# Here is the loop where we put and get each key/data pair
|
|
set count 0
|
|
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set txn "-txn $t"
|
|
set pid [pid]
|
|
while { [gets $did str] != -1 && $count < $nentries } {
|
|
if { [is_record_based $method] == 1 } {
|
|
global kvals
|
|
|
|
set key [expr $count + 1 + $start]
|
|
if { 0xffffffff > 0 && $key > 0xffffffff } {
|
|
set key [expr $key - 0x100000000]
|
|
}
|
|
if { $key == 0 || $key - 0xffffffff == 1 } {
|
|
incr key
|
|
incr count
|
|
}
|
|
set kvals($key) [pad_data $method $str]
|
|
if { [is_fixed_length $method] == 0 } {
|
|
set str [repeat $str 100]
|
|
}
|
|
} else {
|
|
set key $str.$pid
|
|
set str [repeat $str 100]
|
|
}
|
|
#
|
|
# For use for overflow test.
|
|
#
|
|
if { $useoverflow == 0 } {
|
|
if { [string length $overflowword1] < \
|
|
[string length $str] } {
|
|
set overflowword2 $overflowword1
|
|
set overflowword1 $str
|
|
}
|
|
} else {
|
|
if { $count == 0 } {
|
|
set len [string length $overflowword1]
|
|
set word $overflowword1
|
|
} else {
|
|
set len [string length $overflowword2]
|
|
set word $overflowword1
|
|
}
|
|
set rpt [expr 1024 * 1024 / $len]
|
|
incr rpt
|
|
set str [repeat $word $rpt]
|
|
}
|
|
set ret [eval \
|
|
{$db put} $txn $pflags {$key [chop_data $method $str]}]
|
|
error_check_good put $ret 0
|
|
incr count
|
|
}
|
|
error_check_good txn [$t commit] 0
|
|
error_check_good txn_checkpoint [$env txn_checkpoint] 0
|
|
close $did
|
|
if { $repdb == "NULL" } {
|
|
error_check_good rep_close [$db close] 0
|
|
}
|
|
}
|
|
|
|
proc rep_test_upg { method env repdb {nentries 10000} \
|
|
{start 0} {skip 0} {needpad 0} {inmem 0} args } {
|
|
|
|
source ./include.tcl
|
|
|
|
#
|
|
# Open the db if one isn't given. Close before exit.
|
|
#
|
|
if { $repdb == "NULL" } {
|
|
if { $inmem == 1 } {
|
|
set testfile { "" "test.db" }
|
|
} else {
|
|
set testfile "test.db"
|
|
}
|
|
set largs [convert_args $method $args]
|
|
set omethod [convert_method $method]
|
|
set db [eval {berkdb_open_noerr} -env $env -auto_commit\
|
|
-create -mode 0644 $omethod $largs $testfile]
|
|
error_check_good reptest_db [is_valid_db $db] TRUE
|
|
} else {
|
|
set db $repdb
|
|
}
|
|
|
|
set pid [pid]
|
|
puts "\t\tRep_test_upg($pid): $method $nentries key/data pairs starting at $start"
|
|
set did [open $dict]
|
|
|
|
# The "start" variable determines the record number to start
|
|
# with, if we're using record numbers. The "skip" variable
|
|
# determines which dictionary entry to start with. In normal
|
|
# use, skip is equal to start.
|
|
|
|
if { $skip != 0 } {
|
|
for { set count 0 } { $count < $skip } { incr count } {
|
|
gets $did str
|
|
}
|
|
}
|
|
set pflags ""
|
|
set gflags ""
|
|
set txn ""
|
|
|
|
if { [is_record_based $method] == 1 } {
|
|
append gflags " -recno"
|
|
}
|
|
puts "\t\tRep_test.a: put/get loop"
|
|
# Here is the loop where we put and get each key/data pair
|
|
set count 0
|
|
|
|
# Checkpoint 10 times during the run, but not more
|
|
# frequently than every 5 entries.
|
|
set checkfreq [expr $nentries / 10]
|
|
|
|
# Abort occasionally during the run.
|
|
set abortfreq [expr $nentries / 15]
|
|
|
|
while { [gets $did str] != -1 && $count < $nentries } {
|
|
if { [is_record_based $method] == 1 } {
|
|
global kvals
|
|
|
|
set key [expr $count + 1 + $start]
|
|
if { 0xffffffff > 0 && $key > 0xffffffff } {
|
|
set key [expr $key - 0x100000000]
|
|
}
|
|
if { $key == 0 || $key - 0xffffffff == 1 } {
|
|
incr key
|
|
incr count
|
|
}
|
|
set kvals($key) [pad_data $method $str]
|
|
} else {
|
|
#
|
|
# With upgrade test, we run the same test several
|
|
# times with the same database. We want to have
|
|
# some overwritten records and some new records.
|
|
# Therefore append our pid to half the keys.
|
|
#
|
|
if { $count % 2 } {
|
|
set key $str.$pid
|
|
} else {
|
|
set key $str
|
|
}
|
|
set str [reverse $str]
|
|
}
|
|
#
|
|
# We want to make sure we send in exactly the same
|
|
# length data so that LSNs match up for some tests
|
|
# in replication (rep021).
|
|
#
|
|
if { [is_fixed_length $method] == 1 && $needpad } {
|
|
#
|
|
# Make it something visible and obvious, 'A'.
|
|
#
|
|
set p 65
|
|
set str [make_fixed_length $method $str $p]
|
|
set kvals($key) $str
|
|
}
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set txn "-txn $t"
|
|
# puts "rep_test_upg: put $count of $nentries: key $key, data $str"
|
|
set ret [eval \
|
|
{$db put} $txn $pflags {$key [chop_data $method $str]}]
|
|
error_check_good put $ret 0
|
|
error_check_good txn [$t commit] 0
|
|
|
|
if { $checkfreq < 5 } {
|
|
set checkfreq 5
|
|
}
|
|
if { $abortfreq < 3 } {
|
|
set abortfreq 3
|
|
}
|
|
#
|
|
# Do a few aborted transactions to test that
|
|
# aborts don't get processed on clients and the
|
|
# master handles them properly. Just abort
|
|
# trying to delete the key we just added.
|
|
#
|
|
if { $count % $abortfreq == 0 } {
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set ret [$db del -txn $t $key]
|
|
error_check_good txn [$t abort] 0
|
|
}
|
|
if { $count % $checkfreq == 0 } {
|
|
error_check_good txn_checkpoint($count) \
|
|
[$env txn_checkpoint] 0
|
|
}
|
|
incr count
|
|
}
|
|
close $did
|
|
if { $repdb == "NULL" } {
|
|
error_check_good rep_close [$db close] 0
|
|
}
|
|
}
|
|
|
|
proc rep_test_upg.check { key data } {
|
|
#
|
|
# If the key has the pid attached, strip it off before checking.
|
|
# If the key does not have the pid attached, then it is a recno
|
|
# and we're done.
|
|
#
|
|
set i [string first . $key]
|
|
if { $i != -1 } {
|
|
set key [string replace $key $i end]
|
|
}
|
|
error_check_good "key/data mismatch" $data [reverse $key]
|
|
}
|
|
|
|
proc rep_test_upg.recno.check { key data } {
|
|
#
|
|
# If we're a recno database we better not have a pid in the key.
|
|
# Otherwise we're done.
|
|
#
|
|
set i [string first . $key]
|
|
error_check_good pid $i -1
|
|
}
|
|
|
|
# In a situation where logs are being archived off a master, it's
|
|
# possible for a client to get so far behind that there is a gap
|
|
# where the highest numbered client log file is lower than the
|
|
# lowest numbered master log file, creating the need for internal
|
|
# initialization of the client.
|
|
#
|
|
# This proc creates that situation for use in internal init tests.
|
|
# It closes the selected client and pushes the master forward
|
|
# while archiving the master's log files.
|
|
|
|
proc push_master_ahead { method masterenv masterdir m_logtype \
|
|
clientenv clientid db start niter flags largs } {
|
|
global util_path
|
|
|
|
# Identify last client log file and then close the client.
|
|
puts "\t\tRep_push.a: Close client."
|
|
set last_client_log [get_logfile $clientenv last]
|
|
error_check_good client_close [$clientenv close] 0
|
|
|
|
set stop 0
|
|
while { $stop == 0 } {
|
|
# Run rep_test in the master. Discard messages
|
|
# for the closed client.
|
|
puts "\t\tRep_push.b: Pushing master ahead."
|
|
eval rep_test \
|
|
$method $masterenv $db $niter $start $start 0 $largs
|
|
incr start $niter
|
|
replclear $clientid
|
|
|
|
puts "\t\tRep_push.c: Run db_archive on master."
|
|
if { $m_logtype == "on-disk"} {
|
|
$masterenv log_flush
|
|
eval exec $util_path/db_archive $flags -d -h $masterdir
|
|
}
|
|
|
|
# Check to see whether the gap has appeared yet.
|
|
set first_master_log [get_logfile $masterenv first]
|
|
if { $first_master_log > $last_client_log } {
|
|
set stop 1
|
|
}
|
|
}
|
|
return $start
|
|
}
|
|
|
|
proc run_repmgr_tests { which {display 0} {run 1} } {
|
|
source ./include.tcl
|
|
if { !$display && $is_freebsd_test == 1 } {
|
|
puts "Skipping replication manager tests on FreeBSD platform."
|
|
return
|
|
}
|
|
|
|
if { $which == "basic" } {
|
|
set testname basic_repmgr_test
|
|
} elseif { $which == "election" } {
|
|
set testname basic_repmgr_election_test
|
|
} elseif { $which == "init" } {
|
|
set testname basic_repmgr_init_test
|
|
} else {
|
|
puts "No repmgr test of that name"
|
|
return
|
|
}
|
|
|
|
if { $run } {
|
|
puts "Running all cases of $testname."
|
|
}
|
|
|
|
set niter 100
|
|
foreach inmemdb { 0 1 } {
|
|
foreach inmemlog { 0 1 } {
|
|
foreach inmemrep { 0 1 } {
|
|
foreach envprivate { 0 1 } {
|
|
foreach bulk { 0 1 } {
|
|
if { $display } {
|
|
puts "$testname $niter $inmemdb $inmemlog \
|
|
$inmemrep $envprivate $bulk"
|
|
}
|
|
|
|
if { $run } {
|
|
if { [catch {$testname $niter $inmemdb $inmemlog \
|
|
$inmemrep $envprivate $bulk} res ] } {
|
|
set databases_in_memory 0
|
|
error "FAIL: $res"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc print_repmgr_headers { test niter inmemdb inmemlog inmemrep \
|
|
envprivate bulk } {
|
|
|
|
set dbmsg "on-disk databases"
|
|
if { $inmemdb } {
|
|
set dbmsg "in-memory databases"
|
|
}
|
|
|
|
set logmsg "on-disk logs"
|
|
if { $inmemlog } {
|
|
set logmsg "in-memory logs"
|
|
}
|
|
|
|
set repmsg "on-disk rep files"
|
|
if { $inmemrep } {
|
|
set repmsg "in-memory rep files"
|
|
}
|
|
|
|
set regmsg "on-disk region files"
|
|
if { $envprivate } {
|
|
set regmsg "in-memory region files"
|
|
}
|
|
|
|
set bulkmsg "regular processing"
|
|
if { $bulk } {
|
|
set bulkmsg "bulk processing"
|
|
}
|
|
|
|
puts "\n$test with:"
|
|
puts "\t$dbmsg"
|
|
puts "\t$logmsg"
|
|
puts "\t$repmsg"
|
|
puts "\t$regmsg"
|
|
puts "\t$bulkmsg"
|
|
puts -nonewline "To reproduce this case: $test "
|
|
puts "$niter $inmemdb $inmemlog $inmemrep $envprivate $bulk"
|
|
}
|
|
|
|
# Verify that no replication files are present in a given directory.
|
|
# This checks for the gen, egen, internal init, temp db and page db
|
|
# files.
|
|
#
|
|
proc no_rep_files_on_disk { dir } {
|
|
error_check_good nogen [file exists "$dir/__db.rep.gen"] 0
|
|
error_check_good noegen [file exists "$dir/__db.rep.egen"] 0
|
|
error_check_good noinit [file exists "$dir/__db.rep.init"] 0
|
|
error_check_good notmpdb [file exists "$dir/__db.rep.db"] 0
|
|
error_check_good nopgdb [file exists "$dir/__db.reppg.db"] 0
|
|
error_check_good nosysdb [file exists "$dir/__db.rep.system"] 0
|
|
}
|
|
|
|
proc process_msgs { elist {perm_response 0} {dupp NONE} {errp NONE} \
|
|
{upg 0} } {
|
|
if { $perm_response == 1 } {
|
|
global perm_response_list
|
|
set perm_response_list {{}}
|
|
}
|
|
|
|
if { [string compare $dupp NONE] != 0 } {
|
|
upvar $dupp dupmaster
|
|
set dupmaster 0
|
|
} else {
|
|
set dupmaster NONE
|
|
}
|
|
|
|
if { [string compare $errp NONE] != 0 } {
|
|
upvar $errp errorp
|
|
set errorp 0
|
|
set var_name errorp
|
|
} else {
|
|
set errorp NONE
|
|
set var_name NONE
|
|
}
|
|
|
|
set upgcount 0
|
|
while { 1 } {
|
|
set nproced 0
|
|
incr nproced [proc_msgs_once $elist dupmaster $var_name]
|
|
#
|
|
# If we're running the upgrade test, we are running only
|
|
# our own env, we need to loop a bit to allow the other
|
|
# upgrade procs to run and reply to our messages.
|
|
#
|
|
if { $upg == 1 && $upgcount < 10 } {
|
|
tclsleep 2
|
|
incr upgcount
|
|
continue
|
|
}
|
|
if { $nproced == 0 } {
|
|
break
|
|
} else {
|
|
set upgcount 0
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
proc proc_msgs_once { elist {dupp NONE} {errp NONE} } {
|
|
global noenv_messaging
|
|
|
|
if { [string compare $dupp NONE] != 0 } {
|
|
upvar $dupp dupmaster
|
|
set dupmaster 0
|
|
} else {
|
|
set dupmaster NONE
|
|
}
|
|
|
|
if { [string compare $errp NONE] != 0 } {
|
|
upvar $errp errorp
|
|
set errorp 0
|
|
set var_name errorp
|
|
} else {
|
|
set errorp NONE
|
|
set var_name NONE
|
|
}
|
|
|
|
set nproced 0
|
|
foreach pair $elist {
|
|
set envname [lindex $pair 0]
|
|
set envid [lindex $pair 1]
|
|
#
|
|
# If we need to send in all the other args
|
|
# puts "Call replpq with on $envid"
|
|
if { $noenv_messaging } {
|
|
incr nproced [replprocessqueue_noenv $envname $envid \
|
|
0 NONE dupmaster $var_name]
|
|
} else {
|
|
incr nproced [replprocessqueue $envname $envid \
|
|
0 NONE dupmaster $var_name]
|
|
}
|
|
#
|
|
# If the user is expecting to handle an error and we get
|
|
# one, return the error immediately.
|
|
#
|
|
if { $dupmaster != 0 && $dupmaster != "NONE" } {
|
|
return 0
|
|
}
|
|
if { $errorp != 0 && $errorp != "NONE" } {
|
|
# puts "Returning due to error $errorp"
|
|
return 0
|
|
}
|
|
}
|
|
return $nproced
|
|
}
|
|
|
|
proc rep_verify { masterdir masterenv clientdir clientenv \
|
|
{compare_shared_portion 0} {match 1} {logcompare 1} \
|
|
{dbname "test.db"} {datadir ""} } {
|
|
global util_path
|
|
global encrypt
|
|
global passwd
|
|
global databases_in_memory
|
|
global repfiles_in_memory
|
|
global env_private
|
|
|
|
# Whether a named database is in-memory or on-disk, only the
|
|
# the name itself is passed in. Here we do the syntax adjustment
|
|
# from "test.db" to { "" "test.db" } for in-memory databases.
|
|
#
|
|
if { $databases_in_memory && $dbname != "NULL" } {
|
|
set dbname " {} $dbname "
|
|
}
|
|
|
|
# Check locations of dbs, repfiles, region files.
|
|
if { $dbname != "NULL" } {
|
|
check_db_location $masterenv $dbname $datadir
|
|
check_db_location $clientenv $dbname $datadir
|
|
}
|
|
|
|
if { $repfiles_in_memory } {
|
|
no_rep_files_on_disk $masterdir
|
|
no_rep_files_on_disk $clientdir
|
|
}
|
|
if { $env_private } {
|
|
no_region_files_on_disk $masterdir
|
|
no_region_files_on_disk $clientdir
|
|
}
|
|
|
|
# The logcompare flag indicates whether to compare logs.
|
|
# Sometimes we run a test where rep_verify is run twice with
|
|
# no intervening processing of messages. If that test is
|
|
# on a build with debug_rop enabled, the master's log is
|
|
# altered by the first rep_verify, and the second rep_verify
|
|
# will fail.
|
|
# To avoid this, skip the log comparison on the second rep_verify
|
|
# by specifying logcompare == 0.
|
|
#
|
|
if { $logcompare } {
|
|
set msg "Logs and databases"
|
|
} else {
|
|
set msg "Databases ($dbname)"
|
|
}
|
|
|
|
if { $match } {
|
|
puts "\t\tRep_verify: $clientdir: $msg should match"
|
|
} else {
|
|
puts "\t\tRep_verify: $clientdir: $msg should not match"
|
|
}
|
|
# Check that master and client logs and dbs are identical.
|
|
|
|
# Logs first, if specified ...
|
|
#
|
|
# If compare_shared_portion is set, run db_printlog on the log
|
|
# subset that both client and master have. Either the client or
|
|
# the master may have more (earlier) log files, due to internal
|
|
# initialization, in-memory log wraparound, or other causes.
|
|
#
|
|
if { $logcompare } {
|
|
error_check_good logcmp \
|
|
[logcmp $masterenv $clientenv $compare_shared_portion] 0
|
|
|
|
if { $dbname == "NULL" } {
|
|
return
|
|
}
|
|
}
|
|
|
|
# ... now the databases.
|
|
#
|
|
# We're defensive here and throw an error if a database does
|
|
# not exist. If opening the first database succeeded but the
|
|
# second failed, we close the first before reporting the error.
|
|
#
|
|
if { [catch {eval {berkdb_open_noerr} -env $masterenv\
|
|
-rdonly $dbname} db1] } {
|
|
error "FAIL:\
|
|
Unable to open first db $dbname in rep_verify: $db1"
|
|
}
|
|
if { [catch {eval {berkdb_open_noerr} -env $clientenv\
|
|
-rdonly $dbname} db2] } {
|
|
error_check_good close_db1 [$db1 close] 0
|
|
error "FAIL:\
|
|
Unable to open second db $dbname in rep_verify: $db2"
|
|
}
|
|
|
|
# db_compare uses the database handles to do the comparison, and
|
|
# we pass in the $mumbledir/$dbname string as a label to make it
|
|
# easier to identify the offending database in case of failure.
|
|
# Therefore this will work for both in-memory and on-disk databases.
|
|
if { $match } {
|
|
error_check_good [concat comparedbs. $dbname] [db_compare \
|
|
$db1 $db2 $masterdir/$dbname $clientdir/$dbname] 0
|
|
} else {
|
|
error_check_bad comparedbs [db_compare \
|
|
$db1 $db2 $masterdir/$dbname $clientdir/$dbname] 0
|
|
}
|
|
error_check_good db1_close [$db1 close] 0
|
|
error_check_good db2_close [$db2 close] 0
|
|
}
|
|
|
|
proc rep_verify_inmem { masterenv clientenv mdb cdb } {
|
|
#
|
|
# Can't use rep_verify to compare the logs because each
|
|
# commit record from db_printlog shows the database name
|
|
# as text on the master and as the file uid on the client
|
|
# because the client cannot find the "file".
|
|
#
|
|
# !!! Check the LSN first. Otherwise the DB->stat for the
|
|
# number of records will write a log record on the master if
|
|
# the build is configured for debug_rop. Work around that issue.
|
|
#
|
|
set mlsn [next_expected_lsn $masterenv]
|
|
set clsn [next_expected_lsn $clientenv]
|
|
error_check_good lsn $mlsn $clsn
|
|
|
|
set mrecs [stat_field $mdb stat "Number of records"]
|
|
set crecs [stat_field $cdb stat "Number of records"]
|
|
error_check_good recs $mrecs $crecs
|
|
}
|
|
|
|
# NOTE: This routine has been copied to ../test/sql/bdb_util.tcl
|
|
# and changes to it should be made in both places because the SQL
|
|
# tests are currently independent of the core tests.
|
|
#
|
|
# Return a list of TCP port numbers that are not currently in use on
|
|
# the local system. Note that this doesn't actually reserve the
|
|
# ports, so it's possible that by the time the caller tries to use
|
|
# them, another process could have taken one of them. But for our
|
|
# purposes that's unlikely enough that this is still useful: it's
|
|
# still better than trying to find hard-coded port numbers that will
|
|
# always be available.
|
|
#
|
|
# Using a starting baseport value that falls in the non-ephemeral port
|
|
# range on most platforms. Can override starting baseport by setting
|
|
# environment variable BDBBASEPORT.
|
|
#
|
|
proc available_ports { n { rangeincr 10 } } {
|
|
global env
|
|
|
|
if { [info exists env(BDBBASEPORT)] } {
|
|
set baseport $env(BDBBASEPORT)
|
|
} else {
|
|
set baseport 30100
|
|
}
|
|
|
|
# Try sets of contiguous ports ascending from baseport.
|
|
for { set i $baseport } { $i < $baseport + $rangeincr * 100 } \
|
|
{ incr i $rangeincr } {
|
|
set ports {}
|
|
set socks {}
|
|
set numports $n
|
|
set curport $i
|
|
|
|
# Try one set of contiguous ports.
|
|
while { [incr numports -1] >= 0 } {
|
|
incr curport
|
|
if [catch { socket -server Unused \
|
|
-myaddr localhost $curport } sock] {
|
|
# A port is unavailable, try another set.
|
|
break
|
|
}
|
|
lappend socks $sock
|
|
lappend ports $curport
|
|
}
|
|
foreach sock $socks {
|
|
close $sock
|
|
}
|
|
if { $numports == -1 } {
|
|
# We have all the ports we need.
|
|
break
|
|
}
|
|
}
|
|
if { $numports == -1 } {
|
|
return $ports
|
|
} else {
|
|
error "available_ports: could not get ports for $baseport"
|
|
}
|
|
}
|
|
|
|
# Return the corresponding site number for an individual port number
|
|
# previously returned by available_ports. This procedure assumes that
|
|
# the baseport number, n and rangeincr value are unchanged from the
|
|
# original call to available_ports. If a port value is supplied that
|
|
# is outside the expected baseport, n and rangeincr range, this procedure
|
|
# returns -1.
|
|
#
|
|
# As in available_ports, it uses a starting baseport number that falls
|
|
# in the non-ephemeral range on most platforms, which can be overridden
|
|
# by setting environment variable BDBBASEPORT.
|
|
#
|
|
proc site_from_port { port n { rangeincr 10 } } {
|
|
global env
|
|
|
|
if { [info exists env(BDBBASEPORT)] } {
|
|
set baseport $env(BDBBASEPORT)
|
|
} else {
|
|
set baseport 30100
|
|
}
|
|
|
|
if { $port > $baseport && $port < $baseport + $rangeincr * 100 } {
|
|
set site [expr ($port - $baseport) % $rangeincr]
|
|
if { $site <= $n } {
|
|
return $site
|
|
}
|
|
}
|
|
return -1
|
|
}
|
|
|
|
# Wait (a limited amount of time) for an arbitrary condition to become true,
|
|
# polling once per second. If time runs out we throw an error: a successful
|
|
# return implies the condition is indeed true.
|
|
#
|
|
proc await_condition { cond { limit 20 } } {
|
|
for {set i 0} {$i < $limit} {incr i} {
|
|
if {[uplevel 1 [list expr $cond]]} {
|
|
return
|
|
}
|
|
tclsleep 1
|
|
}
|
|
error "FAIL: condition \{$cond\} not achieved in $limit seconds."
|
|
}
|
|
|
|
proc await_startup_done { env { limit 20 } } {
|
|
await_condition {[stat_field $env rep_stat "Startup complete"]} $limit
|
|
}
|
|
|
|
proc await_event { env event_name { limit 20 } } {
|
|
await_condition {[is_event_present $env $event_name]} $limit
|
|
return [find_event [$env event_info] $event_name]
|
|
}
|
|
|
|
# Wait (a limited amount of time) for an election to yield the expected
|
|
# environment as winner.
|
|
#
|
|
proc await_expected_master { env { limit 20 } } {
|
|
await_condition {[stat_field $env rep_stat "Role"] == "master"} $limit
|
|
}
|
|
|
|
proc do_leaseop { env db method key envlist { domsgs 1 } } {
|
|
global alphabet
|
|
|
|
#
|
|
# Put a txn to the database. Process messages to envlist
|
|
# if directed to do so. Read data on the master, ignoring
|
|
# leases (should always succeed).
|
|
#
|
|
set num [berkdb random_int 1 100]
|
|
set data $alphabet.$num
|
|
set t [$env txn]
|
|
error_check_good txn [is_valid_txn $t $env] TRUE
|
|
set txn "-txn $t"
|
|
set ret [eval \
|
|
{$db put} $txn {$key [chop_data $method $data]}]
|
|
error_check_good put $ret 0
|
|
error_check_good txn [$t commit] 0
|
|
|
|
if { $domsgs } {
|
|
process_msgs $envlist
|
|
}
|
|
|
|
#
|
|
# Now make sure we can successfully read on the master
|
|
# if we ignore leases. That should always work. The
|
|
# caller will do any lease related calls and checks
|
|
# that are specific to the test.
|
|
#
|
|
set kd [$db get -nolease $key]
|
|
set curs [$db cursor]
|
|
set ckd [$curs get -nolease -set $key]
|
|
$curs close
|
|
error_check_good kd [llength $kd] 1
|
|
error_check_good ckd [llength $ckd] 1
|
|
}
|
|
|
|
#
|
|
# Get the given key, expecting status depending on whether leases
|
|
# are currently expected to be valid or not.
|
|
#
|
|
proc check_leaseget { db key getarg status } {
|
|
set stat [catch {eval {$db get} $getarg $key} kd]
|
|
if { $status != 0 } {
|
|
error_check_good get_result $stat 1
|
|
error_check_good kd_check \
|
|
[is_substr $kd $status] 1
|
|
} else {
|
|
error_check_good get_result_good $stat $status
|
|
error_check_good dbkey [lindex [lindex $kd 0] 0] $key
|
|
}
|
|
set curs [$db cursor]
|
|
set stat [catch {eval {$curs get} $getarg -set $key} kd]
|
|
if { $status != 0 } {
|
|
error_check_good get_result2 $stat 1
|
|
error_check_good kd_check \
|
|
[is_substr $kd $status] 1
|
|
} else {
|
|
error_check_good get_result2_good $stat $status
|
|
error_check_good dbckey [lindex [lindex $kd 0] 0] $key
|
|
}
|
|
$curs close
|
|
}
|
|
|
|
# Simple utility to check a client database for expected values. It does not
|
|
# handle dup keys.
|
|
#
|
|
proc verify_client_data { env db items } {
|
|
set dbp [berkdb open -env $env $db]
|
|
foreach i $items {
|
|
foreach {key expected_value} $i {
|
|
set results [$dbp get $key]
|
|
error_check_good result_length [llength $results] 1
|
|
set value [lindex $results 0 1]
|
|
error_check_good expected_value $value $expected_value
|
|
}
|
|
}
|
|
$dbp close
|
|
}
|
|
|
|
proc make_dbconfig { dir cnfs } {
|
|
global rep_verbose
|
|
|
|
set f [open "$dir/DB_CONFIG" "w"]
|
|
foreach line $cnfs {
|
|
puts $f $line
|
|
}
|
|
if {$rep_verbose} {
|
|
puts $f "set_verbose DB_VERB_REPLICATION"
|
|
}
|
|
close $f
|
|
}
|
|
|
|
proc open_site_prog { cmds } {
|
|
|
|
set site_prog [setup_site_prog]
|
|
|
|
set s [open "| $site_prog" "r+"]
|
|
fconfigure $s -buffering line
|
|
set synced yes
|
|
foreach cmd $cmds {
|
|
puts $s $cmd
|
|
if {[lindex $cmd 0] == "start"} {
|
|
gets $s
|
|
set synced yes
|
|
} else {
|
|
set synced no
|
|
}
|
|
}
|
|
if {! $synced} {
|
|
puts $s "echo done"
|
|
gets $s
|
|
}
|
|
return $s
|
|
}
|
|
|
|
proc setup_site_prog { } {
|
|
source ./include.tcl
|
|
|
|
# Generate the proper executable name for the system.
|
|
if { $is_windows_test } {
|
|
set repsite_executable db_repsite.exe
|
|
} else {
|
|
set repsite_executable db_repsite
|
|
}
|
|
|
|
# Check whether the executable exists.
|
|
if { [file exists $util_path/$repsite_executable] == 0 } {
|
|
error "Skipping: db_repsite executable\
|
|
not found. Is it built?"
|
|
} else {
|
|
set site_prog $util_path/$repsite_executable
|
|
}
|
|
return $site_prog
|
|
}
|
|
|
|
proc next_expected_lsn { env } {
|
|
return [stat_field $env rep_stat "Next LSN expected"]
|
|
}
|
|
|
|
proc lsn_file { lsn } {
|
|
if { [llength $lsn] != 2 } {
|
|
error "not a valid LSN: $lsn"
|
|
}
|
|
|
|
return [lindex $lsn 0]
|
|
}
|
|
|
|
proc assert_rep_flag { dir flag value } {
|
|
global util_path
|
|
|
|
set stat [exec $util_path/db_stat -N -RA -h $dir]
|
|
set present [is_substr $stat $flag]
|
|
error_check_good expected.flag.$flag $present $value
|
|
}
|
|
|
|
# Kind of like an abbreviated lsearch(3tcl), except that the list must be a list
|
|
# of lists, and we search each list for a key in the "head" (0-th) position.
|
|
#
|
|
# lsearch_head ?option? list_of_lists key
|
|
#
|
|
# "option" can be -index or -inline (or may be omitted)
|
|
#
|
|
proc lsearch_head { args } {
|
|
if {[llength $args] > 2} {
|
|
foreach { how lists key } $args {}
|
|
} else {
|
|
set how -index
|
|
foreach { lists key } $args {}
|
|
}
|
|
|
|
set i 0
|
|
foreach list $lists {
|
|
if { $key eq [lindex $list 0] } {
|
|
if {$how eq "-inline"} {
|
|
return $list
|
|
} else {
|
|
return $i
|
|
}
|
|
}
|
|
incr i
|
|
}
|
|
if { $how eq "-inline" } {
|
|
return ""
|
|
} else {
|
|
return -1
|
|
}
|
|
}
|
|
|
|
#
|
|
# To build a profiled version of BDB and tclsh and run the rep
|
|
# tests individually with profiling you need the following steps:
|
|
#
|
|
# 0. NOTE: References to 'X' below for BDB versions obviously need
|
|
# the current release version number used.
|
|
# 1. Need to build a static, profiled version of DB and install it.
|
|
# ../dist/configure with --disable-shared and --enable-static.
|
|
#
|
|
# NOTE: Assumes you already have --enable-debug configured.
|
|
#
|
|
# (if you use the script 'dbconf' the 'args' line looks like:)
|
|
# args="--disable-shared --enable-static --with-tcl=/usr/local/lib --enable-test $args"
|
|
#
|
|
# Edit build_unix/Makefile and add '-pg' to CFLAGS and LDFLAGS.
|
|
# make
|
|
# sudo make install
|
|
#
|
|
# 2. Need to make sure LD_LIBRARY_PATH in your .cshrc is pointing to the
|
|
# right path for the profiled DB, such as
|
|
# ... :./.libs:/usr/local/BerkeleyDB.5.X/lib: ...
|
|
#
|
|
# source your new .cshrc if necessary.
|
|
#
|
|
# [NOTE: Your Tcl version may vary. Use the paths and versions as a
|
|
# guide. Mostly it should be the same. These steps work for Tcl 5.8.]
|
|
# 3. Build a new, profiling tclsh:
|
|
# Go to your Tcl source directory, e.g. <..srcpath>/tcl8.5.8/unix
|
|
# make clean
|
|
# ./configure --disable-shared
|
|
#
|
|
# Edit the generated Makefile:
|
|
# Add '-L /usr/local/BerkeleyDB.5.X/lib' to tclsh target
|
|
# after ${TCLSH_OBJS}.
|
|
# Add '-ldb_tcl-5.X' to tclsh target before -ltcl8.5....
|
|
# Should look something like this:
|
|
# ${CC} ${LDFLAGS} ${TCLSH_OBJS} -L/usr/local/BerkeleyDB.5.0/lib -L/users/sue/src/tcl8.5.8/unix -ldb_tcl-5.0 -ltcl8.5 ${LIBS} \
|
|
# ${CC_SEARCH_FLAGS} -o tclsh
|
|
#
|
|
# May want to switch CFLAGS to CFLAGS_DEBUG.
|
|
# Add -pg to CFLAGS.
|
|
# Add -pthread to CFLAGS if it isn't already there.
|
|
# Need to add '-static -pg' to LDFLAGS.
|
|
# Change LDFLAGS to use $(LDFLAGS_DEBUG) instead of OPTIMIZE if needed.
|
|
# Change TCL_LIB_FILE to '.a' from '.so' if needed
|
|
#
|
|
# 4. Add Db_tcl_Init call to tclAppInit.c and an extern:
|
|
#====================
|
|
#*** tclAppInit.c.orig Mon Mar 17 12:15:42 2008
|
|
#--- tclAppInit.c Mon Mar 17 12:15:23 2008
|
|
#***************
|
|
#*** 30,35 ****
|
|
#--- 30,37 ----
|
|
#
|
|
# #endif /* TCL_TEST */
|
|
#
|
|
#+ extern int Db_tcl_Init _ANSI_ARGS_((Tcl_Interp *interp));
|
|
#+
|
|
# #ifdef TCL_XT_TEST
|
|
# extern void XtToolkitInitialize _ANSI_ARGS_((void));
|
|
# extern int Tclxttest_Init _ANSI_ARGS_((Tcl_Interp *interp));
|
|
#***************
|
|
#*** 145,150 ****
|
|
#--- 147,153 ----
|
|
# Procbodytest_SafeInit);
|
|
# #endif /* TCL_TEST */
|
|
#
|
|
#+ Db_tcl_Init(interp);
|
|
# /*
|
|
# * Call the init procedures for included packages. Each call should
|
|
# * look like this:
|
|
#
|
|
#====================
|
|
# 5. Build tclsh with 'make' but I do NOT suggest 'make install'.
|
|
#
|
|
# Test it has BDB built-in properly:
|
|
# Run ./tclsh in Tcl src (unix) directory:
|
|
# % berkdb version
|
|
# [Should show current BDB version.]
|
|
# % ^D
|
|
#
|
|
# Current directory should now have a tclsh.gmon or gmon.out file.
|
|
#
|
|
#
|
|
# 6. Edit build_unix/include.tcl to point to profiled tclsh and
|
|
# the static DB library:
|
|
#
|
|
# set tclsh_path <path to tclsrc>/tcl8.5.8/unix/tclsh
|
|
# set tcllib .libs/libdb_tcl-5.X.a
|
|
#
|
|
# 7. Comment out 'load $tcllib' in test/test.tcl
|
|
#
|
|
# 8. Run *your newly generated, profiled* tclsh as you normally would,
|
|
# including 'source ../test/test.tcl'
|
|
# build_unix% <path to tclsrc>/unix/tclsh
|
|
# % source ../test/test.tcl
|
|
#
|
|
# 9. Each test will be run in a separate tclsh and profiled individually.
|
|
# In the 'build_unix' directory you'll then find a <testname>.OUT file
|
|
# that contains the profile output. Run:
|
|
# % run_rep_gprof [start reptest name]
|
|
# This form runs all rep tests, starting with the given
|
|
# reptest name, or rep001 if no name is given.
|
|
# % run_gprof <testname>
|
|
# This form runs only the (required) specified test.
|
|
# NOTE: This form can be used on any individual test, not
|
|
# just replication tests. However, it uses 'run_test' so it
|
|
# must be a test that can be run through all the methods.
|
|
#
|
|
proc run_rep_gprof { {starttest rep001} } {
|
|
global test_names
|
|
|
|
set tindex [lsearch $test_names(rep) $starttest]
|
|
if { $tindex == -1 } {
|
|
set tindex 0
|
|
}
|
|
set rlist [lrange $test_names(rep) $tindex end]
|
|
run_gprof_int $rlist
|
|
}
|
|
|
|
proc run_gprof { testname } {
|
|
global test_names
|
|
|
|
set rlist [list $testname]
|
|
run_gprof_int $rlist
|
|
}
|
|
|
|
proc run_gprof_int { rlist } {
|
|
global one_test
|
|
source ./include.tcl
|
|
|
|
foreach test $rlist {
|
|
puts "Test $test start: [timestamp]"
|
|
fileremove -f $test.OUT
|
|
if [catch {exec $tclsh_path << \
|
|
"global one_test; set one_test $one_test; \
|
|
source $test_path/test.tcl; run_test $test" \
|
|
>>& ALL.OUT } res] {
|
|
set o [open ALL.OUT a]
|
|
puts $o "FAIL: run_gprof_int $test: $res"
|
|
close $o
|
|
}
|
|
puts "Test $test gprof: [timestamp]"
|
|
set gmonfile NULL
|
|
set known_gmons { tclsh.gmon gmon.out }
|
|
foreach gmon $known_gmons {
|
|
if { [file exists $gmon] } {
|
|
set gmonfile $gmon
|
|
break
|
|
}
|
|
}
|
|
if { $gmonfile != "NULL" } {
|
|
set stat [catch {exec gprof $tclsh_path $gmonfile \
|
|
>>& $test.OUT} ret]
|
|
} else {
|
|
puts "FAIL: Could not find execution profile in \
|
|
either tclsh.gmon or gmon.out."
|
|
}
|
|
puts "Test $test complete: [timestamp]"
|
|
}
|
|
}
|
|
|
|
#
|
|
# Make a DB_CONFIG file for a site about to run a db_replicate test.
|
|
# Args are
|
|
# sitedir - the directory for this site
|
|
# i - my site index/number
|
|
# pri - my priority
|
|
#
|
|
proc replicate_make_config { sitedir i pri } {
|
|
#
|
|
# Generate global config values that should be the same
|
|
# across all sites, such as number of sites and log size, etc.
|
|
#
|
|
set default_cfglist {
|
|
{ "set_flags" "DB_TXN_NOSYNC" }
|
|
{ "rep_set_request" "150000 2400000" }
|
|
{ "rep_set_timeout" "db_rep_checkpoint_delay 0" }
|
|
{ "rep_set_timeout" "db_rep_connection_retry 2000000" }
|
|
{ "rep_set_timeout" "db_rep_heartbeat_monitor 5000000" }
|
|
{ "rep_set_timeout" "db_rep_heartbeat_send 1000000" }
|
|
{ "set_cachesize" "0 4194304 1" }
|
|
{ "set_lk_detect" "db_lock_default" }
|
|
{ "rep_set_config" "db_repmgr_conf_2site_strict" }
|
|
}
|
|
|
|
#
|
|
# Otherwise set up per-site config information
|
|
#
|
|
set cfglist $default_cfglist
|
|
|
|
set litem [list rep_set_priority $pri]
|
|
lappend cfglist $litem
|
|
|
|
#
|
|
# Now set up the local and remote ports. Use 49210 so that
|
|
# we don't collide with db_reptest which uses 49200. For
|
|
# now, we have site 0 know about no one, and all other sites
|
|
# know about site 0. Do not use peers for now.
|
|
#
|
|
set baseport 49210
|
|
set rporttype NULL
|
|
set lport [expr $baseport + $i]
|
|
if { $i == 0 } {
|
|
set creator_flag "db_group_creator on"
|
|
} else {
|
|
set creator_flag ""
|
|
}
|
|
set litem [list repmgr_site \
|
|
"localhost $lport $creator_flag db_local_site on"]
|
|
lappend cfglist $litem
|
|
set peers 0
|
|
set p NULL
|
|
if { $i != 0 } {
|
|
set p $baseport
|
|
}
|
|
if { $peers } {
|
|
set remote_arg "db_repmgr_peer on"
|
|
} else {
|
|
set remote_arg ""
|
|
}
|
|
if { $p != "NULL" } {
|
|
set litem [list repmgr_site \
|
|
"localhost $p $remote_arg db_bootstrap_helper on"]
|
|
lappend cfglist $litem
|
|
}
|
|
#
|
|
# Now write out the DB_CONFIG file.
|
|
#
|
|
set cid [open $sitedir/DB_CONFIG a]
|
|
foreach c $cfglist {
|
|
set carg [subst [lindex $c 0]]
|
|
set cval [subst [lindex $c 1]]
|
|
puts $cid "$carg $cval"
|
|
}
|
|
close $cid
|
|
}
|