diff options
Diffstat (limited to 'bdb/test/mutex.tcl')
| -rw-r--r-- | bdb/test/mutex.tcl | 225 |
1 files changed, 0 insertions, 225 deletions
diff --git a/bdb/test/mutex.tcl b/bdb/test/mutex.tcl deleted file mode 100644 index 5300fb0c4a3..00000000000 --- a/bdb/test/mutex.tcl +++ /dev/null @@ -1,225 +0,0 @@ -# See the file LICENSE for redistribution information. -# -# Copyright (c) 1996, 1997, 1998, 1999, 2000 -# Sleepycat Software. All rights reserved. -# -# $Id: mutex.tcl,v 11.18 2000/09/01 19:24:59 krinsky Exp $ -# -# Exercise mutex functionality. -# Options are: -# -dir <directory in which to store mpool> -# -iter <iterations> -# -mdegree <number of mutexes per iteration> -# -nmutex <number of mutexes> -# -procs <number of processes to run> -# -wait <wait interval after getting locks> -proc mutex_usage {} { - puts stderr "mutex\n\t-dir <dir>\n\t-iter <iterations>" - puts stderr "\t-mdegree <locks per iteration>\n\t-nmutex <n>" - puts stderr "\t-procs <nprocs>" - puts stderr "\n\t-wait <max wait interval>" - return -} - -proc mutex { args } { - source ./include.tcl - - set dir db - set iter 500 - set mdegree 3 - set nmutex 20 - set procs 5 - set wait 2 - - for { set i 0 } { $i < [llength $args] } {incr i} { - switch -regexp -- [lindex $args $i] { - -d.* { incr i; set testdir [lindex $args $i] } - -i.* { incr i; set iter [lindex $args $i] } - -m.* { incr i; set mdegree [lindex $args $i] } - -n.* { incr i; set nmutex [lindex $args $i] } - -p.* { incr i; set procs [lindex $args $i] } - -w.* { incr i; set wait [lindex $args $i] } - default { - puts -nonewline "FAIL:[timestamp] Usage: " - mutex_usage - return - } - } - } - - if { [file exists $testdir/$dir] != 1 } { - file mkdir $testdir/$dir - } elseif { [file isdirectory $testdir/$dir ] != 1 } { - error "$testdir/$dir is not a directory" - } - - # Basic sanity tests - mutex001 $testdir $nmutex - - # Basic synchronization tests - mutex002 $testdir $nmutex - - # Multiprocess tests - mutex003 $testdir $iter $nmutex $procs $mdegree $wait -} - -proc mutex001 { dir nlocks } { - source ./include.tcl - - puts "Mutex001: Basic functionality" - env_cleanup $dir - - # Test open w/out create; should fail - error_check_bad \ - env_open [catch {berkdb env -lock -home $dir} env] 0 - - # Now open for real - set env [berkdb env -create -mode 0644 -lock -home $dir] - error_check_good env_open [is_valid_env $env] TRUE - - set m [$env mutex 0644 $nlocks] - error_check_good mutex_init [is_valid_mutex $m $env] TRUE - - # Get, set each mutex; sleep, then get Release - for { set i 0 } { $i < $nlocks } { incr i } { - set r [$m get $i ] - error_check_good mutex_get $r 0 - - set r [$m setval $i $i] - error_check_good mutex_setval $r 0 - } - tclsleep 5 - for { set i 0 } { $i < $nlocks } { incr i } { - set r [$m getval $i] - error_check_good mutex_getval $r $i - - set r [$m release $i ] - error_check_good mutex_get $r 0 - } - - error_check_good mutex_close [$m close] 0 - error_check_good env_close [$env close] 0 - puts "Mutex001: completed successfully." -} - -# Test basic synchronization -proc mutex002 { dir nlocks } { - source ./include.tcl - - puts "Mutex002: Basic synchronization" - env_cleanup $dir - - # Fork off child before we open any files. - set f1 [open |$tclsh_path r+] - puts $f1 "source $test_path/test.tcl" - flush $f1 - - # Open the environment and the mutex locally - set local_env [berkdb env -create -mode 0644 -lock -home $dir] - error_check_good env_open [is_valid_env $local_env] TRUE - - set local_mutex [$local_env mutex 0644 $nlocks] - error_check_good \ - mutex_init [is_valid_mutex $local_mutex $local_env] TRUE - - # Open the environment and the mutex remotely - set remote_env [send_cmd $f1 "berkdb env -lock -home $dir"] - error_check_good remote:env_open [is_valid_env $remote_env] TRUE - - set remote_mutex [send_cmd $f1 "$remote_env mutex 0644 $nlocks"] - error_check_good \ - mutex_init [is_valid_mutex $remote_mutex $remote_env] TRUE - - # Do a get here, then set the value to be pid. - # On the remote side fire off a get and getval. - set r [$local_mutex get 1] - error_check_good lock_get $r 0 - - set r [$local_mutex setval 1 [pid]] - error_check_good lock_get $r 0 - - # Now have the remote side request the lock and check its - # value. Then wait 5 seconds, release the mutex and see - # what the remote side returned. - send_timed_cmd $f1 1 "$remote_mutex get 1" - send_timed_cmd $f1 1 "set ret \[$remote_mutex getval 1\]" - - # Now sleep before resetting and releasing lock - tclsleep 5 - set newv [expr [pid] - 1] - set r [$local_mutex setval 1 $newv] - error_check_good mutex_setval $r 0 - - set r [$local_mutex release 1] - error_check_good mutex_release $r 0 - - # Now get the result from the other script - # Timestamp - set result [rcv_result $f1] - error_check_good lock_get:remote_time [expr $result > 4] 1 - - # Timestamp - set result [rcv_result $f1] - - # Mutex value - set result [send_cmd $f1 "puts \$ret"] - error_check_good lock_get:remote_getval $result $newv - - # Close down the remote - set ret [send_cmd $f1 "$remote_mutex close" 5] - # Not sure why we need this, but we do... an extra blank line - # someone gets output somewhere - gets $f1 ret - error_check_good remote:mutex_close $ret 0 - - set ret [send_cmd $f1 "$remote_env close"] - error_check_good remote:env_close $ret 0 - - catch { close $f1 } result - - set ret [$local_mutex close] - error_check_good local:mutex_close $ret 0 - - set ret [$local_env close] - error_check_good local:env_close $ret 0 - - puts "Mutex002: completed successfully." -} - -# Generate a bunch of parallel -# testers that try to randomly obtain locks. -proc mutex003 { dir iter nmutex procs mdegree wait } { - source ./include.tcl - - puts "Mutex003: Multi-process random mutex test ($procs processes)" - - env_cleanup $dir - - # Now open the region we'll use for multiprocess testing. - set env [berkdb env -create -mode 0644 -lock -home $dir] - error_check_good env_open [is_valid_env $env] TRUE - - set mutex [$env mutex 0644 $nmutex] - error_check_good mutex_init [is_valid_mutex $mutex $env] TRUE - - error_check_good mutex_close [$mutex close] 0 - - # Now spawn off processes - set proclist {} - for { set i 0 } {$i < $procs} {incr i} { - puts "$tclsh_path\ - $test_path/mutexscript.tcl $dir\ - $iter $nmutex $wait $mdegree > $testdir/$i.mutexout &" - set p [exec $tclsh_path $test_path/wrap.tcl \ - mutexscript.tcl $testdir/$i.mutexout $dir\ - $iter $nmutex $wait $mdegree &] - lappend proclist $p - } - puts "Mutex003: $procs independent processes now running" - watch_procs - error_check_good env_close [$env close] 0 - # Remove output files - for { set i 0 } {$i < $procs} {incr i} { - fileremove -f $dir/$i.mutexout - } -} |