1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: testutils.tcl,v 12.40 2008/04/02 02:45:02 moshen Exp $ 6# 7# Test system utilities 8# 9# Timestamp -- print time along with elapsed time since last invocation 10# of timestamp. 11proc timestamp {{opt ""}} { 12 global __timestamp_start 13 14 set now [clock seconds] 15 16 # -c accurate to the click, instead of the second. 17 # -r seconds since the Epoch 18 # -t current time in the format expected by db_recover -t. 19 # -w wallclock time 20 # else wallclock plus elapsed time. 21 if {[string compare $opt "-r"] == 0} { 22 return $now 23 } elseif {[string compare $opt "-t"] == 0} { 24 return [clock format $now -format "%y%m%d%H%M.%S"] 25 } elseif {[string compare $opt "-w"] == 0} { 26 return [clock format $now -format "%c"] 27 } else { 28 if {[string compare $opt "-c"] == 0} { 29 set printclicks 1 30 } else { 31 set printclicks 0 32 } 33 34 if {[catch {set start $__timestamp_start}] != 0} { 35 set __timestamp_start $now 36 } 37 set start $__timestamp_start 38 39 set elapsed [expr $now - $start] 40 set the_time [clock format $now -format ""] 41 set __timestamp_start $now 42 43 if { $printclicks == 1 } { 44 set pc_print [format ".%08u" [__fix_num [clock clicks]]] 45 } else { 46 set pc_print "" 47 } 48 49 format "%02d:%02d:%02d$pc_print (%02d:%02d:%02d)" \ 50 [__fix_num [clock format $now -format "%H"]] \ 51 [__fix_num [clock format $now -format "%M"]] \ 52 [__fix_num [clock format $now -format "%S"]] \ 53 [expr $elapsed / 3600] \ 54 [expr ($elapsed % 3600) / 60] \ 55 [expr ($elapsed % 3600) % 60] 56 } 57} 58 59proc __fix_num { num } { 60 set num [string trimleft $num "0"] 61 if {[string length $num] == 0} { 62 set num "0" 63 } 64 return $num 65} 66 67# Add a {key,data} pair to the specified database where 68# key=filename and data=file contents. 69proc put_file { db txn flags file } { 70 source ./include.tcl 71 72 set fid [open $file r] 73 fconfigure $fid -translation binary 74 set data [read $fid] 75 close $fid 76 77 set ret [eval {$db put} $txn $flags {$file $data}] 78 error_check_good put_file $ret 0 79} 80 81# Get a {key,data} pair from the specified database where 82# key=filename and data=file contents and then write the 83# data to the specified file. 84proc get_file { db txn flags file outfile } { 85 source ./include.tcl 86 87 set fid [open $outfile w] 88 fconfigure $fid -translation binary 89 if [catch {eval {$db get} $txn $flags {$file}} data] { 90 puts -nonewline $fid $data 91 } else { 92 # Data looks like {{key data}} 93 set data [lindex [lindex $data 0] 1] 94 puts -nonewline $fid $data 95 } 96 close $fid 97} 98 99# Add a {key,data} pair to the specified database where 100# key=file contents and data=file name. 101proc put_file_as_key { db txn flags file } { 102 source ./include.tcl 103 104 set fid [open $file r] 105 fconfigure $fid -translation binary 106 set filecont [read $fid] 107 close $fid 108 109 # Use not the file contents, but the file name concatenated 110 # before the file contents, as a key, to ensure uniqueness. 111 set data $file$filecont 112 113 set ret [eval {$db put} $txn $flags {$data $file}] 114 error_check_good put_file $ret 0 115} 116 117# Get a {key,data} pair from the specified database where 118# key=file contents and data=file name 119proc get_file_as_key { db txn flags file} { 120 source ./include.tcl 121 122 set fid [open $file r] 123 fconfigure $fid -translation binary 124 set filecont [read $fid] 125 close $fid 126 127 set data $file$filecont 128 129 return [eval {$db get} $txn $flags {$data}] 130} 131 132# open file and call dump_file to dumpkeys to tempfile 133proc open_and_dump_file { 134 dbname env outfile checkfunc dump_func beg cont } { 135 global encrypt 136 global passwd 137 source ./include.tcl 138 139 set encarg "" 140 if { $encrypt > 0 && $env == "NULL" } { 141 set encarg "-encryptany $passwd" 142 } 143 set envarg "" 144 set txn "" 145 set txnenv 0 146 if { $env != "NULL" } { 147 append envarg " -env $env " 148 set txnenv [is_txnenv $env] 149 if { $txnenv == 1 } { 150 append envarg " -auto_commit " 151 set t [$env txn] 152 error_check_good txn [is_valid_txn $t $env] TRUE 153 set txn "-txn $t" 154 } 155 } 156 set db [eval {berkdb open} $envarg -rdonly -unknown $encarg $dbname] 157 error_check_good dbopen [is_valid_db $db] TRUE 158 $dump_func $db $txn $outfile $checkfunc $beg $cont 159 if { $txnenv == 1 } { 160 error_check_good txn [$t commit] 0 161 } 162 error_check_good db_close [$db close] 0 163} 164 165# open file and call dump_file to dumpkeys to tempfile 166proc open_and_dump_subfile { 167 dbname env outfile checkfunc dump_func beg cont subdb} { 168 global encrypt 169 global passwd 170 source ./include.tcl 171 172 set encarg "" 173 if { $encrypt > 0 && $env == "NULL" } { 174 set encarg "-encryptany $passwd" 175 } 176 set envarg "" 177 set txn "" 178 set txnenv 0 179 if { $env != "NULL" } { 180 append envarg "-env $env" 181 set txnenv [is_txnenv $env] 182 if { $txnenv == 1 } { 183 append envarg " -auto_commit " 184 set t [$env txn] 185 error_check_good txn [is_valid_txn $t $env] TRUE 186 set txn "-txn $t" 187 } 188 } 189 set db [eval {berkdb open -rdonly -unknown} \ 190 $envarg $encarg {$dbname $subdb}] 191 error_check_good dbopen [is_valid_db $db] TRUE 192 $dump_func $db $txn $outfile $checkfunc $beg $cont 193 if { $txnenv == 1 } { 194 error_check_good txn [$t commit] 0 195 } 196 error_check_good db_close [$db close] 0 197} 198 199# Sequentially read a file and call checkfunc on each key/data pair. 200# Dump the keys out to the file specified by outfile. 201proc dump_file { db txn outfile {checkfunc NONE} } { 202 source ./include.tcl 203 204 dump_file_direction $db $txn $outfile $checkfunc "-first" "-next" 205} 206 207proc dump_file_direction { db txn outfile checkfunc start continue } { 208 source ./include.tcl 209 210 # Now we will get each key from the DB and dump to outfile 211 set c [eval {$db cursor} $txn] 212 error_check_good db_cursor [is_valid_cursor $c $db] TRUE 213 dump_file_walk $c $outfile $checkfunc $start $continue 214 error_check_good curs_close [$c close] 0 215} 216 217proc dump_file_walk { c outfile checkfunc start continue {flag ""} } { 218 set outf [open $outfile w] 219 for {set d [eval {$c get} $flag $start] } \ 220 { [llength $d] != 0 } \ 221 {set d [eval {$c get} $flag $continue] } { 222 set kd [lindex $d 0] 223 set k [lindex $kd 0] 224 set d2 [lindex $kd 1] 225 if { $checkfunc != "NONE" } { 226 $checkfunc $k $d2 227 } 228 puts $outf $k 229 # XXX: Geoff Mainland 230 # puts $outf "$k $d2" 231 } 232 close $outf 233} 234 235proc dump_binkey_file { db txn outfile checkfunc } { 236 source ./include.tcl 237 238 dump_binkey_file_direction $db $txn $outfile $checkfunc \ 239 "-first" "-next" 240} 241proc dump_bin_file { db txn outfile checkfunc } { 242 source ./include.tcl 243 244 dump_bin_file_direction $db $txn $outfile $checkfunc "-first" "-next" 245} 246 247# Note: the following procedure assumes that the binary-file-as-keys were 248# inserted into the database by put_file_as_key, and consist of the file 249# name followed by the file contents as key, to ensure uniqueness. 250proc dump_binkey_file_direction { db txn outfile checkfunc begin cont } { 251 source ./include.tcl 252 253 set d1 $testdir/d1 254 255 set outf [open $outfile w] 256 257 # Now we will get each key from the DB and dump to outfile 258 set c [eval {$db cursor} $txn] 259 error_check_good db_cursor [is_valid_cursor $c $db] TRUE 260 261 set inf $d1 262 for {set d [$c get $begin] } { [llength $d] != 0 } \ 263 {set d [$c get $cont] } { 264 set kd [lindex $d 0] 265 set keyfile [lindex $kd 0] 266 set data [lindex $kd 1] 267 268 set ofid [open $d1 w] 269 fconfigure $ofid -translation binary 270 271 # Chop off the first few bytes--that's the file name, 272 # added for uniqueness in put_file_as_key, which we don't 273 # want in the regenerated file. 274 set namelen [string length $data] 275 set keyfile [string range $keyfile $namelen end] 276 puts -nonewline $ofid $keyfile 277 close $ofid 278 279 $checkfunc $data $d1 280 puts $outf $data 281 flush $outf 282 } 283 close $outf 284 error_check_good curs_close [$c close] 0 285 fileremove $d1 286} 287 288proc dump_bin_file_direction { db txn outfile checkfunc begin cont } { 289 source ./include.tcl 290 291 set d1 $testdir/d1 292 293 set outf [open $outfile w] 294 295 # Now we will get each key from the DB and dump to outfile 296 set c [eval {$db cursor} $txn] 297 298 for {set d [$c get $begin] } \ 299 { [llength $d] != 0 } {set d [$c get $cont] } { 300 set k [lindex [lindex $d 0] 0] 301 set data [lindex [lindex $d 0] 1] 302 set ofid [open $d1 w] 303 fconfigure $ofid -translation binary 304 puts -nonewline $ofid $data 305 close $ofid 306 307 $checkfunc $k $d1 308 puts $outf $k 309 } 310 close $outf 311 error_check_good curs_close [$c close] 0 312 fileremove -f $d1 313} 314 315proc make_data_str { key } { 316 set datastr "" 317 for {set i 0} {$i < 10} {incr i} { 318 append datastr $key 319 } 320 return $datastr 321} 322 323proc error_check_bad { func result bad {txn 0}} { 324 if { [binary_compare $result $bad] == 0 } { 325 if { $txn != 0 } { 326 $txn abort 327 } 328 flush stdout 329 flush stderr 330 error "FAIL:[timestamp] $func returned error value $bad" 331 } 332} 333 334proc error_check_good { func result desired {txn 0} } { 335 if { [binary_compare $desired $result] != 0 } { 336 if { $txn != 0 } { 337 $txn abort 338 } 339 flush stdout 340 flush stderr 341 error "FAIL:[timestamp]\ 342 $func: expected $desired, got $result" 343 } 344} 345 346# Locks have the prefix of their manager. 347proc is_substr { str sub } { 348 if { [string first $sub $str] == -1 } { 349 return 0 350 } else { 351 return 1 352 } 353} 354 355proc is_serial { str } { 356 global serial_tests 357 358 foreach test $serial_tests { 359 if { [is_substr $str $test] == 1 } { 360 return 1 361 } 362 } 363 return 0 364} 365 366proc release_list { l } { 367 368 # Now release all the locks 369 foreach el $l { 370 catch { $el put } ret 371 error_check_good lock_put $ret 0 372 } 373} 374 375proc debug { {stop 0} } { 376 global __debug_on 377 global __debug_print 378 global __debug_test 379 380 set __debug_on 1 381 set __debug_print 1 382 set __debug_test $stop 383} 384 385# Check if each key appears exactly [llength dlist] times in the file with 386# the duplicate tags matching those that appear in dlist. 387proc dup_check { db txn tmpfile dlist {extra 0}} { 388 source ./include.tcl 389 390 set outf [open $tmpfile w] 391 # Now we will get each key from the DB and dump to outfile 392 set c [eval {$db cursor} $txn] 393 set lastkey "" 394 set done 0 395 while { $done != 1} { 396 foreach did $dlist { 397 set rec [$c get "-next"] 398 if { [string length $rec] == 0 } { 399 set done 1 400 break 401 } 402 set key [lindex [lindex $rec 0] 0] 403 set fulldata [lindex [lindex $rec 0] 1] 404 set id [id_of $fulldata] 405 set d [data_of $fulldata] 406 if { [string compare $key $lastkey] != 0 && \ 407 $id != [lindex $dlist 0] } { 408 set e [lindex $dlist 0] 409 error "FAIL: \tKey \ 410 $key, expected dup id $e, got $id" 411 } 412 error_check_good dupget.data $d $key 413 error_check_good dupget.id $id $did 414 set lastkey $key 415 } 416 # 417 # Some tests add an extra dup (like overflow entries) 418 # Check id if it exists. 419 if { $extra != 0} { 420 set okey $key 421 set rec [$c get "-next"] 422 if { [string length $rec] != 0 } { 423 set key [lindex [lindex $rec 0] 0] 424 # 425 # If this key has no extras, go back for 426 # next iteration. 427 if { [string compare $key $lastkey] != 0 } { 428 set key $okey 429 set rec [$c get "-prev"] 430 } else { 431 set fulldata [lindex [lindex $rec 0] 1] 432 set id [id_of $fulldata] 433 set d [data_of $fulldata] 434 error_check_bad dupget.data1 $d $key 435 error_check_good dupget.id1 $id $extra 436 } 437 } 438 } 439 if { $done != 1 } { 440 puts $outf $key 441 } 442 } 443 close $outf 444 error_check_good curs_close [$c close] 0 445} 446 447# Check if each key appears exactly [llength dlist] times in the file with 448# the duplicate tags matching those that appear in dlist. 449proc dup_file_check { db txn tmpfile dlist } { 450 source ./include.tcl 451 452 set outf [open $tmpfile w] 453 # Now we will get each key from the DB and dump to outfile 454 set c [eval {$db cursor} $txn] 455 set lastkey "" 456 set done 0 457 while { $done != 1} { 458 foreach did $dlist { 459 set rec [$c get "-next"] 460 if { [string length $rec] == 0 } { 461 set done 1 462 break 463 } 464 set key [lindex [lindex $rec 0] 0] 465 if { [string compare $key $lastkey] != 0 } { 466 # 467 # If we changed files read in new contents. 468 # 469 set fid [open $key r] 470 fconfigure $fid -translation binary 471 set filecont [read $fid] 472 close $fid 473 } 474 set fulldata [lindex [lindex $rec 0] 1] 475 set id [id_of $fulldata] 476 set d [data_of $fulldata] 477 if { [string compare $key $lastkey] != 0 && \ 478 $id != [lindex $dlist 0] } { 479 set e [lindex $dlist 0] 480 error "FAIL: \tKey \ 481 $key, expected dup id $e, got $id" 482 } 483 error_check_good dupget.data $d $filecont 484 error_check_good dupget.id $id $did 485 set lastkey $key 486 } 487 if { $done != 1 } { 488 puts $outf $key 489 } 490 } 491 close $outf 492 error_check_good curs_close [$c close] 0 493} 494 495# Parse duplicate data entries of the form N:data. Data_of returns 496# the data part; id_of returns the numerical part 497proc data_of {str} { 498 set ndx [string first ":" $str] 499 if { $ndx == -1 } { 500 return "" 501 } 502 return [ string range $str [expr $ndx + 1] end] 503} 504 505proc id_of {str} { 506 set ndx [string first ":" $str] 507 if { $ndx == -1 } { 508 return "" 509 } 510 511 return [ string range $str 0 [expr $ndx - 1]] 512} 513 514proc nop { {args} } { 515 return 516} 517 518# Partial put test procedure. 519# Munges a data val through three different partial puts. Stores 520# the final munged string in the dvals array so that you can check 521# it later (dvals should be global). We take the characters that 522# are being replaced, make them capitals and then replicate them 523# some number of times (n_add). We do this at the beginning of the 524# data, at the middle and at the end. The parameters are: 525# db, txn, key -- as per usual. Data is the original data element 526# from which we are starting. n_replace is the number of characters 527# that we will replace. n_add is the number of times we will add 528# the replaced string back in. 529proc partial_put { method db txn gflags key data n_replace n_add } { 530 global dvals 531 source ./include.tcl 532 533 # Here is the loop where we put and get each key/data pair 534 # We will do the initial put and then three Partial Puts 535 # for the beginning, middle and end of the string. 536 537 eval {$db put} $txn {$key [chop_data $method $data]} 538 539 # Beginning change 540 set s [string range $data 0 [ expr $n_replace - 1 ] ] 541 set repl [ replicate [string toupper $s] $n_add ] 542 543 # This is gross, but necessary: if this is a fixed-length 544 # method, and the chopped length of $repl is zero, 545 # it's because the original string was zero-length and our data item 546 # is all nulls. Set repl to something non-NULL. 547 if { [is_fixed_length $method] && \ 548 [string length [chop_data $method $repl]] == 0 } { 549 set repl [replicate "." $n_add] 550 } 551 552 set newstr [chop_data $method $repl[string range $data $n_replace end]] 553 set ret [eval {$db put} $txn {-partial [list 0 $n_replace] \ 554 $key [chop_data $method $repl]}] 555 error_check_good put $ret 0 556 557 set ret [eval {$db get} $gflags $txn {$key}] 558 error_check_good get $ret [list [list $key [pad_data $method $newstr]]] 559 560 # End Change 561 set len [string length $newstr] 562 set spl [expr $len - $n_replace] 563 # Handle case where $n_replace > $len 564 if { $spl < 0 } { 565 set spl 0 566 } 567 568 set s [string range $newstr [ expr $len - $n_replace ] end ] 569 # Handle zero-length keys 570 if { [string length $s] == 0 } { set s "A" } 571 572 set repl [ replicate [string toupper $s] $n_add ] 573 set newstr [chop_data $method \ 574 [string range $newstr 0 [expr $spl - 1 ] ]$repl] 575 576 set ret [eval {$db put} $txn \ 577 {-partial [list $spl $n_replace] $key [chop_data $method $repl]}] 578 error_check_good put $ret 0 579 580 set ret [eval {$db get} $gflags $txn {$key}] 581 error_check_good get $ret [list [list $key [pad_data $method $newstr]]] 582 583 # Middle Change 584 set len [string length $newstr] 585 set mid [expr $len / 2 ] 586 set beg [expr $mid - [expr $n_replace / 2] ] 587 set end [expr $beg + $n_replace - 1] 588 set s [string range $newstr $beg $end] 589 set repl [ replicate [string toupper $s] $n_add ] 590 set newstr [chop_data $method [string range $newstr 0 \ 591 [expr $beg - 1 ] ]$repl[string range $newstr [expr $end + 1] end]] 592 593 set ret [eval {$db put} $txn {-partial [list $beg $n_replace] \ 594 $key [chop_data $method $repl]}] 595 error_check_good put $ret 0 596 597 set ret [eval {$db get} $gflags $txn {$key}] 598 error_check_good get $ret [list [list $key [pad_data $method $newstr]]] 599 600 set dvals($key) [pad_data $method $newstr] 601} 602 603proc replicate { str times } { 604 set res $str 605 for { set i 1 } { $i < $times } { set i [expr $i * 2] } { 606 append res $res 607 } 608 return $res 609} 610 611proc repeat { str n } { 612 set ret "" 613 while { $n > 0 } { 614 set ret $str$ret 615 incr n -1 616 } 617 return $ret 618} 619 620proc isqrt { l } { 621 set s [expr sqrt($l)] 622 set ndx [expr [string first "." $s] - 1] 623 return [string range $s 0 $ndx] 624} 625 626# If we run watch_procs multiple times without an intervening 627# testdir cleanup, it's possible that old sentinel files will confuse 628# us. Make sure they're wiped out before we spawn any other processes. 629proc sentinel_init { } { 630 source ./include.tcl 631 632 set filelist {} 633 set ret [catch {glob $testdir/begin.*} result] 634 if { $ret == 0 } { 635 set filelist $result 636 } 637 638 set ret [catch {glob $testdir/end.*} result] 639 if { $ret == 0 } { 640 set filelist [concat $filelist $result] 641 } 642 643 foreach f $filelist { 644 fileremove $f 645 } 646} 647 648proc watch_procs { pidlist {delay 30} {max 3600} {quiet 0} } { 649 source ./include.tcl 650 651 set elapsed 0 652 653 # Don't start watching the processes until a sentinel 654 # file has been created for each one. 655 foreach pid $pidlist { 656 while { [file exists $testdir/begin.$pid] == 0 } { 657 tclsleep $delay 658 incr elapsed $delay 659 # If pids haven't been created in one-tenth 660 # of the time allowed for the whole test, 661 # there's a problem. Report an error and fail. 662 if { $elapsed > [expr {$max / 10}] } { 663 puts "FAIL: begin.pid not created" 664 break 665 } 666 } 667 } 668 669 while { 1 } { 670 671 tclsleep $delay 672 incr elapsed $delay 673 674 # Find the list of processes with outstanding sentinel 675 # files (i.e. a begin.pid and no end.pid). 676 set beginlist {} 677 set endlist {} 678 set ret [catch {glob $testdir/begin.*} result] 679 if { $ret == 0 } { 680 set beginlist $result 681 } 682 set ret [catch {glob $testdir/end.*} result] 683 if { $ret == 0 } { 684 set endlist $result 685 } 686 687 set bpids {} 688 catch {unset epids} 689 foreach begfile $beginlist { 690 lappend bpids [string range $begfile \ 691 [string length $testdir/begin.] end] 692 } 693 foreach endfile $endlist { 694 set epids([string range $endfile \ 695 [string length $testdir/end.] end]) 1 696 } 697 698 # The set of processes that we still want to watch, $l, 699 # is the set of pids that have begun but not ended 700 # according to their sentinel files. 701 set l {} 702 foreach p $bpids { 703 if { [info exists epids($p)] == 0 } { 704 lappend l $p 705 } 706 } 707 708 set rlist {} 709 foreach i $l { 710 set r [ catch { exec $KILL -0 $i } res ] 711 if { $r == 0 } { 712 lappend rlist $i 713 } 714 } 715 if { [ llength $rlist] == 0 } { 716 break 717 } else { 718 puts "[timestamp] processes running: $rlist" 719 } 720 721 if { $elapsed > $max } { 722 # We have exceeded the limit; kill processes 723 # and report an error 724 foreach i $l { 725 tclkill $i 726 } 727 } 728 } 729 if { $quiet == 0 } { 730 puts "All processes have exited." 731 } 732 733 # 734 # Once we are done, remove all old sentinel files. 735 # 736 set oldsent [glob -nocomplain $testdir/begin* $testdir/end*] 737 foreach f oldsent { 738 fileremove -f $f 739 } 740 741} 742 743# These routines are all used from within the dbscript.tcl tester. 744proc db_init { dbp do_data } { 745 global a_keys 746 global l_keys 747 source ./include.tcl 748 749 set txn "" 750 set nk 0 751 set lastkey "" 752 753 set a_keys() BLANK 754 set l_keys "" 755 756 set c [$dbp cursor] 757 for {set d [$c get -first] } { [llength $d] != 0 } { 758 set d [$c get -next] } { 759 set k [lindex [lindex $d 0] 0] 760 set d2 [lindex [lindex $d 0] 1] 761 incr nk 762 if { $do_data == 1 } { 763 if { [info exists a_keys($k)] } { 764 lappend a_keys($k) $d2] 765 } else { 766 set a_keys($k) $d2 767 } 768 } 769 770 lappend l_keys $k 771 } 772 error_check_good curs_close [$c close] 0 773 774 return $nk 775} 776 777proc pick_op { min max n } { 778 if { $n == 0 } { 779 return add 780 } 781 782 set x [berkdb random_int 1 12] 783 if {$n < $min} { 784 if { $x <= 4 } { 785 return put 786 } elseif { $x <= 8} { 787 return get 788 } else { 789 return add 790 } 791 } elseif {$n > $max} { 792 if { $x <= 4 } { 793 return put 794 } elseif { $x <= 8 } { 795 return get 796 } else { 797 return del 798 } 799 800 } elseif { $x <= 3 } { 801 return del 802 } elseif { $x <= 6 } { 803 return get 804 } elseif { $x <= 9 } { 805 return put 806 } else { 807 return add 808 } 809} 810 811# random_data: Generate a string of random characters. 812# If recno is 0 - Use average to pick a length between 1 and 2 * avg. 813# If recno is non-0, generate a number between 1 and 2 ^ (avg * 2), 814# that will fit into a 32-bit integer. 815# If the unique flag is 1, then make sure that the string is unique 816# in the array "where". 817proc random_data { avg unique where {recno 0} } { 818 upvar #0 $where arr 819 global debug_on 820 set min 1 821 set max [expr $avg+$avg-1] 822 if { $recno } { 823 # 824 # Tcl seems to have problems with values > 30. 825 # 826 if { $max > 30 } { 827 set max 30 828 } 829 set maxnum [expr int(pow(2, $max))] 830 } 831 while {1} { 832 set len [berkdb random_int $min $max] 833 set s "" 834 if {$recno} { 835 set s [berkdb random_int 1 $maxnum] 836 } else { 837 for {set i 0} {$i < $len} {incr i} { 838 append s [int_to_char [berkdb random_int 0 25]] 839 } 840 } 841 842 if { $unique == 0 || [info exists arr($s)] == 0 } { 843 break 844 } 845 } 846 847 return $s 848} 849 850proc random_key { } { 851 global l_keys 852 global nkeys 853 set x [berkdb random_int 0 [expr $nkeys - 1]] 854 return [lindex $l_keys $x] 855} 856 857proc is_err { desired } { 858 set x [berkdb random_int 1 100] 859 if { $x <= $desired } { 860 return 1 861 } else { 862 return 0 863 } 864} 865 866proc pick_cursput { } { 867 set x [berkdb random_int 1 4] 868 switch $x { 869 1 { return "-keylast" } 870 2 { return "-keyfirst" } 871 3 { return "-before" } 872 4 { return "-after" } 873 } 874} 875 876proc random_cursor { curslist } { 877 global l_keys 878 global nkeys 879 880 set x [berkdb random_int 0 [expr [llength $curslist] - 1]] 881 set dbc [lindex $curslist $x] 882 883 # We want to randomly set the cursor. Pick a key. 884 set k [random_key] 885 set r [$dbc get "-set" $k] 886 error_check_good cursor_get:$k [is_substr Error $r] 0 887 888 # Now move forward or backward some hops to randomly 889 # position the cursor. 890 set dist [berkdb random_int -10 10] 891 892 set dir "-next" 893 set boundary "-first" 894 if { $dist < 0 } { 895 set dir "-prev" 896 set boundary "-last" 897 set dist [expr 0 - $dist] 898 } 899 900 for { set i 0 } { $i < $dist } { incr i } { 901 set r [ record $dbc get $dir $k ] 902 if { [llength $d] == 0 } { 903 set r [ record $dbc get $k $boundary ] 904 } 905 error_check_bad dbcget [llength $r] 0 906 } 907 return { [linsert r 0 $dbc] } 908} 909 910proc record { args } { 911# Recording every operation makes tests ridiculously slow on 912# NT, so we are commenting this out; for debugging purposes, 913# it will undoubtedly be useful to uncomment this. 914# puts $args 915# flush stdout 916 return [eval $args] 917} 918 919proc newpair { k data } { 920 global l_keys 921 global a_keys 922 global nkeys 923 924 set a_keys($k) $data 925 lappend l_keys $k 926 incr nkeys 927} 928 929proc rempair { k } { 930 global l_keys 931 global a_keys 932 global nkeys 933 934 unset a_keys($k) 935 set n [lsearch $l_keys $k] 936 error_check_bad rempair:$k $n -1 937 set l_keys [lreplace $l_keys $n $n] 938 incr nkeys -1 939} 940 941proc changepair { k data } { 942 global l_keys 943 global a_keys 944 global nkeys 945 946 set a_keys($k) $data 947} 948 949proc changedup { k olddata newdata } { 950 global l_keys 951 global a_keys 952 global nkeys 953 954 set d $a_keys($k) 955 error_check_bad changedup:$k [llength $d] 0 956 957 set n [lsearch $d $olddata] 958 error_check_bad changedup:$k $n -1 959 960 set a_keys($k) [lreplace $a_keys($k) $n $n $newdata] 961} 962 963# Insert a dup into the a_keys array with DB_KEYFIRST. 964proc adddup { k olddata newdata } { 965 global l_keys 966 global a_keys 967 global nkeys 968 969 set d $a_keys($k) 970 if { [llength $d] == 0 } { 971 lappend l_keys $k 972 incr nkeys 973 set a_keys($k) { $newdata } 974 } 975 976 set ndx 0 977 978 set d [linsert d $ndx $newdata] 979 set a_keys($k) $d 980} 981 982proc remdup { k data } { 983 global l_keys 984 global a_keys 985 global nkeys 986 987 set d [$a_keys($k)] 988 error_check_bad changedup:$k [llength $d] 0 989 990 set n [lsearch $d $olddata] 991 error_check_bad changedup:$k $n -1 992 993 set a_keys($k) [lreplace $a_keys($k) $n $n] 994} 995 996proc dump_full_file { db txn outfile checkfunc start continue } { 997 source ./include.tcl 998 999 set outf [open $outfile w] 1000 # Now we will get each key from the DB and dump to outfile 1001 set c [eval {$db cursor} $txn] 1002 error_check_good dbcursor [is_valid_cursor $c $db] TRUE 1003 1004 for {set d [$c get $start] } { [string length $d] != 0 } { 1005 set d [$c get $continue] } { 1006 set k [lindex [lindex $d 0] 0] 1007 set d2 [lindex [lindex $d 0] 1] 1008 $checkfunc $k $d2 1009 puts $outf "$k\t$d2" 1010 } 1011 close $outf 1012 error_check_good curs_close [$c close] 0 1013} 1014 1015proc int_to_char { i } { 1016 global alphabet 1017 1018 return [string index $alphabet $i] 1019} 1020 1021proc dbcheck { key data } { 1022 global l_keys 1023 global a_keys 1024 global nkeys 1025 global check_array 1026 1027 if { [lsearch $l_keys $key] == -1 } { 1028 error "FAIL: Key |$key| not in list of valid keys" 1029 } 1030 1031 set d $a_keys($key) 1032 1033 if { [info exists check_array($key) ] } { 1034 set check $check_array($key) 1035 } else { 1036 set check {} 1037 } 1038 1039 if { [llength $d] > 1 } { 1040 if { [llength $check] != [llength $d] } { 1041 # Make the check array the right length 1042 for { set i [llength $check] } { $i < [llength $d] } \ 1043 {incr i} { 1044 lappend check 0 1045 } 1046 set check_array($key) $check 1047 } 1048 1049 # Find this data's index 1050 set ndx [lsearch $d $data] 1051 if { $ndx == -1 } { 1052 error "FAIL: \ 1053 Data |$data| not found for key $key. Found |$d|" 1054 } 1055 1056 # Set the bit in the check array 1057 set check_array($key) [lreplace $check_array($key) $ndx $ndx 1] 1058 } elseif { [string compare $d $data] != 0 } { 1059 error "FAIL: \ 1060 Invalid data |$data| for key |$key|. Expected |$d|." 1061 } else { 1062 set check_array($key) 1 1063 } 1064} 1065 1066# Dump out the file and verify it 1067proc filecheck { file txn } { 1068 global check_array 1069 global l_keys 1070 global nkeys 1071 global a_keys 1072 source ./include.tcl 1073 1074 if { [info exists check_array] == 1 } { 1075 unset check_array 1076 } 1077 1078 open_and_dump_file $file NULL $file.dump dbcheck dump_full_file \ 1079 "-first" "-next" 1080 1081 # Check that everything we checked had all its data 1082 foreach i [array names check_array] { 1083 set count 0 1084 foreach j $check_array($i) { 1085 if { $j != 1 } { 1086 puts -nonewline "Key |$i| never found datum" 1087 puts " [lindex $a_keys($i) $count]" 1088 } 1089 incr count 1090 } 1091 } 1092 1093 # Check that all keys appeared in the checked array 1094 set count 0 1095 foreach k $l_keys { 1096 if { [info exists check_array($k)] == 0 } { 1097 puts "filecheck: key |$k| not found. Data: $a_keys($k)" 1098 } 1099 incr count 1100 } 1101 1102 if { $count != $nkeys } { 1103 puts "filecheck: Got $count keys; expected $nkeys" 1104 } 1105} 1106 1107proc cleanup { dir env { quiet 0 } } { 1108 global gen_upgrade 1109 global gen_dump 1110 global is_qnx_test 1111 global is_je_test 1112 global old_encrypt 1113 global passwd 1114 source ./include.tcl 1115 1116 if { $gen_upgrade == 1 || $gen_dump == 1 } { 1117 save_upgrade_files $dir 1118 } 1119 1120# check_handles 1121 set remfiles {} 1122 set ret [catch { glob $dir/* } result] 1123 if { $ret == 0 } { 1124 foreach fileorig $result { 1125 # 1126 # We: 1127 # - Ignore any env-related files, which are 1128 # those that have __db.* or log.* if we are 1129 # running in an env. Also ignore files whose 1130 # names start with REPDIR_; these are replication 1131 # subdirectories. 1132 # - Call 'dbremove' on any databases. 1133 # Remove any remaining temp files. 1134 # 1135 switch -glob -- $fileorig { 1136 */DIR_* - 1137 */__db.* - 1138 */log.* - 1139 */*.jdb { 1140 if { $env != "NULL" } { 1141 continue 1142 } else { 1143 if { $is_qnx_test } { 1144 catch {berkdb envremove -force \ 1145 -home $dir} r 1146 } 1147 lappend remfiles $fileorig 1148 } 1149 } 1150 *.db { 1151 set envargs "" 1152 set encarg "" 1153 # 1154 # If in an env, it should be open crypto 1155 # or not already. 1156 # 1157 if { $env != "NULL"} { 1158 set file [file tail $fileorig] 1159 set envargs " -env $env " 1160 if { [is_txnenv $env] } { 1161 append envargs " -auto_commit " 1162 } 1163 } else { 1164 if { $old_encrypt != 0 } { 1165 set encarg "-encryptany $passwd" 1166 } 1167 set file $fileorig 1168 } 1169 1170 # If a database is left in a corrupt 1171 # state, dbremove might not be able to handle 1172 # it (it does an open before the remove). 1173 # Be prepared for this, and if necessary, 1174 # just forcibly remove the file with a warning 1175 # message. 1176 set ret [catch \ 1177 {eval {berkdb dbremove} $envargs $encarg \ 1178 $file} res] 1179 # If dbremove failed and we're not in an env, 1180 # note that we don't have 100% certainty 1181 # about whether the previous run used 1182 # encryption. Try to remove with crypto if 1183 # we tried without, and vice versa. 1184 if { $ret != 0 } { 1185 if { $env == "NULL" && \ 1186 $old_encrypt == 0} { 1187 set ret [catch \ 1188 {eval {berkdb dbremove} \ 1189 -encryptany $passwd \ 1190 $file} res] 1191 } 1192 if { $env == "NULL" && \ 1193 $old_encrypt == 1 } { 1194 set ret [catch \ 1195 {eval {berkdb dbremove} \ 1196 $file} res] 1197 } 1198 if { $ret != 0 } { 1199 if { $quiet == 0 } { 1200 puts \ 1201 "FAIL: dbremove in cleanup failed: $res" 1202 } 1203 set file $fileorig 1204 lappend remfiles $file 1205 } 1206 } 1207 } 1208 default { 1209 lappend remfiles $fileorig 1210 } 1211 } 1212 } 1213 if {[llength $remfiles] > 0} { 1214 # 1215 # In the HFS file system there are cases where not 1216 # all files are removed on the first attempt. If 1217 # it fails, try again a few times. 1218 # 1219 # This bug has been compensated for in Tcl with a fix 1220 # checked into Tcl 8.4. When Berkeley DB requires 1221 # Tcl 8.5, we can remove this while loop and replace 1222 # it with a simple 'fileremove -f $remfiles'. 1223 # 1224 set count 0 1225 while { [catch {eval fileremove -f $remfiles}] == 1 \ 1226 && $count < 5 } { 1227 incr count 1228 } 1229 } 1230 1231 if { $is_je_test } { 1232 set rval [catch {eval {exec \ 1233 $util_path/db_dump} -h $dir -l } res] 1234 if { $rval == 0 } { 1235 set envargs " -env $env " 1236 if { [is_txnenv $env] } { 1237 append envargs " -auto_commit " 1238 } 1239 1240 foreach db $res { 1241 set ret [catch {eval \ 1242 {berkdb dbremove} $envargs $db } res] 1243 } 1244 } 1245 } 1246 } 1247} 1248 1249proc log_cleanup { dir } { 1250 source ./include.tcl 1251 global gen_upgrade_log 1252 1253 if { $gen_upgrade_log == 1 } { 1254 save_upgrade_files $dir 1255 } 1256 1257 set files [glob -nocomplain $dir/log.*] 1258 if { [llength $files] != 0} { 1259 foreach f $files { 1260 fileremove -f $f 1261 } 1262 } 1263} 1264 1265proc env_cleanup { dir } { 1266 global old_encrypt 1267 global passwd 1268 source ./include.tcl 1269 1270 set encarg "" 1271 if { $old_encrypt != 0 } { 1272 set encarg "-encryptany $passwd" 1273 } 1274 set stat [catch {eval {berkdb envremove -home} $dir $encarg} ret] 1275 # 1276 # If something failed and we are left with a region entry 1277 # in /dev/shmem that is zero-length, the envremove will 1278 # succeed, and the shm_unlink will succeed, but it will not 1279 # remove the zero-length entry from /dev/shmem. Remove it 1280 # using fileremove or else all other tests using an env 1281 # will immediately fail. 1282 # 1283 if { $is_qnx_test == 1 } { 1284 set region_files [glob -nocomplain /dev/shmem/$dir*] 1285 if { [llength $region_files] != 0 } { 1286 foreach f $region_files { 1287 fileremove -f $f 1288 } 1289 } 1290 } 1291 log_cleanup $dir 1292 cleanup $dir NULL 1293} 1294 1295# Start an RPC server. Don't return to caller until the 1296# server is up. Wait up to $maxwait seconds. 1297proc rpc_server_start { { encrypted 0 } { maxwait 30 } { args "" } } { 1298 source ./include.tcl 1299 global rpc_svc 1300 global passwd 1301 1302 set encargs "" 1303 # Set -v for verbose messages from the RPC server. 1304 # set encargs " -v " 1305 1306 if { $encrypted == 1 } { 1307 set encargs " -P $passwd " 1308 } 1309 1310 if { [string compare $rpc_server "localhost"] == 0 } { 1311 set dpid [eval {exec $util_path/$rpc_svc \ 1312 -h $rpc_testdir} $args $encargs &] 1313 } else { 1314 set dpid [eval {exec rsh $rpc_server \ 1315 $rpc_path/$rpc_svc -h $rpc_testdir $args} &] 1316 } 1317 1318 # Wait a couple of seconds before we start looking for 1319 # the server. 1320 tclsleep 2 1321 set home [file tail $rpc_testdir] 1322 if { $encrypted == 1 } { 1323 set encargs " -encryptaes $passwd " 1324 } 1325 for { set i 0 } { $i < $maxwait } { incr i } { 1326 # Try an operation -- while it fails with NOSERVER, sleep for 1327 # a second and retry. 1328 if {[catch {berkdb envremove -force -home "$home.FAIL" \ 1329 -server $rpc_server} res] && \ 1330 [is_substr $res DB_NOSERVER:]} { 1331 tclsleep 1 1332 } else { 1333 # Server is up, clean up and return to caller 1334 break 1335 } 1336 if { $i >= $maxwait } { 1337 puts "FAIL: RPC server\ 1338 not started after $maxwait seconds" 1339 } 1340 } 1341 return $dpid 1342} 1343 1344proc remote_cleanup { server dir localdir } { 1345 set home [file tail $dir] 1346 error_check_good cleanup:remove [berkdb envremove -home $home \ 1347 -server $server] 0 1348 catch {exec rsh $server rm -f $dir/*} ret 1349 cleanup $localdir NULL 1350} 1351 1352proc help { cmd } { 1353 if { [info command $cmd] == $cmd } { 1354 set is_proc [lsearch [info procs $cmd] $cmd] 1355 if { $is_proc == -1 } { 1356 # Not a procedure; must be a C command 1357 # Let's hope that it takes some parameters 1358 # and that it prints out a message 1359 puts "Usage: [eval $cmd]" 1360 } else { 1361 # It is a tcl procedure 1362 puts -nonewline "Usage: $cmd" 1363 set args [info args $cmd] 1364 foreach a $args { 1365 set is_def [info default $cmd $a val] 1366 if { $is_def != 0 } { 1367 # Default value 1368 puts -nonewline " $a=$val" 1369 } elseif {$a == "args"} { 1370 # Print out flag values 1371 puts " options" 1372 args 1373 } else { 1374 # No default value 1375 puts -nonewline " $a" 1376 } 1377 } 1378 puts "" 1379 } 1380 } else { 1381 puts "$cmd is not a command" 1382 } 1383} 1384 1385# Run a recovery test for a particular operation 1386# Notice that we catch the return from CP and do not do anything with it. 1387# This is because Solaris CP seems to exit non-zero on occasion, but 1388# everything else seems to run just fine. 1389# 1390# We split it into two functions so that the preparation and command 1391# could be executed in a different process than the recovery. 1392# 1393proc op_codeparse { encodedop op } { 1394 set op1 "" 1395 set op2 "" 1396 switch $encodedop { 1397 "abort" { 1398 set op1 $encodedop 1399 set op2 "" 1400 } 1401 "commit" { 1402 set op1 $encodedop 1403 set op2 "" 1404 } 1405 "prepare-abort" { 1406 set op1 "prepare" 1407 set op2 "abort" 1408 } 1409 "prepare-commit" { 1410 set op1 "prepare" 1411 set op2 "commit" 1412 } 1413 "prepare-discard" { 1414 set op1 "prepare" 1415 set op2 "discard" 1416 } 1417 } 1418 1419 if { $op == "op" } { 1420 return $op1 1421 } else { 1422 return $op2 1423 } 1424} 1425 1426proc op_recover { encodedop dir env_cmd dbfile cmd msg } { 1427 source ./include.tcl 1428 1429 set op [op_codeparse $encodedop "op"] 1430 set op2 [op_codeparse $encodedop "sub"] 1431 puts "\t$msg $encodedop" 1432 set gidf "" 1433 if { $op == "prepare" } { 1434 sentinel_init 1435 1436 # Fork off a child to run the cmd 1437 # We append the gid, so start here making sure 1438 # we don't have old gid's around. 1439 set outfile $testdir/childlog 1440 fileremove -f $testdir/gidfile 1441 set gidf $testdir/gidfile 1442 set pidlist {} 1443 # puts "$tclsh_path $test_path/recdscript.tcl $testdir/recdout \ 1444 # $op $dir $env_cmd $dbfile $gidf $cmd" 1445 set p [exec $tclsh_path $test_path/wrap.tcl recdscript.tcl \ 1446 $testdir/recdout $op $dir $env_cmd $dbfile $gidf $cmd &] 1447 lappend pidlist $p 1448 watch_procs $pidlist 5 1449 set f1 [open $testdir/recdout r] 1450 set r [read $f1] 1451 puts -nonewline $r 1452 close $f1 1453 fileremove -f $testdir/recdout 1454 } else { 1455 op_recover_prep $op $dir $env_cmd $dbfile $gidf $cmd 1456 } 1457 op_recover_rec $op $op2 $dir $env_cmd $dbfile $gidf 1458} 1459 1460proc op_recover_prep { op dir env_cmd dbfile gidf cmd } { 1461 global log_log_record_types 1462 global recd_debug 1463 global recd_id 1464 global recd_op 1465 source ./include.tcl 1466 1467 #puts "op_recover: $op $dir $env $dbfile $cmd" 1468 1469 set init_file $dir/t1 1470 set afterop_file $dir/t2 1471 set final_file $dir/t3 1472 1473 # Keep track of the log types we've seen 1474 if { $log_log_record_types == 1} { 1475 logtrack_read $dir 1476 } 1477 1478 # Save the initial file and open the environment and the file 1479 catch { file copy -force $dir/$dbfile $dir/$dbfile.init } res 1480 copy_extent_file $dir $dbfile init 1481 1482 convert_encrypt $env_cmd 1483 set env [eval $env_cmd] 1484 error_check_good envopen [is_valid_env $env] TRUE 1485 1486 set db [berkdb open -auto_commit -env $env $dbfile] 1487 error_check_good dbopen [is_valid_db $db] TRUE 1488 1489 # Dump out file contents for initial case 1490 open_and_dump_file $dbfile $env $init_file nop \ 1491 dump_file_direction "-first" "-next" 1492 1493 set t [$env txn] 1494 error_check_bad txn_begin $t NULL 1495 error_check_good txn_begin [is_substr $t "txn"] 1 1496 1497 # Now fill in the db, tmgr, and the txnid in the command 1498 set exec_cmd $cmd 1499 1500 set i [lsearch $cmd ENV] 1501 if { $i != -1 } { 1502 set exec_cmd [lreplace $exec_cmd $i $i $env] 1503 } 1504 1505 set i [lsearch $cmd TXNID] 1506 if { $i != -1 } { 1507 set exec_cmd [lreplace $exec_cmd $i $i $t] 1508 } 1509 1510 set i [lsearch $exec_cmd DB] 1511 if { $i != -1 } { 1512 set exec_cmd [lreplace $exec_cmd $i $i $db] 1513 } 1514 1515 # To test DB_CONSUME, we need to expect a record return, not "0". 1516 set i [lsearch $exec_cmd "-consume"] 1517 if { $i != -1 } { 1518 set record_exec_cmd_ret 1 1519 } else { 1520 set record_exec_cmd_ret 0 1521 } 1522 1523 # For the DB_APPEND test, we need to expect a return other than 1524 # 0; set this flag to be more lenient in the error_check_good. 1525 set i [lsearch $exec_cmd "-append"] 1526 if { $i != -1 } { 1527 set lenient_exec_cmd_ret 1 1528 } else { 1529 set lenient_exec_cmd_ret 0 1530 } 1531 1532 # Execute command and commit/abort it. 1533 set ret [eval $exec_cmd] 1534 if { $record_exec_cmd_ret == 1 } { 1535 error_check_good "\"$exec_cmd\"" [llength [lindex $ret 0]] 2 1536 } elseif { $lenient_exec_cmd_ret == 1 } { 1537 error_check_good "\"$exec_cmd\"" [expr $ret > 0] 1 1538 } else { 1539 error_check_good "\"$exec_cmd\"" $ret 0 1540 } 1541 1542 set record_exec_cmd_ret 0 1543 set lenient_exec_cmd_ret 0 1544 1545 # Sync the file so that we can capture a snapshot to test recovery. 1546 error_check_good sync:$db [$db sync] 0 1547 1548 catch { file copy -force $dir/$dbfile $dir/$dbfile.afterop } res 1549 copy_extent_file $dir $dbfile afterop 1550 open_and_dump_file $dir/$dbfile.afterop NULL \ 1551 $afterop_file nop dump_file_direction "-first" "-next" 1552 1553 #puts "\t\t\tExecuting txn_$op:$t" 1554 if { $op == "prepare" } { 1555 set gid [make_gid global:$t] 1556 set gfd [open $gidf w+] 1557 puts $gfd $gid 1558 close $gfd 1559 error_check_good txn_$op:$t [$t $op $gid] 0 1560 } else { 1561 error_check_good txn_$op:$t [$t $op] 0 1562 } 1563 1564 switch $op { 1565 "commit" { puts "\t\tCommand executed and committed." } 1566 "abort" { puts "\t\tCommand executed and aborted." } 1567 "prepare" { puts "\t\tCommand executed and prepared." } 1568 } 1569 1570 # Sync the file so that we can capture a snapshot to test recovery. 1571 error_check_good sync:$db [$db sync] 0 1572 1573 catch { file copy -force $dir/$dbfile $dir/$dbfile.final } res 1574 copy_extent_file $dir $dbfile final 1575 open_and_dump_file $dir/$dbfile.final NULL \ 1576 $final_file nop dump_file_direction "-first" "-next" 1577 1578 # If this is an abort or prepare-abort, it should match the 1579 # original file. 1580 # If this was a commit or prepare-commit, then this file should 1581 # match the afterop file. 1582 # If this was a prepare without an abort or commit, we still 1583 # have transactions active, and peering at the database from 1584 # another environment will show data from uncommitted transactions. 1585 # Thus we just skip this in the prepare-only case; what 1586 # we care about are the results of a prepare followed by a 1587 # recovery, which we test later. 1588 if { $op == "commit" } { 1589 filesort $afterop_file $afterop_file.sort 1590 filesort $final_file $final_file.sort 1591 error_check_good \ 1592 diff(post-$op,pre-commit):diff($afterop_file,$final_file) \ 1593 [filecmp $afterop_file.sort $final_file.sort] 0 1594 } elseif { $op == "abort" } { 1595 filesort $init_file $init_file.sort 1596 filesort $final_file $final_file.sort 1597 error_check_good \ 1598 diff(initial,post-$op):diff($init_file,$final_file) \ 1599 [filecmp $init_file.sort $final_file.sort] 0 1600 } else { 1601 # Make sure this really is one of the prepare tests 1602 error_check_good assert:prepare-test $op "prepare" 1603 } 1604 1605 # Running recovery on this database should not do anything. 1606 # Flush all data to disk, close the environment and save the 1607 # file. 1608 # XXX DO NOT CLOSE FILE ON PREPARE -- if you are prepared, 1609 # you really have an active transaction and you're not allowed 1610 # to close files that are being acted upon by in-process 1611 # transactions. 1612 if { $op != "prepare" } { 1613 error_check_good close:$db [$db close] 0 1614 } 1615 1616 # 1617 # If we are running 'prepare' don't close the env with an 1618 # active transaction. Leave it alone so the close won't 1619 # quietly abort it on us. 1620 if { [is_substr $op "prepare"] != 1 } { 1621 error_check_good log_flush [$env log_flush] 0 1622 error_check_good envclose [$env close] 0 1623 } 1624 return 1625} 1626 1627proc op_recover_rec { op op2 dir env_cmd dbfile gidf} { 1628 global log_log_record_types 1629 global recd_debug 1630 global recd_id 1631 global recd_op 1632 global encrypt 1633 global passwd 1634 source ./include.tcl 1635 1636 #puts "op_recover_rec: $op $op2 $dir $env_cmd $dbfile $gidf" 1637 1638 set init_file $dir/t1 1639 set afterop_file $dir/t2 1640 set final_file $dir/t3 1641 1642 # Keep track of the log types we've seen 1643 if { $log_log_record_types == 1} { 1644 logtrack_read $dir 1645 } 1646 1647 berkdb debug_check 1648 puts -nonewline "\t\top_recover_rec: Running recovery ... " 1649 flush stdout 1650 1651 set recargs "-h $dir -c " 1652 if { $encrypt > 0 } { 1653 append recargs " -P $passwd " 1654 } 1655 set stat [catch {eval exec $util_path/db_recover -e $recargs} result] 1656 if { $stat == 1 } { 1657 error "FAIL: Recovery error: $result." 1658 } 1659 puts -nonewline "complete ... " 1660 1661 # 1662 # We cannot run db_recover here because that will open an env, run 1663 # recovery, then close it, which will abort the outstanding txns. 1664 # We want to do it ourselves. 1665 # 1666 set env [eval $env_cmd] 1667 error_check_good dbenv [is_valid_widget $env env] TRUE 1668 1669 error_check_good db_verify [verify_dir $testdir "\t\t" 0 1] 0 1670 puts "verified" 1671 1672 # If we left a txn as prepared, but not aborted or committed, 1673 # we need to do a txn_recover. Make sure we have the same 1674 # number of txns we want. 1675 if { $op == "prepare"} { 1676 set txns [$env txn_recover] 1677 error_check_bad txnrecover [llength $txns] 0 1678 set gfd [open $gidf r] 1679 set origgid [read -nonewline $gfd] 1680 close $gfd 1681 set txnlist [lindex $txns 0] 1682 set t [lindex $txnlist 0] 1683 set gid [lindex $txnlist 1] 1684 error_check_good gidcompare $gid $origgid 1685 puts "\t\t\tExecuting txn_$op2:$t" 1686 error_check_good txn_$op2:$t [$t $op2] 0 1687 # 1688 # If we are testing discard, we do need to resolve 1689 # the txn, so get the list again and now abort it. 1690 # 1691 if { $op2 == "discard" } { 1692 set txns [$env txn_recover] 1693 error_check_bad txnrecover [llength $txns] 0 1694 set txnlist [lindex $txns 0] 1695 set t [lindex $txnlist 0] 1696 set gid [lindex $txnlist 1] 1697 error_check_good gidcompare $gid $origgid 1698 puts "\t\t\tExecuting txn_abort:$t" 1699 error_check_good disc_txn_abort:$t [$t abort] 0 1700 } 1701 } 1702 1703 open_and_dump_file $dir/$dbfile NULL $final_file nop \ 1704 dump_file_direction "-first" "-next" 1705 if { $op == "commit" || $op2 == "commit" } { 1706 filesort $afterop_file $afterop_file.sort 1707 filesort $final_file $final_file.sort 1708 error_check_good \ 1709 diff(post-$op,pre-commit):diff($afterop_file,$final_file) \ 1710 [filecmp $afterop_file.sort $final_file.sort] 0 1711 } else { 1712 filesort $init_file $init_file.sort 1713 filesort $final_file $final_file.sort 1714 error_check_good \ 1715 diff(initial,post-$op):diff($init_file,$final_file) \ 1716 [filecmp $init_file.sort $final_file.sort] 0 1717 } 1718 1719 # Now close the environment, substitute a file that will need 1720 # recovery and try running recovery again. 1721 reset_env $env 1722 if { $op == "commit" || $op2 == "commit" } { 1723 catch { file copy -force $dir/$dbfile.init $dir/$dbfile } res 1724 move_file_extent $dir $dbfile init copy 1725 } else { 1726 catch { file copy -force $dir/$dbfile.afterop $dir/$dbfile } res 1727 move_file_extent $dir $dbfile afterop copy 1728 } 1729 1730 berkdb debug_check 1731 puts -nonewline "\t\tRunning recovery on pre-op database ... " 1732 flush stdout 1733 1734 set stat [catch {eval exec $util_path/db_recover $recargs} result] 1735 if { $stat == 1 } { 1736 error "FAIL: Recovery error: $result." 1737 } 1738 puts -nonewline "complete ... " 1739 1740 error_check_good db_verify_preop [verify_dir $testdir "\t\t" 0 1] 0 1741 1742 puts "verified" 1743 1744 set env [eval $env_cmd] 1745 1746 open_and_dump_file $dir/$dbfile NULL $final_file nop \ 1747 dump_file_direction "-first" "-next" 1748 if { $op == "commit" || $op2 == "commit" } { 1749 filesort $final_file $final_file.sort 1750 filesort $afterop_file $afterop_file.sort 1751 error_check_good \ 1752 diff(post-$op,recovered):diff($afterop_file,$final_file) \ 1753 [filecmp $afterop_file.sort $final_file.sort] 0 1754 } else { 1755 filesort $init_file $init_file.sort 1756 filesort $final_file $final_file.sort 1757 error_check_good \ 1758 diff(initial,post-$op):diff($init_file,$final_file) \ 1759 [filecmp $init_file.sort $final_file.sort] 0 1760 } 1761 1762 # This should just close the environment, not blow it away. 1763 reset_env $env 1764} 1765 1766proc populate { db method txn n dups bigdata } { 1767 source ./include.tcl 1768 1769 set did [open $dict] 1770 set count 0 1771 while { [gets $did str] != -1 && $count < $n } { 1772 if { [is_record_based $method] == 1 } { 1773 set key [expr $count + 1] 1774 } elseif { $dups == 1 } { 1775 set key duplicate_key 1776 } else { 1777 set key $str 1778 } 1779 if { $bigdata == 1 && [berkdb random_int 1 3] == 1} { 1780 set str [replicate $str 1000] 1781 } 1782 1783 set ret [$db put -txn $txn $key $str] 1784 error_check_good db_put:$key $ret 0 1785 incr count 1786 } 1787 close $did 1788 return 0 1789} 1790 1791proc big_populate { db txn n } { 1792 source ./include.tcl 1793 1794 set did [open $dict] 1795 set count 0 1796 while { [gets $did str] != -1 && $count < $n } { 1797 set key [replicate $str 50] 1798 set ret [$db put -txn $txn $key $str] 1799 error_check_good db_put:$key $ret 0 1800 incr count 1801 } 1802 close $did 1803 return 0 1804} 1805 1806proc unpopulate { db txn num } { 1807 source ./include.tcl 1808 1809 set c [eval {$db cursor} "-txn $txn"] 1810 error_check_bad $db:cursor $c NULL 1811 error_check_good $db:cursor [is_substr $c $db] 1 1812 1813 set i 0 1814 for {set d [$c get -first] } { [llength $d] != 0 } { 1815 set d [$c get -next] } { 1816 $c del 1817 incr i 1818 if { $num != 0 && $i >= $num } { 1819 break 1820 } 1821 } 1822 error_check_good cursor_close [$c close] 0 1823 return 0 1824} 1825 1826# Flush logs for txn envs only. 1827proc reset_env { env } { 1828 if { [is_txnenv $env] } { 1829 error_check_good log_flush [$env log_flush] 0 1830 } 1831 error_check_good env_close [$env close] 0 1832} 1833 1834proc maxlocks { myenv locker_id obj_id num } { 1835 return [countlocks $myenv $locker_id $obj_id $num ] 1836} 1837 1838proc maxwrites { myenv locker_id obj_id num } { 1839 return [countlocks $myenv $locker_id $obj_id $num ] 1840} 1841 1842proc minlocks { myenv locker_id obj_id num } { 1843 return [countlocks $myenv $locker_id $obj_id $num ] 1844} 1845 1846proc minwrites { myenv locker_id obj_id num } { 1847 return [countlocks $myenv $locker_id $obj_id $num ] 1848} 1849 1850proc countlocks { myenv locker_id obj_id num } { 1851 set locklist "" 1852 for { set i 0} {$i < [expr $obj_id * 4]} { incr i } { 1853 set r [catch {$myenv lock_get read $locker_id \ 1854 [expr $obj_id * 1000 + $i]} l ] 1855 if { $r != 0 } { 1856 puts $l 1857 return ERROR 1858 } else { 1859 error_check_good lockget:$obj_id [is_substr $l $myenv] 1 1860 lappend locklist $l 1861 } 1862 } 1863 1864 # Now acquire one write lock, except for obj_id 1, which doesn't 1865 # acquire any. We'll use obj_id 1 to test minwrites. 1866 if { $obj_id != 1 } { 1867 set r [catch {$myenv lock_get write $locker_id \ 1868 [expr $obj_id * 1000 + 10]} l ] 1869 if { $r != 0 } { 1870 puts $l 1871 return ERROR 1872 } else { 1873 error_check_good lockget:$obj_id [is_substr $l $myenv] 1 1874 lappend locklist $l 1875 } 1876 } 1877 1878 # Get one extra write lock for obj_id 2. We'll use 1879 # obj_id 2 to test maxwrites. 1880 # 1881 if { $obj_id == 2 } { 1882 set extra [catch {$myenv lock_get write \ 1883 $locker_id [expr $obj_id * 1000 + 11]} l ] 1884 if { $extra != 0 } { 1885 puts $l 1886 return ERROR 1887 } else { 1888 error_check_good lockget:$obj_id [is_substr $l $myenv] 1 1889 lappend locklist $l 1890 } 1891 } 1892 1893 set ret [ring $myenv $locker_id $obj_id $num] 1894 1895 foreach l $locklist { 1896 error_check_good lockput:$l [$l put] 0 1897 } 1898 1899 return $ret 1900} 1901 1902# This routine will let us obtain a ring of deadlocks. 1903# Each locker will get a lock on obj_id, then sleep, and 1904# then try to lock (obj_id + 1) % num. 1905# When the lock is finally granted, we release our locks and 1906# return 1 if we got both locks and DEADLOCK if we deadlocked. 1907# The results here should be that 1 locker deadlocks and the 1908# rest all finish successfully. 1909proc ring { myenv locker_id obj_id num } { 1910 source ./include.tcl 1911 1912 if {[catch {$myenv lock_get write $locker_id $obj_id} lock1] != 0} { 1913 puts $lock1 1914 return ERROR 1915 } else { 1916 error_check_good lockget:$obj_id [is_substr $lock1 $myenv] 1 1917 } 1918 1919 tclsleep 30 1920 set nextobj [expr ($obj_id + 1) % $num] 1921 set ret 1 1922 if {[catch {$myenv lock_get write $locker_id $nextobj} lock2] != 0} { 1923 if {[string match "*DEADLOCK*" $lock2] == 1} { 1924 set ret DEADLOCK 1925 } else { 1926 if {[string match "*NOTGRANTED*" $lock2] == 1} { 1927 set ret DEADLOCK 1928 } else { 1929 puts $lock2 1930 set ret ERROR 1931 } 1932 } 1933 } else { 1934 error_check_good lockget:$obj_id [is_substr $lock2 $myenv] 1 1935 } 1936 1937 # Now release the first lock 1938 error_check_good lockput:$lock1 [$lock1 put] 0 1939 1940 if {$ret == 1} { 1941 error_check_bad lockget:$obj_id $lock2 NULL 1942 error_check_good lockget:$obj_id [is_substr $lock2 $myenv] 1 1943 error_check_good lockput:$lock2 [$lock2 put] 0 1944 } 1945 return $ret 1946} 1947 1948# This routine will create massive deadlocks. 1949# Each locker will get a readlock on obj_id, then sleep, and 1950# then try to upgrade the readlock to a write lock. 1951# When the lock is finally granted, we release our first lock and 1952# return 1 if we got both locks and DEADLOCK if we deadlocked. 1953# The results here should be that 1 locker succeeds in getting all 1954# the locks and everyone else deadlocks. 1955proc clump { myenv locker_id obj_id num } { 1956 source ./include.tcl 1957 1958 set obj_id 10 1959 if {[catch {$myenv lock_get read $locker_id $obj_id} lock1] != 0} { 1960 puts $lock1 1961 return ERROR 1962 } else { 1963 error_check_good lockget:$obj_id \ 1964 [is_valid_lock $lock1 $myenv] TRUE 1965 } 1966 1967 tclsleep 30 1968 set ret 1 1969 if {[catch {$myenv lock_get write $locker_id $obj_id} lock2] != 0} { 1970 if {[string match "*DEADLOCK*" $lock2] == 1} { 1971 set ret DEADLOCK 1972 } else { 1973 if {[string match "*NOTGRANTED*" $lock2] == 1} { 1974 set ret DEADLOCK 1975 } else { 1976 puts $lock2 1977 set ret ERROR 1978 } 1979 } 1980 } else { 1981 error_check_good \ 1982 lockget:$obj_id [is_valid_lock $lock2 $myenv] TRUE 1983 } 1984 1985 # Now release the first lock 1986 error_check_good lockput:$lock1 [$lock1 put] 0 1987 1988 if {$ret == 1} { 1989 error_check_good \ 1990 lockget:$obj_id [is_valid_lock $lock2 $myenv] TRUE 1991 error_check_good lockput:$lock2 [$lock2 put] 0 1992 } 1993 return $ret 1994} 1995 1996proc dead_check { t procs timeout dead clean other } { 1997 error_check_good $t:$procs:other $other 0 1998 switch $t { 1999 ring { 2000 # With timeouts the number of deadlocks is 2001 # unpredictable: test for at least one deadlock. 2002 if { $timeout != 0 && $dead > 1 } { 2003 set clean [ expr $clean + $dead - 1] 2004 set dead 1 2005 } 2006 error_check_good $t:$procs:deadlocks $dead 1 2007 error_check_good $t:$procs:success $clean \ 2008 [expr $procs - 1] 2009 } 2010 clump { 2011 # With timeouts the number of deadlocks is 2012 # unpredictable: test for no more than one 2013 # successful lock. 2014 if { $timeout != 0 && $dead == $procs } { 2015 set clean 1 2016 set dead [expr $procs - 1] 2017 } 2018 error_check_good $t:$procs:deadlocks $dead \ 2019 [expr $procs - 1] 2020 error_check_good $t:$procs:success $clean 1 2021 } 2022 oldyoung { 2023 error_check_good $t:$procs:deadlocks $dead 1 2024 error_check_good $t:$procs:success $clean \ 2025 [expr $procs - 1] 2026 } 2027 maxlocks { 2028 error_check_good $t:$procs:deadlocks $dead 1 2029 error_check_good $t:$procs:success $clean \ 2030 [expr $procs - 1] 2031 } 2032 maxwrites { 2033 error_check_good $t:$procs:deadlocks $dead 1 2034 error_check_good $t:$procs:success $clean \ 2035 [expr $procs - 1] 2036 } 2037 minlocks { 2038 error_check_good $t:$procs:deadlocks $dead 1 2039 error_check_good $t:$procs:success $clean \ 2040 [expr $procs - 1] 2041 } 2042 minwrites { 2043 error_check_good $t:$procs:deadlocks $dead 1 2044 error_check_good $t:$procs:success $clean \ 2045 [expr $procs - 1] 2046 } 2047 default { 2048 error "Test $t not implemented" 2049 } 2050 } 2051} 2052 2053proc rdebug { id op where } { 2054 global recd_debug 2055 global recd_id 2056 global recd_op 2057 2058 set recd_debug $where 2059 set recd_id $id 2060 set recd_op $op 2061} 2062 2063proc rtag { msg id } { 2064 set tag [lindex $msg 0] 2065 set tail [expr [string length $tag] - 2] 2066 set tag [string range $tag $tail $tail] 2067 if { $id == $tag } { 2068 return 1 2069 } else { 2070 return 0 2071 } 2072} 2073 2074proc zero_list { n } { 2075 set ret "" 2076 while { $n > 0 } { 2077 lappend ret 0 2078 incr n -1 2079 } 2080 return $ret 2081} 2082 2083proc check_dump { k d } { 2084 puts "key: $k data: $d" 2085} 2086 2087proc reverse { s } { 2088 set res "" 2089 for { set i 0 } { $i < [string length $s] } { incr i } { 2090 set res "[string index $s $i]$res" 2091 } 2092 2093 return $res 2094} 2095 2096# 2097# This is a internal only proc. All tests should use 'is_valid_db' etc. 2098# 2099proc is_valid_widget { w expected } { 2100 # First N characters must match "expected" 2101 set l [string length $expected] 2102 incr l -1 2103 if { [string compare [string range $w 0 $l] $expected] != 0 } { 2104 return $w 2105 } 2106 2107 # Remaining characters must be digits 2108 incr l 1 2109 for { set i $l } { $i < [string length $w] } { incr i} { 2110 set c [string index $w $i] 2111 if { $c < "0" || $c > "9" } { 2112 return $w 2113 } 2114 } 2115 2116 return TRUE 2117} 2118 2119proc is_valid_db { db } { 2120 return [is_valid_widget $db db] 2121} 2122 2123proc is_valid_env { env } { 2124 return [is_valid_widget $env env] 2125} 2126 2127proc is_valid_cursor { dbc db } { 2128 return [is_valid_widget $dbc $db.c] 2129} 2130 2131proc is_valid_lock { lock env } { 2132 return [is_valid_widget $lock $env.lock] 2133} 2134 2135proc is_valid_logc { logc env } { 2136 return [is_valid_widget $logc $env.logc] 2137} 2138 2139proc is_valid_mpool { mpool env } { 2140 return [is_valid_widget $mpool $env.mp] 2141} 2142 2143proc is_valid_page { page mpool } { 2144 return [is_valid_widget $page $mpool.pg] 2145} 2146 2147proc is_valid_txn { txn env } { 2148 return [is_valid_widget $txn $env.txn] 2149} 2150 2151proc is_valid_lock {l env} { 2152 return [is_valid_widget $l $env.lock] 2153} 2154 2155proc is_valid_locker {l } { 2156 return [is_valid_widget $l ""] 2157} 2158 2159proc is_valid_seq { seq } { 2160 return [is_valid_widget $seq seq] 2161} 2162 2163proc send_cmd { fd cmd {sleep 2}} { 2164 source ./include.tcl 2165 2166 puts $fd "if \[catch {set v \[$cmd\] ; puts \$v} ret\] { \ 2167 puts \"FAIL: \$ret\" \ 2168 }" 2169 puts $fd "flush stdout" 2170 flush $fd 2171 berkdb debug_check 2172 tclsleep $sleep 2173 2174 set r [rcv_result $fd] 2175 return $r 2176} 2177 2178proc rcv_result { fd } { 2179 global errorInfo 2180 2181 set r [gets $fd result] 2182 if { $r == -1 } { 2183 puts "FAIL: gets returned -1 (EOF)" 2184 puts "FAIL: errorInfo is $errorInfo" 2185 } 2186 2187 return $result 2188} 2189 2190proc send_timed_cmd { fd rcv_too cmd } { 2191 set c1 "set start \[timestamp -r\]; " 2192 set c2 "puts \[expr \[timestamp -r\] - \$start\]" 2193 set full_cmd [concat $c1 $cmd ";" $c2] 2194 2195 puts $fd $full_cmd 2196 puts $fd "flush stdout" 2197 flush $fd 2198 return 0 2199} 2200 2201# 2202# The rationale behind why we have *two* "data padding" routines is outlined 2203# below: 2204# 2205# Both pad_data and chop_data truncate data that is too long. However, 2206# pad_data also adds the pad character to pad data out to the fixed length 2207# record length. 2208# 2209# Which routine you call does not depend on the length of the data you're 2210# using, but on whether you're doing a put or a get. When we do a put, we 2211# have to make sure the data isn't longer than the size of a record because 2212# otherwise we'll get an error (use chop_data). When we do a get, we want to 2213# check that db padded everything correctly (use pad_data on the value against 2214# which we are comparing). 2215# 2216# We don't want to just use the pad_data routine for both purposes, because 2217# we want to be able to test whether or not db is padding correctly. For 2218# example, the queue access method had a bug where when a record was 2219# overwritten (*not* a partial put), only the first n bytes of the new entry 2220# were written, n being the new entry's (unpadded) length. So, if we did 2221# a put with key,value pair (1, "abcdef") and then a put (1, "z"), we'd get 2222# back (1,"zbcdef"). If we had used pad_data instead of chop_data, we would 2223# have gotten the "correct" result, but we wouldn't have found this bug. 2224proc chop_data {method data} { 2225 global fixed_len 2226 2227 if {[is_fixed_length $method] == 1 && \ 2228 [string length $data] > $fixed_len} { 2229 return [eval {binary format a$fixed_len $data}] 2230 } else { 2231 return $data 2232 } 2233} 2234 2235proc pad_data {method data} { 2236 global fixed_len 2237 2238 if {[is_fixed_length $method] == 1} { 2239 return [eval {binary format a$fixed_len $data}] 2240 } else { 2241 return $data 2242 } 2243} 2244 2245# 2246# The make_fixed_length proc is used in special circumstances where we 2247# absolutely need to send in data that is already padded out to the fixed 2248# length with a known pad character. Most tests should use chop_data and 2249# pad_data, not this. 2250# 2251proc make_fixed_length {method data {pad 0}} { 2252 global fixed_len 2253 2254 if {[is_fixed_length $method] == 1} { 2255 set data [chop_data $method $data] 2256 while { [string length $data] < $fixed_len } { 2257 set data [format $data%c $pad] 2258 } 2259 } 2260 return $data 2261} 2262 2263proc make_gid {data} { 2264 while { [string length $data] < 128 } { 2265 set data [format ${data}0] 2266 } 2267 return $data 2268} 2269 2270# shift data for partial 2271# pad with fixed pad (which is NULL) 2272proc partial_shift { data offset direction} { 2273 global fixed_len 2274 2275 set len [expr $fixed_len - 1] 2276 2277 if { [string compare $direction "right"] == 0 } { 2278 for { set i 1} { $i <= $offset } {incr i} { 2279 set data [binary format x1a$len $data] 2280 } 2281 } elseif { [string compare $direction "left"] == 0 } { 2282 for { set i 1} { $i <= $offset } {incr i} { 2283 set data [string range $data 1 end] 2284 set data [binary format a$len $data] 2285 } 2286 } 2287 return $data 2288} 2289 2290# string compare does not always work to compare 2291# this data, nor does expr (==) 2292# specialized routine for comparison 2293# (for use in fixed len recno and q) 2294proc binary_compare { data1 data2 } { 2295 if { [string length $data1] != [string length $data2] || \ 2296 [string compare -length \ 2297 [string length $data1] $data1 $data2] != 0 } { 2298 return 1 2299 } else { 2300 return 0 2301 } 2302} 2303 2304# This is a comparison function used with the lsort command. 2305# It treats its inputs as 32 bit signed integers for comparison, 2306# and is coded to work with both 32 bit and 64 bit versions of tclsh. 2307proc int32_compare { val1 val2 } { 2308 # Big is set to 2^32 on a 64 bit machine, or 0 on 32 bit machine. 2309 set big [expr 0xffffffff + 1] 2310 if { $val1 >= 0x80000000 } { 2311 set val1 [expr $val1 - $big] 2312 } 2313 if { $val2 >= 0x80000000 } { 2314 set val2 [expr $val2 - $big] 2315 } 2316 return [expr $val1 - $val2] 2317} 2318 2319proc convert_method { method } { 2320 switch -- $method { 2321 -btree - 2322 -dbtree - 2323 dbtree - 2324 -ddbtree - 2325 ddbtree - 2326 -rbtree - 2327 BTREE - 2328 DB_BTREE - 2329 DB_RBTREE - 2330 RBTREE - 2331 bt - 2332 btree - 2333 db_btree - 2334 db_rbtree - 2335 rbt - 2336 rbtree { return "-btree" } 2337 2338 -dhash - 2339 -ddhash - 2340 -hash - 2341 DB_HASH - 2342 HASH - 2343 dhash - 2344 ddhash - 2345 db_hash - 2346 h - 2347 hash { return "-hash" } 2348 2349 -queue - 2350 DB_QUEUE - 2351 QUEUE - 2352 db_queue - 2353 q - 2354 qam - 2355 queue - 2356 -iqueue - 2357 DB_IQUEUE - 2358 IQUEUE - 2359 db_iqueue - 2360 iq - 2361 iqam - 2362 iqueue { return "-queue" } 2363 2364 -queueextent - 2365 QUEUEEXTENT - 2366 qe - 2367 qamext - 2368 -queueext - 2369 queueextent - 2370 queueext - 2371 -iqueueextent - 2372 IQUEUEEXTENT - 2373 iqe - 2374 iqamext - 2375 -iqueueext - 2376 iqueueextent - 2377 iqueueext { return "-queue" } 2378 2379 -frecno - 2380 -recno - 2381 -rrecno - 2382 DB_FRECNO - 2383 DB_RECNO - 2384 DB_RRECNO - 2385 FRECNO - 2386 RECNO - 2387 RRECNO - 2388 db_frecno - 2389 db_recno - 2390 db_rrecno - 2391 frec - 2392 frecno - 2393 rec - 2394 recno - 2395 rrec - 2396 rrecno { return "-recno" } 2397 2398 default { error "FAIL:[timestamp] $method: unknown method" } 2399 } 2400} 2401 2402proc split_encargs { largs encargsp } { 2403 global encrypt 2404 upvar $encargsp e 2405 set eindex [lsearch $largs "-encrypta*"] 2406 if { $eindex == -1 } { 2407 set e "" 2408 set newl $largs 2409 } else { 2410 set eend [expr $eindex + 1] 2411 set e [lrange $largs $eindex $eend] 2412 set newl [lreplace $largs $eindex $eend "-encrypt"] 2413 } 2414 return $newl 2415} 2416 2417proc convert_encrypt { largs } { 2418 global encrypt 2419 global old_encrypt 2420 2421 set old_encrypt $encrypt 2422 set encrypt 0 2423 if { [lsearch $largs "-encrypt*"] != -1 } { 2424 set encrypt 1 2425 } 2426} 2427 2428# If recno-with-renumbering or btree-with-renumbering is specified, then 2429# fix the arguments to specify the DB_RENUMBER/DB_RECNUM option for the 2430# -flags argument. 2431proc convert_args { method {largs ""} } { 2432 global fixed_len 2433 global gen_upgrade 2434 global upgrade_be 2435 source ./include.tcl 2436 2437 if { [string first - $largs] == -1 &&\ 2438 [string compare $largs ""] != 0 &&\ 2439 [string compare $largs {{}}] != 0 } { 2440 set errstring "args must contain a hyphen; does this test\ 2441 have no numeric args?" 2442 puts "FAIL:[timestamp] $errstring (largs was $largs)" 2443 return -code return 2444 } 2445 2446 convert_encrypt $largs 2447 if { $gen_upgrade == 1 && $upgrade_be == 1 } { 2448 append largs " -lorder 4321 " 2449 } elseif { $gen_upgrade == 1 && $upgrade_be != 1 } { 2450 append largs " -lorder 1234 " 2451 } 2452 2453 if { [is_rrecno $method] == 1 } { 2454 append largs " -renumber " 2455 } elseif { [is_rbtree $method] == 1 } { 2456 append largs " -recnum " 2457 } elseif { [is_dbtree $method] == 1 } { 2458 append largs " -dup " 2459 } elseif { [is_ddbtree $method] == 1 } { 2460 append largs " -dup " 2461 append largs " -dupsort " 2462 } elseif { [is_dhash $method] == 1 } { 2463 append largs " -dup " 2464 } elseif { [is_ddhash $method] == 1 } { 2465 append largs " -dup " 2466 append largs " -dupsort " 2467 } elseif { [is_queueext $method] == 1 } { 2468 append largs " -extent 4 " 2469 } 2470 2471 if { [is_iqueue $method] == 1 || [is_iqueueext $method] == 1 } { 2472 append largs " -inorder " 2473 } 2474 2475 # Default padding character is ASCII nul. 2476 set fixed_pad 0 2477 if {[is_fixed_length $method] == 1} { 2478 append largs " -len $fixed_len -pad $fixed_pad " 2479 } 2480 return $largs 2481} 2482 2483proc is_btree { method } { 2484 set names { -btree BTREE DB_BTREE bt btree } 2485 if { [lsearch $names $method] >= 0 } { 2486 return 1 2487 } else { 2488 return 0 2489 } 2490} 2491 2492proc is_dbtree { method } { 2493 set names { -dbtree dbtree } 2494 if { [lsearch $names $method] >= 0 } { 2495 return 1 2496 } else { 2497 return 0 2498 } 2499} 2500 2501proc is_ddbtree { method } { 2502 set names { -ddbtree ddbtree } 2503 if { [lsearch $names $method] >= 0 } { 2504 return 1 2505 } else { 2506 return 0 2507 } 2508} 2509 2510proc is_rbtree { method } { 2511 set names { -rbtree rbtree RBTREE db_rbtree DB_RBTREE rbt } 2512 if { [lsearch $names $method] >= 0 } { 2513 return 1 2514 } else { 2515 return 0 2516 } 2517} 2518 2519proc is_recno { method } { 2520 set names { -recno DB_RECNO RECNO db_recno rec recno} 2521 if { [lsearch $names $method] >= 0 } { 2522 return 1 2523 } else { 2524 return 0 2525 } 2526} 2527 2528proc is_rrecno { method } { 2529 set names { -rrecno rrecno RRECNO db_rrecno DB_RRECNO rrec } 2530 if { [lsearch $names $method] >= 0 } { 2531 return 1 2532 } else { 2533 return 0 2534 } 2535} 2536 2537proc is_frecno { method } { 2538 set names { -frecno frecno frec FRECNO db_frecno DB_FRECNO} 2539 if { [lsearch $names $method] >= 0 } { 2540 return 1 2541 } else { 2542 return 0 2543 } 2544} 2545 2546proc is_hash { method } { 2547 set names { -hash DB_HASH HASH db_hash h hash } 2548 if { [lsearch $names $method] >= 0 } { 2549 return 1 2550 } else { 2551 return 0 2552 } 2553} 2554 2555proc is_dhash { method } { 2556 set names { -dhash dhash } 2557 if { [lsearch $names $method] >= 0 } { 2558 return 1 2559 } else { 2560 return 0 2561 } 2562} 2563 2564proc is_ddhash { method } { 2565 set names { -ddhash ddhash } 2566 if { [lsearch $names $method] >= 0 } { 2567 return 1 2568 } else { 2569 return 0 2570 } 2571} 2572 2573proc is_queue { method } { 2574 if { [is_queueext $method] == 1 || [is_iqueue $method] == 1 || \ 2575 [is_iqueueext $method] == 1 } { 2576 return 1 2577 } 2578 2579 set names { -queue DB_QUEUE QUEUE db_queue q queue qam } 2580 if { [lsearch $names $method] >= 0 } { 2581 return 1 2582 } else { 2583 return 0 2584 } 2585} 2586 2587proc is_queueext { method } { 2588 if { [is_iqueueext $method] == 1 } { 2589 return 1 2590 } 2591 2592 set names { -queueextent queueextent QUEUEEXTENT qe qamext \ 2593 queueext -queueext } 2594 if { [lsearch $names $method] >= 0 } { 2595 return 1 2596 } else { 2597 return 0 2598 } 2599} 2600 2601proc is_iqueue { method } { 2602 if { [is_iqueueext $method] == 1 } { 2603 return 1 2604 } 2605 2606 set names { -iqueue DB_IQUEUE IQUEUE db_iqueue iq iqueue iqam } 2607 if { [lsearch $names $method] >= 0 } { 2608 return 1 2609 } else { 2610 return 0 2611 } 2612} 2613 2614proc is_iqueueext { method } { 2615 set names { -iqueueextent iqueueextent IQUEUEEXTENT iqe iqamext \ 2616 iqueueext -iqueueext } 2617 if { [lsearch $names $method] >= 0 } { 2618 return 1 2619 } else { 2620 return 0 2621 } 2622} 2623 2624proc is_record_based { method } { 2625 if { [is_recno $method] || [is_frecno $method] || 2626 [is_rrecno $method] || [is_queue $method] } { 2627 return 1 2628 } else { 2629 return 0 2630 } 2631} 2632 2633proc is_fixed_length { method } { 2634 if { [is_queue $method] || [is_frecno $method] } { 2635 return 1 2636 } else { 2637 return 0 2638 } 2639} 2640 2641# Sort lines in file $in and write results to file $out. 2642# This is a more portable alternative to execing the sort command, 2643# which has assorted issues on NT [#1576]. 2644# The addition of a "-n" argument will sort numerically. 2645proc filesort { in out { arg "" } } { 2646 set i [open $in r] 2647 2648 set ilines {} 2649 while { [gets $i line] >= 0 } { 2650 lappend ilines $line 2651 } 2652 2653 if { [string compare $arg "-n"] == 0 } { 2654 set olines [lsort -integer $ilines] 2655 } else { 2656 set olines [lsort $ilines] 2657 } 2658 2659 close $i 2660 2661 set o [open $out w] 2662 foreach line $olines { 2663 puts $o $line 2664 } 2665 2666 close $o 2667} 2668 2669# Print lines up to the nth line of infile out to outfile, inclusive. 2670# The optional beg argument tells us where to start. 2671proc filehead { n infile outfile { beg 0 } } { 2672 set in [open $infile r] 2673 set out [open $outfile w] 2674 2675 # Sed uses 1-based line numbers, and so we do too. 2676 for { set i 1 } { $i < $beg } { incr i } { 2677 if { [gets $in junk] < 0 } { 2678 break 2679 } 2680 } 2681 2682 for { } { $i <= $n } { incr i } { 2683 if { [gets $in line] < 0 } { 2684 break 2685 } 2686 puts $out $line 2687 } 2688 2689 close $in 2690 close $out 2691} 2692 2693# Remove file (this replaces $RM). 2694# Usage: fileremove filenames =~ rm; fileremove -f filenames =~ rm -rf. 2695proc fileremove { args } { 2696 set forceflag "" 2697 foreach a $args { 2698 if { [string first - $a] == 0 } { 2699 # It's a flag. Better be f. 2700 if { [string first f $a] != 1 } { 2701 return -code error "bad flag to fileremove" 2702 } else { 2703 set forceflag "-force" 2704 } 2705 } else { 2706 eval {file delete $forceflag $a} 2707 } 2708 } 2709} 2710 2711proc findfail { args } { 2712 set errstring {} 2713 foreach a $args { 2714 if { [file exists $a] == 0 } { 2715 continue 2716 } 2717 set f [open $a r] 2718 while { [gets $f line] >= 0 } { 2719 if { [string first FAIL $line] == 0 } { 2720 lappend errstring $a:$line 2721 } 2722 } 2723 close $f 2724 } 2725 return $errstring 2726} 2727 2728# Sleep for s seconds. 2729proc tclsleep { s } { 2730 # On Windows, the system time-of-day clock may update as much 2731 # as 55 ms late due to interrupt timing. Don't take any 2732 # chances; sleep extra-long so that when tclsleep 1 returns, 2733 # it's guaranteed to be a new second. 2734 after [expr $s * 1000 + 56] 2735} 2736 2737# Kill a process. 2738proc tclkill { id } { 2739 source ./include.tcl 2740 2741 while { [ catch {exec $KILL -0 $id} ] == 0 } { 2742 catch {exec $KILL -9 $id} 2743 tclsleep 5 2744 } 2745} 2746 2747# Compare two files, a la diff. Returns 1 if non-identical, 0 if identical. 2748proc filecmp { file_a file_b } { 2749 set fda [open $file_a r] 2750 set fdb [open $file_b r] 2751 2752 set nra 0 2753 set nrb 0 2754 2755 # The gets can't be in the while condition because we'll 2756 # get short-circuit evaluated. 2757 while { $nra >= 0 && $nrb >= 0 } { 2758 set nra [gets $fda aline] 2759 set nrb [gets $fdb bline] 2760 2761 if { $nra != $nrb || [string compare $aline $bline] != 0} { 2762 close $fda 2763 close $fdb 2764 return 1 2765 } 2766 } 2767 2768 close $fda 2769 close $fdb 2770 return 0 2771} 2772 2773# Give two SORTED files, one of which is a complete superset of the other, 2774# extract out the unique portions of the superset and put them in 2775# the given outfile. 2776proc fileextract { superset subset outfile } { 2777 set sup [open $superset r] 2778 set sub [open $subset r] 2779 set outf [open $outfile w] 2780 2781 # The gets can't be in the while condition because we'll 2782 # get short-circuit evaluated. 2783 set nrp [gets $sup pline] 2784 set nrb [gets $sub bline] 2785 while { $nrp >= 0 } { 2786 if { $nrp != $nrb || [string compare $pline $bline] != 0} { 2787 puts $outf $pline 2788 } else { 2789 set nrb [gets $sub bline] 2790 } 2791 set nrp [gets $sup pline] 2792 } 2793 2794 close $sup 2795 close $sub 2796 close $outf 2797 return 0 2798} 2799 2800# Verify all .db files in the specified directory. 2801proc verify_dir { {directory $testdir} { pref "" } \ 2802 { noredo 0 } { quiet 0 } { nodump 0 } { cachesize 0 } { unref 1 } } { 2803 global encrypt 2804 global passwd 2805 2806 # If we're doing database verification between tests, we don't 2807 # want to do verification twice without an intervening cleanup--some 2808 # test was skipped. Always verify by default (noredo == 0) so 2809 # that explicit calls to verify_dir during tests don't require 2810 # cleanup commands. 2811 if { $noredo == 1 } { 2812 if { [file exists $directory/NOREVERIFY] == 1 } { 2813 if { $quiet == 0 } { 2814 puts "Skipping verification." 2815 } 2816 return 0 2817 } 2818 set f [open $directory/NOREVERIFY w] 2819 close $f 2820 } 2821 2822 if { [catch {glob $directory/*.db} dbs] != 0 } { 2823 # No files matched 2824 return 0 2825 } 2826 set errfilearg "-errfile /dev/stderr " 2827 set errpfxarg {-errpfx "FAIL: verify" } 2828 set errarg $errfilearg$errpfxarg 2829 set ret 0 2830 2831 # Open an env, so that we have a large enough cache. Pick 2832 # a fairly generous default if we haven't specified something else. 2833 2834 if { $cachesize == 0 } { 2835 set cachesize [expr 1024 * 1024] 2836 } 2837 set encarg "" 2838 if { $encrypt != 0 } { 2839 set encarg "-encryptaes $passwd" 2840 } 2841 2842 set env [eval {berkdb_env -create -private} $encarg \ 2843 {-cachesize [list 0 $cachesize 0]}] 2844 set earg " -env $env $errarg " 2845 2846 # The 'unref' flag means that we report unreferenced pages 2847 # at all times. This is the default behavior. 2848 # If we have a test which leaves unreferenced pages on systems 2849 # where HAVE_FTRUNCATE is not on, then we call verify_dir with 2850 # unref == 0. 2851 set uflag "-unref" 2852 if { $unref == 0 } { 2853 set uflag "" 2854 } 2855 2856 foreach db $dbs { 2857 # Replication's temp db uses a custom comparison function, 2858 # so we can't verify it. 2859 # 2860 if { [file tail $db] == "__db.rep.db" } { 2861 continue 2862 } 2863 if { [catch \ 2864 {eval {berkdb dbverify} $uflag $earg $db} res] != 0 } { 2865 puts $res 2866 puts "FAIL:[timestamp] Verification of $db failed." 2867 set ret 1 2868 continue 2869 } else { 2870 error_check_good verify:$db $res 0 2871 if { $quiet == 0 } { 2872 puts "${pref}Verification of $db succeeded." 2873 } 2874 } 2875 2876 # Skip the dump if it's dangerous to do it. 2877 if { $nodump == 0 } { 2878 if { [catch {eval dumploadtest $db} res] != 0 } { 2879 puts $res 2880 puts "FAIL:[timestamp] Dump/load of $db failed." 2881 set ret 1 2882 continue 2883 } else { 2884 error_check_good dumpload:$db $res 0 2885 if { $quiet == 0 } { 2886 puts \ 2887 "${pref}Dump/load of $db succeeded." 2888 } 2889 } 2890 } 2891 } 2892 2893 error_check_good vrfyenv_close [$env close] 0 2894 2895 return $ret 2896} 2897 2898# Is the database handle in $db a master database containing subdbs? 2899proc check_for_subdbs { db } { 2900 set stat [$db stat] 2901 for { set i 0 } { [string length [lindex $stat $i]] > 0 } { incr i } { 2902 set elem [lindex $stat $i] 2903 if { [string compare [lindex $elem 0] Flags] == 0 } { 2904 # This is the list of flags; look for 2905 # "subdatabases". 2906 if { [is_substr [lindex $elem 1] subdatabases] } { 2907 return 1 2908 } 2909 } 2910 } 2911 return 0 2912} 2913 2914proc db_compare { olddb newdb olddbname newdbname } { 2915 # Walk through olddb and newdb and make sure their contents 2916 # are identical. 2917 set oc [$olddb cursor] 2918 set nc [$newdb cursor] 2919 error_check_good orig_cursor($olddbname) \ 2920 [is_valid_cursor $oc $olddb] TRUE 2921 error_check_good new_cursor($olddbname) \ 2922 [is_valid_cursor $nc $newdb] TRUE 2923 2924 for { set odbt [$oc get -first -nolease] } { [llength $odbt] > 0 } \ 2925 { set odbt [$oc get -next -nolease] } { 2926 set ndbt [$nc get -get_both -nolease \ 2927 [lindex [lindex $odbt 0] 0] [lindex [lindex $odbt 0] 1]] 2928 if { [binary_compare $ndbt $odbt] == 1 } { 2929 error_check_good oc_close [$oc close] 0 2930 error_check_good nc_close [$nc close] 0 2931# puts "FAIL: $odbt does not match $ndbt" 2932 return 1 2933 } 2934 } 2935 2936 for { set ndbt [$nc get -first -nolease] } { [llength $ndbt] > 0 } \ 2937 { set ndbt [$nc get -next -nolease] } { 2938 set odbt [$oc get -get_both -nolease \ 2939 [lindex [lindex $ndbt 0] 0] [lindex [lindex $ndbt 0] 1]] 2940 if { [binary_compare $ndbt $odbt] == 1 } { 2941 error_check_good oc_close [$oc close] 0 2942 error_check_good nc_close [$nc close] 0 2943# puts "FAIL: $odbt does not match $ndbt" 2944 return 1 2945 } 2946 } 2947 2948 error_check_good orig_cursor_close($olddbname) [$oc close] 0 2949 error_check_good new_cursor_close($newdbname) [$nc close] 0 2950 2951 return 0 2952} 2953 2954proc dumploadtest { db } { 2955 global util_path 2956 global encrypt 2957 global passwd 2958 2959 set newdbname $db-dumpload.db 2960 2961 set dbarg "" 2962 set utilflag "" 2963 if { $encrypt != 0 } { 2964 set dbarg "-encryptany $passwd" 2965 set utilflag "-P $passwd" 2966 } 2967 2968 # Dump/load the whole file, including all subdbs. 2969 set rval [catch {eval {exec $util_path/db_dump} $utilflag -k \ 2970 $db | $util_path/db_load $utilflag $newdbname} res] 2971 error_check_good db_dump/db_load($db:$res) $rval 0 2972 2973 # If the old file was empty, there's no new file and we're done. 2974 if { [file exists $newdbname] == 0 } { 2975 return 0 2976 } 2977 2978 # Open original database. 2979 set olddb [eval {berkdb_open -rdonly} $dbarg $db] 2980 error_check_good olddb($db) [is_valid_db $olddb] TRUE 2981 2982 if { [check_for_subdbs $olddb] } { 2983 # If $db has subdatabases, compare each one separately. 2984 set oc [$olddb cursor] 2985 error_check_good orig_cursor($db) \ 2986 [is_valid_cursor $oc $olddb] TRUE 2987 2988 for { set dbt [$oc get -first] } \ 2989 { [llength $dbt] > 0 } \ 2990 { set dbt [$oc get -next] } { 2991 set subdb [lindex [lindex $dbt 0] 0] 2992 2993 set oldsubdb \ 2994 [eval {berkdb_open -rdonly} $dbarg {$db $subdb}] 2995 error_check_good olddb($db) [is_valid_db $oldsubdb] TRUE 2996 2997 # Open the new database. 2998 set newdb \ 2999 [eval {berkdb_open -rdonly} $dbarg {$newdbname $subdb}] 3000 error_check_good newdb($db) [is_valid_db $newdb] TRUE 3001 3002 db_compare $oldsubdb $newdb $db $newdbname 3003 error_check_good new_db_close($db) [$newdb close] 0 3004 error_check_good old_subdb_close($oldsubdb) [$oldsubdb close] 0 3005 } 3006 3007 error_check_good oldcclose [$oc close] 0 3008 } else { 3009 # Open the new database. 3010 set newdb [eval {berkdb_open -rdonly} $dbarg $newdbname] 3011 error_check_good newdb($db) [is_valid_db $newdb] TRUE 3012 3013 db_compare $olddb $newdb $db $newdbname 3014 error_check_good new_db_close($db) [$newdb close] 0 3015 } 3016 3017 error_check_good orig_db_close($db) [$olddb close] 0 3018 eval berkdb dbremove $dbarg $newdbname 3019} 3020 3021# Test regular and aggressive salvage procedures for all databases 3022# in a directory. 3023proc salvage_dir { dir { noredo 0 } { quiet 0 } } { 3024 global util_path 3025 global encrypt 3026 global passwd 3027 3028 # If we're doing salvage testing between tests, don't do it 3029 # twice without an intervening cleanup. 3030 if { $noredo == 1 } { 3031 if { [file exists $dir/NOREDO] == 1 } { 3032 if { $quiet == 0 } { 3033 puts "Skipping salvage testing." 3034 } 3035 return 0 3036 } 3037 set f [open $dir/NOREDO w] 3038 close $f 3039 } 3040 3041 if { [catch {glob $dir/*.db} dbs] != 0 } { 3042 # No files matched 3043 return 0 3044 } 3045 3046 foreach db $dbs { 3047 set dumpfile $db-dump 3048 set sorteddump $db-dump-sorted 3049 set salvagefile $db-salvage 3050 set sortedsalvage $db-salvage-sorted 3051 set aggsalvagefile $db-aggsalvage 3052 3053 set dbarg "" 3054 set utilflag "" 3055 if { $encrypt != 0 } { 3056 set dbarg "-encryptany $passwd" 3057 set utilflag "-P $passwd" 3058 } 3059 3060 # Dump the database with salvage, with aggressive salvage, 3061 # and without salvage. 3062 # 3063 set rval [catch {eval {exec $util_path/db_dump} $utilflag -r \ 3064 -f $salvagefile $db} res] 3065 error_check_good salvage($db:$res) $rval 0 3066 filesort $salvagefile $sortedsalvage 3067 3068 # We can't avoid occasional verify failures in aggressive 3069 # salvage. Make sure it's the expected failure. 3070 set rval [catch {eval {exec $util_path/db_dump} $utilflag -R \ 3071 -f $aggsalvagefile $db} res] 3072 if { $rval == 1 } { 3073#puts "res is $res" 3074 error_check_good agg_failure \ 3075 [is_substr $res "DB_VERIFY_BAD"] 1 3076 } else { 3077 error_check_good aggressive_salvage($db:$res) $rval 0 3078 } 3079 3080 # Queue databases must be dumped with -k to display record 3081 # numbers if we're not in salvage mode. 3082 if { [isqueuedump $salvagefile] == 1 } { 3083 append utilflag " -k " 3084 } 3085 3086 # Discard db_pagesize lines from file dumped with ordinary 3087 # db_dump -- they are omitted from a salvage dump. 3088 set rval [catch {eval {exec $util_path/db_dump} $utilflag \ 3089 -f $dumpfile $db} res] 3090 error_check_good dump($db:$res) $rval 0 3091 filesort $dumpfile $sorteddump 3092 discardline $sorteddump TEMPFILE "db_pagesize=" 3093 file copy -force TEMPFILE $sorteddump 3094 3095 # A non-aggressively salvaged file should match db_dump. 3096 error_check_good compare_dump_and_salvage \ 3097 [filecmp $sorteddump $sortedsalvage] 0 3098 3099 puts "Salvage tests of $db succeeded." 3100 } 3101} 3102 3103# Reads infile, writes to outfile, discarding any line whose 3104# beginning matches the given string. 3105proc discardline { infile outfile discard } { 3106 set fdin [open $infile r] 3107 set fdout [open $outfile w] 3108 3109 while { [gets $fdin str] >= 0 } { 3110 if { [string match $discard* $str] != 1 } { 3111 puts $fdout $str 3112 } 3113 } 3114 close $fdin 3115 close $fdout 3116} 3117 3118# Inspects dumped file for "type=" line. Returns 1 if type=queue. 3119proc isqueuedump { file } { 3120 set fd [open $file r] 3121 3122 while { [gets $fd str] >= 0 } { 3123 if { [string match type=* $str] == 1 } { 3124 if { [string match "type=queue" $str] == 1 } { 3125 close $fd 3126 return 1 3127 } else { 3128 close $fd 3129 return 0 3130 } 3131 } 3132 } 3133 puts "did not find type= line in dumped file" 3134 close $fd 3135} 3136 3137# Generate randomly ordered, guaranteed-unique four-character strings that can 3138# be used to differentiate duplicates without creating duplicate duplicates. 3139# (test031 & test032) randstring_init is required before the first call to 3140# randstring and initializes things for up to $i distinct strings; randstring 3141# gets the next string. 3142proc randstring_init { i } { 3143 global rs_int_list alphabet 3144 3145 # Fail if we can't generate sufficient unique strings. 3146 if { $i > [expr 26 * 26 * 26 * 26] } { 3147 set errstring\ 3148 "Duplicate set too large for random string generator" 3149 puts "FAIL:[timestamp] $errstring" 3150 return -code return $errstring 3151 } 3152 3153 set rs_int_list {} 3154 3155 # generate alphabet array 3156 for { set j 0 } { $j < 26 } { incr j } { 3157 set a($j) [string index $alphabet $j] 3158 } 3159 3160 # Generate a list with $i elements, { aaaa, aaab, ... aaaz, aaba ...} 3161 for { set d1 0 ; set j 0 } { $d1 < 26 && $j < $i } { incr d1 } { 3162 for { set d2 0 } { $d2 < 26 && $j < $i } { incr d2 } { 3163 for { set d3 0 } { $d3 < 26 && $j < $i } { incr d3 } { 3164 for { set d4 0 } { $d4 < 26 && $j < $i } \ 3165 { incr d4 } { 3166 lappend rs_int_list \ 3167 $a($d1)$a($d2)$a($d3)$a($d4) 3168 incr j 3169 } 3170 } 3171 } 3172 } 3173 3174 # Randomize the list. 3175 set rs_int_list [randomize_list $rs_int_list] 3176} 3177 3178# Randomize a list. Returns a randomly-reordered copy of l. 3179proc randomize_list { l } { 3180 set i [llength $l] 3181 3182 for { set j 0 } { $j < $i } { incr j } { 3183 # Pick a random element from $j to the end 3184 set k [berkdb random_int $j [expr $i - 1]] 3185 3186 # Swap it with element $j 3187 set t1 [lindex $l $j] 3188 set t2 [lindex $l $k] 3189 3190 set l [lreplace $l $j $j $t2] 3191 set l [lreplace $l $k $k $t1] 3192 } 3193 3194 return $l 3195} 3196 3197proc randstring {} { 3198 global rs_int_list 3199 3200 if { [info exists rs_int_list] == 0 || [llength $rs_int_list] == 0 } { 3201 set errstring "randstring uninitialized or used too often" 3202 puts "FAIL:[timestamp] $errstring" 3203 return -code return $errstring 3204 } 3205 3206 set item [lindex $rs_int_list 0] 3207 set rs_int_list [lreplace $rs_int_list 0 0] 3208 3209 return $item 3210} 3211 3212# Takes a variable-length arg list, and returns a list containing the list of 3213# the non-hyphenated-flag arguments, followed by a list of each alphanumeric 3214# flag it finds. 3215proc extractflags { args } { 3216 set inflags 1 3217 set flags {} 3218 while { $inflags == 1 } { 3219 set curarg [lindex $args 0] 3220 if { [string first "-" $curarg] == 0 } { 3221 set i 1 3222 while {[string length [set f \ 3223 [string index $curarg $i]]] > 0 } { 3224 incr i 3225 if { [string compare $f "-"] == 0 } { 3226 set inflags 0 3227 break 3228 } else { 3229 lappend flags $f 3230 } 3231 } 3232 set args [lrange $args 1 end] 3233 } else { 3234 set inflags 0 3235 } 3236 } 3237 return [list $args $flags] 3238} 3239 3240# Wrapper for berkdb open, used throughout the test suite so that we can 3241# set an errfile/errpfx as appropriate. 3242proc berkdb_open { args } { 3243 global is_envmethod 3244 3245 if { [info exists is_envmethod] == 0 } { 3246 set is_envmethod 0 3247 } 3248 3249 set errargs {} 3250 if { $is_envmethod == 0 } { 3251 append errargs " -errfile /dev/stderr " 3252 append errargs " -errpfx \\F\\A\\I\\L" 3253 } 3254 3255 eval {berkdb open} $errargs $args 3256} 3257 3258# Version without errpfx/errfile, used when we're expecting a failure. 3259proc berkdb_open_noerr { args } { 3260 eval {berkdb open} $args 3261} 3262 3263# Wrapper for berkdb env, used throughout the test suite so that we can 3264# set an errfile/errpfx as appropriate. 3265proc berkdb_env { args } { 3266 global is_envmethod 3267 3268 if { [info exists is_envmethod] == 0 } { 3269 set is_envmethod 0 3270 } 3271 3272 set errargs {} 3273 if { $is_envmethod == 0 } { 3274 append errargs " -errfile /dev/stderr " 3275 append errargs " -errpfx \\F\\A\\I\\L" 3276 } 3277 3278 eval {berkdb env} $errargs $args 3279} 3280 3281# Version without errpfx/errfile, used when we're expecting a failure. 3282proc berkdb_env_noerr { args } { 3283 eval {berkdb env} $args 3284} 3285 3286proc check_handles { {outf stdout} } { 3287 global ohandles 3288 3289 set handles [berkdb handles] 3290 if {[llength $handles] != [llength $ohandles]} { 3291 puts $outf "WARNING: Open handles during cleanup: $handles" 3292 } 3293 set ohandles $handles 3294} 3295 3296proc open_handles { } { 3297 return [llength [berkdb handles]] 3298} 3299 3300# Will close any database and cursor handles, cursors first. 3301# Ignores other handles, like env handles. 3302proc close_db_handles { } { 3303 set handles [berkdb handles] 3304 set db_handles {} 3305 set cursor_handles {} 3306 3307 # Find the handles we want to process. We can't use 3308 # is_valid_cursor to find cursors because we don't know 3309 # the cursor's parent database handle. 3310 foreach handle $handles { 3311 if {[string range $handle 0 1] == "db"} { 3312 if { [string first "c" $handle] != -1} { 3313 lappend cursor_handles $handle 3314 } else { 3315 lappend db_handles $handle 3316 } 3317 } 3318 } 3319 3320 foreach handle $cursor_handles { 3321 error_check_good cursor_close [$handle close] 0 3322 } 3323 foreach handle $db_handles { 3324 error_check_good db_close [$handle close] 0 3325 } 3326} 3327 3328proc move_file_extent { dir dbfile tag op } { 3329 set curfiles [get_extfiles $dir $dbfile ""] 3330 set tagfiles [get_extfiles $dir $dbfile $tag] 3331 # 3332 # We want to copy or rename only those that have been saved, 3333 # so delete all the current extent files so that we don't 3334 # end up with extra ones we didn't restore from our saved ones. 3335 foreach extfile $curfiles { 3336 file delete -force $extfile 3337 } 3338 foreach extfile $tagfiles { 3339 set i [string last "." $extfile] 3340 incr i 3341 set extnum [string range $extfile $i end] 3342 set dbq [make_ext_filename $dir $dbfile $extnum] 3343 # 3344 # We can either copy or rename 3345 # 3346 file $op -force $extfile $dbq 3347 } 3348} 3349 3350proc copy_extent_file { dir dbfile tag { op copy } } { 3351 set files [get_extfiles $dir $dbfile ""] 3352 foreach extfile $files { 3353 set i [string last "." $extfile] 3354 incr i 3355 set extnum [string range $extfile $i end] 3356 file $op -force $extfile $dir/__dbq.$dbfile.$tag.$extnum 3357 } 3358} 3359 3360proc get_extfiles { dir dbfile tag } { 3361 if { $tag == "" } { 3362 set filepat $dir/__dbq.$dbfile.\[0-9\]* 3363 } else { 3364 set filepat $dir/__dbq.$dbfile.$tag.\[0-9\]* 3365 } 3366 return [glob -nocomplain -- $filepat] 3367} 3368 3369proc make_ext_filename { dir dbfile extnum } { 3370 return $dir/__dbq.$dbfile.$extnum 3371} 3372 3373# All pids for Windows 9X are negative values. When we want to have 3374# unsigned int values, unique to the process, we'll take the absolute 3375# value of the pid. This avoids unsigned/signed mistakes, yet 3376# guarantees uniqueness, since each system has pids that are all 3377# either positive or negative. 3378# 3379proc sanitized_pid { } { 3380 set mypid [pid] 3381 if { $mypid < 0 } { 3382 set mypid [expr - $mypid] 3383 } 3384 puts "PID: [pid] $mypid\n" 3385 return $mypid 3386} 3387 3388# 3389# Extract the page size field from a stat record. Return -1 if 3390# none is found. 3391# 3392proc get_pagesize { stat } { 3393 foreach field $stat { 3394 set title [lindex $field 0] 3395 if {[string compare $title "Page size"] == 0} { 3396 return [lindex $field 1] 3397 } 3398 } 3399 return -1 3400} 3401 3402# Get a globbed list of source files and executables to use as large 3403# data items in overflow page tests. 3404proc get_file_list { {small 0} } { 3405 global is_windows_test 3406 global is_qnx_test 3407 global is_je_test 3408 global src_root 3409 3410 # Skip libraries if we have a debug build. 3411 if { $is_qnx_test || $is_je_test || [is_debug] == 1 } { 3412 set small 1 3413 } 3414 3415 if { $small && $is_windows_test } { 3416 set templist [glob $src_root/*/*.c */env*.obj] 3417 } elseif { $small } { 3418 set templist [glob $src_root/*/*.c ./env*.o] 3419 } elseif { $is_windows_test } { 3420 set templist \ 3421 [glob $src_root/*/*.c */*.obj */libdb??.dll */libdb??d.dll] 3422 } else { 3423 set templist [glob $src_root/*/*.c ./*.o ./.libs/libdb-?.?.s?] 3424 } 3425 3426 # We don't want a huge number of files, but we do want a nice 3427 # variety. If there are more than nfiles files, pick out a list 3428 # by taking every other, or every third, or every nth file. 3429 set filelist {} 3430 set nfiles 500 3431 if { [llength $templist] > $nfiles } { 3432 set skip \ 3433 [expr [llength $templist] / [expr [expr $nfiles / 3] * 2]] 3434 set i $skip 3435 while { $i < [llength $templist] } { 3436 lappend filelist [lindex $templist $i] 3437 incr i $skip 3438 } 3439 } else { 3440 set filelist $templist 3441 } 3442 return $filelist 3443} 3444 3445proc is_cdbenv { env } { 3446 set sys [$env attributes] 3447 if { [lsearch $sys -cdb] != -1 } { 3448 return 1 3449 } else { 3450 return 0 3451 } 3452} 3453 3454proc is_lockenv { env } { 3455 set sys [$env attributes] 3456 if { [lsearch $sys -lock] != -1 } { 3457 return 1 3458 } else { 3459 return 0 3460 } 3461} 3462 3463proc is_logenv { env } { 3464 set sys [$env attributes] 3465 if { [lsearch $sys -log] != -1 } { 3466 return 1 3467 } else { 3468 return 0 3469 } 3470} 3471 3472proc is_mpoolenv { env } { 3473 set sys [$env attributes] 3474 if { [lsearch $sys -mpool] != -1 } { 3475 return 1 3476 } else { 3477 return 0 3478 } 3479} 3480 3481proc is_repenv { env } { 3482 set sys [$env attributes] 3483 if { [lsearch $sys -rep] != -1 } { 3484 return 1 3485 } else { 3486 return 0 3487 } 3488} 3489 3490proc is_rpcenv { env } { 3491 set sys [$env attributes] 3492 if { [lsearch $sys -rpc] != -1 } { 3493 return 1 3494 } else { 3495 return 0 3496 } 3497} 3498 3499proc is_secenv { env } { 3500 set sys [$env attributes] 3501 if { [lsearch $sys -crypto] != -1 } { 3502 return 1 3503 } else { 3504 return 0 3505 } 3506} 3507 3508proc is_txnenv { env } { 3509 set sys [$env attributes] 3510 if { [lsearch $sys -txn] != -1 } { 3511 return 1 3512 } else { 3513 return 0 3514 } 3515} 3516 3517proc get_home { env } { 3518 set sys [$env attributes] 3519 set h [lsearch $sys -home] 3520 if { $h == -1 } { 3521 return NULL 3522 } 3523 incr h 3524 return [lindex $sys $h] 3525} 3526 3527proc reduce_dups { nent ndp } { 3528 upvar $nent nentries 3529 upvar $ndp ndups 3530 3531 # If we are using a txnenv, assume it is using 3532 # the default maximum number of locks, cut back 3533 # so that we don't run out of locks. Reduce 3534 # by 25% until we fit. 3535 # 3536 while { [expr $nentries * $ndups] > 5000 } { 3537 set nentries [expr ($nentries / 4) * 3] 3538 set ndups [expr ($ndups / 4) * 3] 3539 } 3540} 3541 3542proc getstats { statlist field } { 3543 foreach pair $statlist { 3544 set txt [lindex $pair 0] 3545 if { [string equal $txt $field] == 1 } { 3546 return [lindex $pair 1] 3547 } 3548 } 3549 return -1 3550} 3551 3552# Return the value for a particular field in a set of statistics. 3553# Works for regular db stat as well as env stats (log_stat, 3554# lock_stat, txn_stat, rep_stat, etc.). 3555proc stat_field { handle which_stat field } { 3556 set stat [$handle $which_stat] 3557 return [getstats $stat $field ] 3558} 3559 3560proc big_endian { } { 3561 global tcl_platform 3562 set e $tcl_platform(byteOrder) 3563 if { [string compare $e littleEndian] == 0 } { 3564 return 0 3565 } elseif { [string compare $e bigEndian] == 0 } { 3566 return 1 3567 } else { 3568 error "FAIL: Unknown endianness $e" 3569 } 3570} 3571 3572# Check if this is a debug build. Use 'string equal' so we 3573# don't get fooled by debug_rop and debug_wop. 3574proc is_debug { } { 3575 3576 set conf [berkdb getconfig] 3577 foreach item $conf { 3578 if { [string equal $item "debug"] } { 3579 return 1 3580 } 3581 } 3582 return 0 3583} 3584 3585proc adjust_logargs { logtype {lbufsize 0} } { 3586 if { $logtype == "in-memory" } { 3587 if { $lbufsize == 0 } { 3588 set lbuf [expr 1 * [expr 1024 * 1024]] 3589 set logargs " -log_inmemory -log_buffer $lbuf " 3590 } else { 3591 set logargs " -log_inmemory -log_buffer $lbufsize " 3592 } 3593 } elseif { $logtype == "on-disk" } { 3594 set logargs "" 3595 } else { 3596 error "FAIL: unrecognized log type $logtype" 3597 } 3598 return $logargs 3599} 3600 3601proc adjust_txnargs { logtype } { 3602 if { $logtype == "in-memory" } { 3603 set txnargs " -txn " 3604 } elseif { $logtype == "on-disk" } { 3605 set txnargs " -txn nosync " 3606 } else { 3607 error "FAIL: unrecognized log type $logtype" 3608 } 3609 return $txnargs 3610} 3611 3612proc get_logfile { env where } { 3613 # Open a log cursor. 3614 set m_logc [$env log_cursor] 3615 error_check_good m_logc [is_valid_logc $m_logc $env] TRUE 3616 3617 # Check that we're in the expected virtual log file. 3618 if { $where == "first" } { 3619 set rec [$m_logc get -first] 3620 } else { 3621 set rec [$m_logc get -last] 3622 } 3623 error_check_good cursor_close [$m_logc close] 0 3624 set lsn [lindex $rec 0] 3625 set log [lindex $lsn 0] 3626 return $log 3627} 3628 3629# Determine whether logs are in-mem or on-disk. 3630# This requires the existence of logs to work correctly. 3631proc check_log_location { env } { 3632 if { [catch {get_logfile $env first} res] } { 3633 puts "FAIL: env $env not configured for logging" 3634 } 3635 set inmemory [$env log_get_config inmemory] 3636 3637 set env_home [get_home $env] 3638 set logfiles [glob -nocomplain $env_home/log.*] 3639 if { $inmemory == 1 } { 3640 error_check_good no_logs_on_disk [llength $logfiles] 0 3641 } else { 3642 error_check_bad logs_on_disk [llength $logfiles] 0 3643 } 3644} 3645 3646proc find_valid_methods { test } { 3647 global checking_valid_methods 3648 global valid_methods 3649 3650 # To find valid methods, call the test with checking_valid_methods 3651 # on. It doesn't matter what method we use for this call, so we 3652 # arbitrarily pick btree. 3653 # 3654 set checking_valid_methods 1 3655 set test_methods [$test btree] 3656 set checking_valid_methods 0 3657 if { $test_methods == "ALL" } { 3658 return $valid_methods 3659 } else { 3660 return $test_methods 3661 } 3662} 3663