diff options
Diffstat (limited to 'bdb/test/mpool.tcl')
| -rw-r--r-- | bdb/test/mpool.tcl | 420 |
1 files changed, 0 insertions, 420 deletions
diff --git a/bdb/test/mpool.tcl b/bdb/test/mpool.tcl deleted file mode 100644 index b2eb2252037..00000000000 --- a/bdb/test/mpool.tcl +++ /dev/null @@ -1,420 +0,0 @@ -# See the file LICENSE for redistribution information. -# -# Copyright (c) 1996, 1997, 1998, 1999, 2000 -# Sleepycat Software. All rights reserved. -# -# $Id: mpool.tcl,v 11.34 2001/01/18 04:58:07 krinsky Exp $ -# -# Options are: -# -cachesize {gbytes bytes ncache} -# -nfiles <files> -# -iterations <iterations> -# -pagesize <page size in bytes> -# -dir <directory in which to store memp> -# -stat -proc memp_usage {} { - puts "memp -cachesize {gbytes bytes ncache}" - puts "\t-nfiles <files>" - puts "\t-iterations <iterations>" - puts "\t-pagesize <page size in bytes>" - puts "\t-dir <memp directory>" - puts "\t-mem {private system}" - return -} - -proc mpool { args } { - source ./include.tcl - global errorCode - - puts "mpool {$args} running" - # Set defaults - set cachearg " -cachesize {0 200000 3}" - set nfiles 5 - set iterations 500 - set pagesize "512 1024 2048 4096 8192" - set npages 100 - set procs 4 - set seeds "" - set shm_key 1 - set dostat 0 - set flags "" - for { set i 0 } { $i < [llength $args] } {incr i} { - switch -regexp -- [lindex $args $i] { - -c.* { - incr i - set cachesize [lindex $args $i] - set cachearg " -cachesize $cachesize" - } - -d.* { incr i; set testdir [lindex $args $i] } - -i.* { incr i; set iterations [lindex $args $i] } - -me.* { - incr i - if { [string \ - compare [lindex $args $i] private] == 0 } { - set flags -private - } elseif { [string \ - compare [lindex $args $i] system] == 0 } { - # - # We need to use a shm id. Use one - # that is the same each time so that - # we do not grow segments infinitely. - set flags "-system_mem -shm_key $shm_key" - } else { - puts -nonewline \ - "FAIL:[timestamp] Usage: " - memp_usage - return - } - } - -nf.* { incr i; set nfiles [lindex $args $i] } - -np.* { incr i; set npages [lindex $args $i] } - -pa.* { incr i; set pagesize [lindex $args $i] } - -pr.* { incr i; set procs [lindex $args $i] } - -se.* { incr i; set seeds [lindex $args $i] } - -st.* { set dostat 1 } - default { - puts -nonewline "FAIL:[timestamp] Usage: " - memp_usage - return - } - } - } - - # Clean out old directory - env_cleanup $testdir - - # Open the memp with region init specified - set ret [catch {eval {berkdb env -create -mode 0644}\ - $cachearg {-region_init -home $testdir} $flags} res] - if { $ret == 0 } { - set env $res - } else { - # If the env open failed, it may be because we're on a platform - # such as HP-UX 10 that won't support mutexes in shmget memory. - # Or QNX, which doesn't support system memory at all. - # Verify that the return value was EINVAL or EOPNOTSUPP - # and bail gracefully. - error_check_good is_shm_test [is_substr $flags -system_mem] 1 - error_check_good returned_error [expr \ - [is_substr $errorCode EINVAL] || \ - [is_substr $errorCode EOPNOTSUPP]] 1 - puts "Warning:\ - platform does not support mutexes in shmget memory." - puts "Skipping shared memory mpool test." - return - } - error_check_good env_open [is_substr $env env] 1 - - reset_env $env - env_cleanup $testdir - - # Now open without region init - set env [eval {berkdb env -create -mode 0644}\ - $cachearg {-home $testdir} $flags] - error_check_good evn_open [is_substr $env env] 1 - - memp001 $env \ - $testdir $nfiles $iterations [lindex $pagesize 0] $dostat $flags - reset_env $env - set ret [berkdb envremove -home $testdir] - error_check_good env_remove $ret 0 - env_cleanup $testdir - - memp002 $testdir \ - $procs $pagesize $iterations $npages $seeds $dostat $flags - set ret [berkdb envremove -home $testdir] - error_check_good env_remove $ret 0 - env_cleanup $testdir - - memp003 $testdir $iterations $flags - set ret [berkdb envremove -home $testdir] - error_check_good env_remove $ret 0 - - env_cleanup $testdir -} - -proc memp001 {env dir n iter psize dostat flags} { - source ./include.tcl - global rand_init - - puts "Memp001: {$flags} random update $iter iterations on $n files." - - # Open N memp files - for {set i 1} {$i <= $n} {incr i} { - set fname "data_file.$i" - file_create $dir/$fname 50 $psize - - set mpools($i) \ - [$env mpool -create -pagesize $psize -mode 0644 $fname] - error_check_good mp_open [is_substr $mpools($i) $env.mp] 1 - } - - # Now, loop, picking files at random - berkdb srand $rand_init - for {set i 0} {$i < $iter} {incr i} { - set mpool $mpools([berkdb random_int 1 $n]) - set p1 [get_range $mpool 10] - set p2 [get_range $mpool 10] - set p3 [get_range $mpool 10] - set p1 [replace $mpool $p1] - set p3 [replace $mpool $p3] - set p4 [get_range $mpool 20] - set p4 [replace $mpool $p4] - set p5 [get_range $mpool 10] - set p6 [get_range $mpool 20] - set p7 [get_range $mpool 10] - set p8 [get_range $mpool 20] - set p5 [replace $mpool $p5] - set p6 [replace $mpool $p6] - set p9 [get_range $mpool 40] - set p9 [replace $mpool $p9] - set p10 [get_range $mpool 40] - set p7 [replace $mpool $p7] - set p8 [replace $mpool $p8] - set p9 [replace $mpool $p9] - set p10 [replace $mpool $p10] - } - - if { $dostat == 1 } { - puts [$env mpool_stat] - for {set i 1} {$i <= $n} {incr i} { - error_check_good mp_sync [$mpools($i) fsync] 0 - } - } - - # Close N memp files - for {set i 1} {$i <= $n} {incr i} { - error_check_good memp_close:$mpools($i) [$mpools($i) close] 0 - fileremove -f $dir/data_file.$i - } -} - -proc file_create { fname nblocks blocksize } { - set fid [open $fname w] - for {set i 0} {$i < $nblocks} {incr i} { - seek $fid [expr $i * $blocksize] start - puts -nonewline $fid $i - } - seek $fid [expr $nblocks * $blocksize - 1] - - # We don't end the file with a newline, because some platforms (like - # Windows) emit CR/NL. There does not appear to be a BINARY open flag - # that prevents this. - puts -nonewline $fid "Z" - close $fid - - # Make sure it worked - if { [file size $fname] != $nblocks * $blocksize } { - error "FAIL: file_create could not create correct file size" - } -} - -proc get_range { mpool max } { - set pno [berkdb random_int 0 $max] - set p [$mpool get $pno] - error_check_good page [is_valid_page $p $mpool] TRUE - set got [$p pgnum] - if { $got != $pno } { - puts "Get_range: Page mismatch page |$pno| val |$got|" - } - set ret [$p init "Page is pinned by [pid]"] - error_check_good page_init $ret 0 - - return $p -} - -proc replace { mpool p } { - set pgno [$p pgnum] - - set ret [$p init "Page is unpinned by [pid]"] - error_check_good page_init $ret 0 - - set ret [$p put -dirty] - error_check_good page_put $ret 0 - - set p2 [$mpool get $pgno] - error_check_good page [is_valid_page $p2 $mpool] TRUE - - return $p2 -} - -proc memp002 { dir procs psizes iterations npages seeds dostat flags } { - source ./include.tcl - - puts "Memp002: {$flags} Multiprocess mpool tester" - - if { [is_substr $flags -private] != 0 } { - puts "Memp002 skipping\ - multiple processes not supported by private memory" - return - } - set iter [expr $iterations / $procs] - - # Clean up old stuff and create new. - env_cleanup $dir - - for { set i 0 } { $i < [llength $psizes] } { incr i } { - fileremove -f $dir/file$i - } - set e [eval {berkdb env -create -lock -home $dir} $flags] - error_check_good dbenv [is_valid_widget $e env] TRUE - - set pidlist {} - for { set i 0 } { $i < $procs } {incr i} { - if { [llength $seeds] == $procs } { - set seed [lindex $seeds $i] - } else { - set seed -1 - } - - puts "$tclsh_path\ - $test_path/mpoolscript.tcl $dir $i $procs \ - $iter $psizes $npages 3 $flags > \ - $dir/memp002.$i.out &" - set p [exec $tclsh_path $test_path/wrap.tcl \ - mpoolscript.tcl $dir/memp002.$i.out $dir $i $procs \ - $iter $psizes $npages 3 $flags &] - lappend pidlist $p - } - puts "Memp002: $procs independent processes now running" - watch_procs - - reset_env $e -} - -# Test reader-only/writer process combinations; we use the access methods -# for testing. -proc memp003 { dir {nentries 10000} flags } { - global alphabet - source ./include.tcl - - puts "Memp003: {$flags} Reader/Writer tests" - - if { [is_substr $flags -private] != 0 } { - puts "Memp003 skipping\ - multiple processes not supported by private memory" - return - } - - env_cleanup $dir - set psize 1024 - set testfile mpool.db - set t1 $dir/t1 - - # Create an environment that the two processes can share - set c [list 0 [expr $psize * 10] 3] - set dbenv [eval {berkdb env \ - -create -lock -home $dir -cachesize $c} $flags] - error_check_good dbenv [is_valid_env $dbenv] TRUE - - # First open and create the file. - - set db [berkdb_open -env $dbenv -create -truncate \ - -mode 0644 -pagesize $psize -btree $testfile] - error_check_good dbopen/RW [is_valid_db $db] TRUE - - set did [open $dict] - set txn "" - set count 0 - - puts "\tMemp003.a: create database" - set keys "" - # Here is the loop where we put and get each key/data pair - while { [gets $did str] != -1 && $count < $nentries } { - lappend keys $str - - set ret [eval {$db put} $txn {$str $str}] - error_check_good put $ret 0 - - set ret [eval {$db get} $txn {$str}] - error_check_good get $ret [list [list $str $str]] - - incr count - } - close $did - error_check_good close [$db close] 0 - - # Now open the file for read-only - set db [berkdb_open -env $dbenv -rdonly $testfile] - error_check_good dbopen/RO [is_substr $db db] 1 - - puts "\tMemp003.b: verify a few keys" - # Read and verify a couple of keys; saving them to check later - set testset "" - for { set i 0 } { $i < 10 } { incr i } { - set ndx [berkdb random_int 0 [expr $nentries - 1]] - set key [lindex $keys $ndx] - if { [lsearch $testset $key] != -1 } { - incr i -1 - continue; - } - - # The remote process stuff is unhappy with - # zero-length keys; make sure we don't pick one. - if { [llength $key] == 0 } { - incr i -1 - continue - } - - lappend testset $key - - set ret [eval {$db get} $txn {$key}] - error_check_good get/RO $ret [list [list $key $key]] - } - - puts "\tMemp003.c: retrieve and modify keys in remote process" - # Now open remote process where we will open the file RW - set f1 [open |$tclsh_path r+] - puts $f1 "source $test_path/test.tcl" - puts $f1 "flush stdout" - flush $f1 - - set c [concat "{" [list 0 [expr $psize * 10] 3] "}" ] - set remote_env [send_cmd $f1 \ - "berkdb env -create -lock -home $dir -cachesize $c $flags"] - error_check_good remote_dbenv [is_valid_env $remote_env] TRUE - - set remote_db [send_cmd $f1 "berkdb_open -env $remote_env $testfile"] - error_check_good remote_dbopen [is_valid_db $remote_db] TRUE - - foreach k $testset { - # Get the key - set ret [send_cmd $f1 "$remote_db get $k"] - error_check_good remote_get $ret [list [list $k $k]] - - # Now replace the key - set ret [send_cmd $f1 "$remote_db put $k $k$k"] - error_check_good remote_put $ret 0 - } - - puts "\tMemp003.d: verify changes in local process" - foreach k $testset { - set ret [eval {$db get} $txn {$key}] - error_check_good get_verify/RO $ret [list [list $key $key$key]] - } - - puts "\tMemp003.e: Fill up the cache with dirty buffers" - foreach k $testset { - # Now rewrite the keys with BIG data - set data [replicate $alphabet 32] - set ret [send_cmd $f1 "$remote_db put $k $data"] - error_check_good remote_put $ret 0 - } - - puts "\tMemp003.f: Get more pages for the read-only file" - dump_file $db $txn $t1 nop - - puts "\tMemp003.g: Sync from the read-only file" - error_check_good db_sync [$db sync] 0 - error_check_good db_close [$db close] 0 - - set ret [send_cmd $f1 "$remote_db close"] - error_check_good remote_get $ret 0 - - # Close the environment both remotely and locally. - set ret [send_cmd $f1 "$remote_env close"] - error_check_good remote:env_close $ret 0 - close $f1 - - reset_env $dbenv -} |