1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: test042.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test042 8# TEST Concurrent Data Store test (CDB) 9# TEST 10# TEST Multiprocess DB test; verify that locking is working for the 11# TEST concurrent access method product. 12# TEST 13# TEST Use the first "nentries" words from the dictionary. Insert each with 14# TEST self as key and a fixed, medium length data string. Then fire off 15# TEST multiple processes that bang on the database. Each one should try to 16# TEST read and write random keys. When they rewrite, they'll append their 17# TEST pid to the data string (sometimes doing a rewrite sometimes doing a 18# TEST partial put). Some will use cursors to traverse through a few keys 19# TEST before finding one to write. 20 21proc test042 { method {nentries 1000} args } { 22 global encrypt 23 24 # 25 # If we are using an env, then skip this test. It needs its own. 26 set eindex [lsearch -exact $args "-env"] 27 if { $eindex != -1 } { 28 incr eindex 29 set env [lindex $args $eindex] 30 puts "Test042 skipping for env $env" 31 return 32 } 33 34 set args [convert_args $method $args] 35 if { $encrypt != 0 } { 36 puts "Test042 skipping for security" 37 return 38 } 39 test042_body $method $nentries 0 $args 40 test042_body $method $nentries 1 $args 41} 42 43proc test042_body { method nentries alldb args } { 44 source ./include.tcl 45 46 if { $alldb } { 47 set eflag "-cdb -cdb_alldb" 48 } else { 49 set eflag "-cdb" 50 } 51 puts "Test042: CDB Test ($eflag) $method $nentries" 52 53 # Set initial parameters 54 set do_exit 0 55 set iter 10000 56 set procs 5 57 58 # Process arguments 59 set oargs "" 60 for { set i 0 } { $i < [llength $args] } {incr i} { 61 switch -regexp -- [lindex $args $i] { 62 -dir { incr i; set testdir [lindex $args $i] } 63 -iter { incr i; set iter [lindex $args $i] } 64 -procs { incr i; set procs [lindex $args $i] } 65 -exit { set do_exit 1 } 66 default { append oargs " " [lindex $args $i] } 67 } 68 } 69 70 # Create the database and open the dictionary 71 set basename test042 72 set t1 $testdir/t1 73 set t2 $testdir/t2 74 set t3 $testdir/t3 75 76 env_cleanup $testdir 77 78 set env [eval {berkdb_env -create} $eflag -home $testdir] 79 error_check_good dbenv [is_valid_env $env] TRUE 80 81 # Env is created, now set up database 82 test042_dbinit $env $nentries $method $oargs $basename.0.db 83 if { $alldb } { 84 for { set i 1 } {$i < $procs} {incr i} { 85 test042_dbinit $env $nentries $method $oargs \ 86 $basename.$i.db 87 } 88 } 89 90 # Remove old mpools and Open/create the lock and mpool regions 91 error_check_good env:close:$env [$env close] 0 92 set ret [berkdb envremove -home $testdir] 93 error_check_good env_remove $ret 0 94 95 set env [eval {berkdb_env \ 96 -create -cachesize {0 1048576 1}} $eflag -home $testdir] 97 error_check_good dbenv [is_valid_widget $env env] TRUE 98 99 if { $do_exit == 1 } { 100 return 101 } 102 103 # Now spawn off processes 104 berkdb debug_check 105 puts "\tTest042.b: forking off $procs children" 106 set pidlist {} 107 108 for { set i 0 } {$i < $procs} {incr i} { 109 if { $alldb } { 110 set tf $basename.$i.db 111 } else { 112 set tf $basename.0.db 113 } 114 puts "exec $tclsh_path $test_path/wrap.tcl \ 115 mdbscript.tcl $testdir/test042.$i.log \ 116 $method $testdir $tf $nentries $iter $i $procs &" 117 set p [exec $tclsh_path $test_path/wrap.tcl \ 118 mdbscript.tcl $testdir/test042.$i.log $method \ 119 $testdir $tf $nentries $iter $i $procs &] 120 lappend pidlist $p 121 } 122 puts "Test042: $procs independent processes now running" 123 watch_procs $pidlist 124 125 # Make sure we haven't added or lost any entries. 126 set dblist [glob $testdir/$basename.*.db] 127 foreach file $dblist { 128 set tf [file tail $file] 129 set db [eval {berkdb_open -env $env $tf}] 130 set statret [$db stat] 131 foreach pair $statret { 132 set fld [lindex $pair 0] 133 if { [string compare $fld {Number of records}] == 0 } { 134 set numrecs [lindex $pair 1] 135 break 136 } 137 } 138 error_check_good nentries $numrecs $nentries 139 error_check_good db_close [$db close] 0 140 } 141 142 # Check for test failure 143 set errstrings [eval findfail [glob $testdir/test042.*.log]] 144 foreach str $errstrings { 145 puts "FAIL: error message in log file: $str" 146 } 147 148 # Test is done, blow away lock and mpool region 149 reset_env $env 150} 151 152proc test042_dbinit { env nentries method oargs tf } { 153 global datastr 154 source ./include.tcl 155 156 set omethod [convert_method $method] 157 set db [eval {berkdb_open -env $env -create \ 158 -mode 0644 $omethod} $oargs $tf] 159 error_check_good dbopen [is_valid_db $db] TRUE 160 161 set did [open $dict] 162 163 set pflags "" 164 set gflags "" 165 set txn "" 166 set count 0 167 168 # Here is the loop where we put each key/data pair 169 puts "\tTest042.a: put loop $tf" 170 while { [gets $did str] != -1 && $count < $nentries } { 171 if { [is_record_based $method] == 1 } { 172 set key [expr $count + 1] 173 } else { 174 set key $str 175 } 176 set ret [eval {$db put} \ 177 $txn $pflags {$key [chop_data $method $datastr]}] 178 error_check_good put:$db $ret 0 179 incr count 180 } 181 close $did 182 error_check_good close:$db [$db close] 0 183} 184