1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: mdbscript.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# Process script for the multi-process db tester. 8 9source ./include.tcl 10source $test_path/test.tcl 11source $test_path/testutils.tcl 12 13global dbenv 14global klock 15global l_keys 16global procid 17global alphabet 18 19# In Tcl, when there are multiple catch handlers, *all* handlers 20# are called, so we have to resort to this hack. 21# 22global exception_handled 23 24set exception_handled 0 25 26set datastr $alphabet$alphabet 27 28# Usage: mdbscript dir file nentries iter procid procs seed 29# dir: DBHOME directory 30# file: db file on which to operate 31# nentries: number of entries taken from dictionary 32# iter: number of operations to run 33# procid: this processes' id number 34# procs: total number of processes running 35set usage "mdbscript method dir file nentries iter procid procs" 36 37# Verify usage 38if { $argc != 7 } { 39 puts "FAIL:[timestamp] test042: Usage: $usage" 40 exit 41} 42 43# Initialize arguments 44set method [lindex $argv 0] 45set dir [lindex $argv 1] 46set file [lindex $argv 2] 47set nentries [ lindex $argv 3 ] 48set iter [ lindex $argv 4 ] 49set procid [ lindex $argv 5 ] 50set procs [ lindex $argv 6 ] 51 52set pflags "" 53set gflags "" 54set txn "" 55 56set renum [is_rrecno $method] 57set omethod [convert_method $method] 58 59if { [is_record_based $method] == 1 } { 60 append gflags " -recno" 61} 62 63# Initialize seed 64global rand_init 65 66# We want repeatable results, but we also want each instance of mdbscript 67# to do something different. So we add the procid to the fixed seed. 68# (Note that this is a serial number given by the caller, not a pid.) 69berkdb srand [expr $rand_init + $procid] 70 71puts "Beginning execution for [pid] $method" 72puts "$dir db_home" 73puts "$file database" 74puts "$nentries data elements" 75puts "$iter iterations" 76puts "$procid process id" 77puts "$procs processes" 78 79set klock NOLOCK 80 81# Note: all I/O operations, and especially flush, are expensive 82# on Win2000 at least with Tcl version 8.3.2. So we'll avoid 83# flushes in the main part of the loop below. 84flush stdout 85 86set dbenv [berkdb_env -create -cdb -home $dir] 87#set dbenv [berkdb_env -create -cdb -log -home $dir] 88error_check_good dbenv [is_valid_env $dbenv] TRUE 89 90set locker [ $dbenv lock_id ] 91 92set db [berkdb_open -env $dbenv -create -mode 0644 $omethod $file] 93error_check_good dbopen [is_valid_db $db] TRUE 94 95# Init globals (no data) 96set nkeys [db_init $db 0] 97puts "Initial number of keys: $nkeys" 98tclsleep 5 99 100proc get_lock { k } { 101 global dbenv 102 global procid 103 global locker 104 global klock 105 global DB_LOCK_WRITE 106 global DB_LOCK_NOWAIT 107 global errorInfo 108 global exception_handled 109 # Make sure that the key isn't in the middle of 110 # a delete operation 111 if {[catch {$dbenv lock_get -nowait write $locker $k} klock] != 0 } { 112 set exception_handled 1 113 114 error_check_good \ 115 get_lock [is_substr $errorInfo "DB_LOCK_NOTGRANTED"] 1 116 puts "Warning: key $k locked" 117 set klock NOLOCK 118 return 1 119 } else { 120 error_check_good get_lock [is_valid_lock $klock $dbenv] TRUE 121 } 122 return 0 123} 124 125# If we are renumbering, then each time we delete an item, the number of 126# items in the file is temporarily decreased, so the highest record numbers 127# do not exist. To make sure this doesn't happen, we never generate the 128# highest few record numbers as keys. 129# 130# For record-based methods, record numbers begin at 1, while for other keys, 131# we begin at 0 to index into an array. 132proc rand_key { method nkeys renum procs} { 133 if { $renum == 1 } { 134 return [berkdb random_int 1 [expr $nkeys - $procs]] 135 } elseif { [is_record_based $method] == 1 } { 136 return [berkdb random_int 1 $nkeys] 137 } else { 138 return [berkdb random_int 0 [expr $nkeys - 1]] 139 } 140} 141 142# On each iteration we're going to randomly pick a key. 143# 1. We'll either get it (verifying that its contents are reasonable). 144# 2. Put it (using an overwrite to make the data be datastr:ID). 145# 3. Get it and do a put through the cursor, tacking our ID on to 146# 4. Get it, read forward some random number of keys. 147# 5. Get it, read forward some random number of keys and do a put (replace). 148# 6. Get it, read forward some random number of keys and do a del. And then 149# do a put of the key. 150set gets 0 151set getput 0 152set overwrite 0 153set seqread 0 154set seqput 0 155set seqdel 0 156set dlen [string length $datastr] 157 158for { set i 0 } { $i < $iter } { incr i } { 159 set op [berkdb random_int 0 5] 160 puts "iteration $i operation $op" 161 set close_cursor 0 162 if {[catch { 163 switch $op { 164 0 { 165 incr gets 166 set k [rand_key $method $nkeys $renum $procs] 167 if {[is_record_based $method] == 1} { 168 set key $k 169 } else { 170 set key [lindex $l_keys $k] 171 } 172 173 if { [get_lock $key] == 1 } { 174 incr i -1 175 continue; 176 } 177 178 set rec [eval {$db get} $txn $gflags {$key}] 179 error_check_bad "$db get $key" [llength $rec] 0 180 set partial [string range \ 181 [lindex [lindex $rec 0] 1] 0 [expr $dlen - 1]] 182 error_check_good \ 183 "$db get $key" $partial [pad_data $method $datastr] 184 } 185 1 { 186 incr overwrite 187 set k [rand_key $method $nkeys $renum $procs] 188 if {[is_record_based $method] == 1} { 189 set key $k 190 } else { 191 set key [lindex $l_keys $k] 192 } 193 194 set data $datastr:$procid 195 set ret [eval {$db put} \ 196 $txn $pflags {$key [chop_data $method $data]}] 197 error_check_good "$db put $key" $ret 0 198 } 199 2 { 200 incr getput 201 set dbc [$db cursor -update] 202 error_check_good "$db cursor" \ 203 [is_valid_cursor $dbc $db] TRUE 204 set close_cursor 1 205 set k [rand_key $method $nkeys $renum $procs] 206 if {[is_record_based $method] == 1} { 207 set key $k 208 } else { 209 set key [lindex $l_keys $k] 210 } 211 212 if { [get_lock $key] == 1 } { 213 incr i -1 214 error_check_good "$dbc close" \ 215 [$dbc close] 0 216 set close_cursor 0 217 continue; 218 } 219 220 set ret [$dbc get -set $key] 221 error_check_good \ 222 "$dbc get $key" [llength [lindex $ret 0]] 2 223 set rec [lindex [lindex $ret 0] 1] 224 set partial [string range $rec 0 [expr $dlen - 1]] 225 error_check_good \ 226 "$dbc get $key" $partial [pad_data $method $datastr] 227 append rec ":$procid" 228 set ret [$dbc put \ 229 -current [chop_data $method $rec]] 230 error_check_good "$dbc put $key" $ret 0 231 error_check_good "$dbc close" [$dbc close] 0 232 set close_cursor 0 233 } 234 3 - 235 4 - 236 5 { 237 if { $op == 3 } { 238 set flags "" 239 } else { 240 set flags -update 241 } 242 set dbc [eval {$db cursor} $flags] 243 error_check_good "$db cursor" \ 244 [is_valid_cursor $dbc $db] TRUE 245 set close_cursor 1 246 set k [rand_key $method $nkeys $renum $procs] 247 if {[is_record_based $method] == 1} { 248 set key $k 249 } else { 250 set key [lindex $l_keys $k] 251 } 252 253 if { [get_lock $key] == 1 } { 254 incr i -1 255 error_check_good "$dbc close" \ 256 [$dbc close] 0 257 set close_cursor 0 258 continue; 259 } 260 261 set ret [$dbc get -set $key] 262 error_check_good \ 263 "$dbc get $key" [llength [lindex $ret 0]] 2 264 265 # Now read a few keys sequentially 266 set nloop [berkdb random_int 0 10] 267 if { [berkdb random_int 0 1] == 0 } { 268 set flags -next 269 } else { 270 set flags -prev 271 } 272 while { $nloop > 0 } { 273 set lastret $ret 274 set ret [eval {$dbc get} $flags] 275 # Might read beginning/end of file 276 if { [llength $ret] == 0} { 277 set ret $lastret 278 break 279 } 280 incr nloop -1 281 } 282 switch $op { 283 3 { 284 incr seqread 285 } 286 4 { 287 incr seqput 288 set rec [lindex [lindex $ret 0] 1] 289 set partial [string range $rec 0 \ 290 [expr $dlen - 1]] 291 error_check_good "$dbc get $key" \ 292 $partial [pad_data $method $datastr] 293 append rec ":$procid" 294 set ret [$dbc put -current \ 295 [chop_data $method $rec]] 296 error_check_good \ 297 "$dbc put $key" $ret 0 298 } 299 5 { 300 incr seqdel 301 set k [lindex [lindex $ret 0] 0] 302 # We need to lock the item we're 303 # deleting so that someone else can't 304 # try to do a get while we're 305 # deleting 306 error_check_good "$klock put" \ 307 [$klock put] 0 308 set klock NOLOCK 309 set cur [$dbc get -current] 310 error_check_bad get_current \ 311 [llength $cur] 0 312 set key [lindex [lindex $cur 0] 0] 313 if { [get_lock $key] == 1 } { 314 incr i -1 315 error_check_good "$dbc close" \ 316 [$dbc close] 0 317 set close_cursor 0 318 continue 319 } 320 set ret [$dbc del] 321 error_check_good "$dbc del" $ret 0 322 set rec $datastr 323 append rec ":$procid" 324 if { $renum == 1 } { 325 set ret [$dbc put -before \ 326 [chop_data $method $rec]] 327 error_check_good \ 328 "$dbc put $k" $ret $k 329 } elseif { \ 330 [is_record_based $method] == 1 } { 331 error_check_good "$dbc close" \ 332 [$dbc close] 0 333 set close_cursor 0 334 set ret [$db put $k \ 335 [chop_data $method $rec]] 336 error_check_good \ 337 "$db put $k" $ret 0 338 } else { 339 set ret [$dbc put -keylast $k \ 340 [chop_data $method $rec]] 341 error_check_good \ 342 "$dbc put $k" $ret 0 343 } 344 } 345 } 346 if { $close_cursor == 1 } { 347 error_check_good \ 348 "$dbc close" [$dbc close] 0 349 set close_cursor 0 350 } 351 } 352 } 353 } res] != 0} { 354 global errorInfo; 355 global exception_handled; 356 357 puts $errorInfo 358 359 set fnl [string first "\n" $errorInfo] 360 set theError [string range $errorInfo 0 [expr $fnl - 1]] 361 362 if { [string compare $klock NOLOCK] != 0 } { 363 catch {$klock put} 364 } 365 if {$close_cursor == 1} { 366 catch {$dbc close} 367 set close_cursor 0 368 } 369 370 if {[string first FAIL $theError] == 0 && \ 371 $exception_handled != 1} { 372 flush stdout 373 error "FAIL:[timestamp] test042: key $k: $theError" 374 } 375 set exception_handled 0 376 } else { 377 if { [string compare $klock NOLOCK] != 0 } { 378 error_check_good "$klock put" [$klock put] 0 379 set klock NOLOCK 380 } 381 } 382} 383 384error_check_good db_close_catch [catch {$db close} ret] 0 385error_check_good db_close $ret 0 386error_check_good dbenv_close [$dbenv close] 0 387 388flush stdout 389exit 390 391puts "[timestamp] [pid] Complete" 392puts "Successful ops: " 393puts "\t$gets gets" 394puts "\t$overwrite overwrites" 395puts "\t$getput getputs" 396puts "\t$seqread seqread" 397puts "\t$seqput seqput" 398puts "\t$seqdel seqdel" 399flush stdout 400