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