1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1999-2009 Oracle. All rights reserved. 4# 5# $Id$ 6 7source ./include.tcl 8 9global upgrade_dir 10# set upgrade_dir "$test_path/upgrade_test" 11set upgrade_dir "$test_path/upgrade/databases" 12 13global gen_upgrade 14set gen_upgrade 0 15global gen_dump 16set gen_dump 0 17global gen_chksum 18set gen_chksum 0 19global gen_upgrade_log 20set gen_upgrade_log 0 21 22global upgrade_dir 23global upgrade_be 24global upgrade_method 25global upgrade_name 26 27proc upgrade { { archived_test_loc "DEFAULT" } } { 28 source ./include.tcl 29 global test_names 30 global upgrade_dir 31 global tcl_platform 32 global saved_logvers 33 34 set saved_upgrade_dir $upgrade_dir 35 36 # Identify endianness of the machine running upgrade. 37 if { [big_endian] == 1 } { 38 set myendianness be 39 } else { 40 set myendianness le 41 } 42 set e $tcl_platform(byteOrder) 43 44 if { [file exists $archived_test_loc/logversion] == 1 } { 45 set fd [open $archived_test_loc/logversion r] 46 set saved_logvers [read $fd] 47 close $fd 48 } else { 49 puts "Old log version number must be available \ 50 in $archived_test_loc/logversion" 51 return 52 } 53 54 fileremove -f UPGRADE.OUT 55 set o [open UPGRADE.OUT a] 56 57 puts -nonewline $o "Upgrade test started at: " 58 puts $o [clock format [clock seconds] -format "%H:%M %D"] 59 puts $o [berkdb version -string] 60 puts $o "Testing $e files" 61 62 puts -nonewline "Upgrade test started at: " 63 puts [clock format [clock seconds] -format "%H:%M %D"] 64 puts [berkdb version -string] 65 puts "Testing $e files" 66 67 if { $archived_test_loc == "DEFAULT" } { 68 puts $o "Using default archived databases in $upgrade_dir." 69 puts "Using default archived databases in $upgrade_dir." 70 } else { 71 set upgrade_dir $archived_test_loc 72 puts $o "Using archived databases in $upgrade_dir." 73 puts "Using archived databases in $upgrade_dir." 74 } 75 close $o 76 77 foreach version [glob $upgrade_dir/*] { 78 if { [string first CVS $version] != -1 } { continue } 79 regexp \[^\/\]*$ $version version 80 81 # Test only files where the endianness of the db matches 82 # the endianness of the test platform. These are the 83 # meaningful tests: 84 # 1. File generated on le, tested on le 85 # 2. File generated on be, tested on be 86 # 3. Byte-swapped file generated on le, tested on be 87 # 4. Byte-swapped file generated on be, tested on le 88 # 89 set dbendianness [string range $version end-1 end] 90 if { [string compare $myendianness $dbendianness] != 0 } { 91 puts "Skipping test of $version \ 92 on $myendianness platform." 93 } else { 94 set release [string trim $version -lbe] 95 set o [open UPGRADE.OUT a] 96 puts $o "Files created on release $release" 97 close $o 98 puts "Files created on release $release" 99 100 foreach method [glob $upgrade_dir/$version/*] { 101 regexp \[^\/\]*$ $method method 102 set o [open UPGRADE.OUT a] 103 puts $o "\nTesting $method files" 104 close $o 105 puts "\tTesting $method files" 106 107 foreach file [lsort -dictionary \ 108 [glob -nocomplain \ 109 $upgrade_dir/$version/$method/*]] { 110 regexp (\[^\/\]*)\.tar\.gz$ \ 111 $file dummy name 112 113 cleanup $testdir NULL 1 114 set curdir [pwd] 115 cd $testdir 116 set tarfd [open "|tar xf -" w] 117 cd $curdir 118 119 catch {exec gunzip -c \ 120 "$upgrade_dir/$version/$method/$name.tar.gz" \ 121 >@$tarfd} 122 close $tarfd 123 124 set f [open $testdir/$name.tcldump \ 125 {RDWR CREAT}] 126 close $f 127 128 # We exec a separate tclsh for each 129 # separate subtest to keep the 130 # testing process from consuming a 131 # tremendous amount of memory. 132 # 133 # First we test the .db files. 134 if { [file exists \ 135 $testdir/$name-$myendianness.db] } { 136 if { [catch {exec $tclsh_path \ 137 << "source \ 138 $test_path/test.tcl;\ 139 _upgrade_test $testdir \ 140 $version $method $name \ 141 $myendianness" >>& \ 142 UPGRADE.OUT } message] } { 143 set o [open \ 144 UPGRADE.OUT a] 145 puts $o "FAIL: $message" 146 close $o 147 } 148 if { [catch {exec $tclsh_path\ 149 << "source \ 150 $test_path/test.tcl;\ 151 _db_load_test $testdir \ 152 $version $method $name" >>&\ 153 UPGRADE.OUT } message] } { 154 set o [open \ 155 UPGRADE.OUT a] 156 puts $o "FAIL: $message" 157 close $o 158 } 159 } 160 # Then we test log files. 161 if { [file exists \ 162 $testdir/$name.prlog] } { 163 if { [catch {exec $tclsh_path \ 164 << "source \ 165 $test_path/test.tcl;\ 166 global saved_logvers;\ 167 set saved_logvers \ 168 $saved_logvers;\ 169 _log_test $testdir \ 170 $release $method \ 171 $name" >>& \ 172 UPGRADE.OUT } message] } { 173 set o [open \ 174 UPGRADE.OUT a] 175 puts $o "FAIL: $message" 176 close $o 177 } 178 } 179 180 # Then we test any .dmp files. Move 181 # the saved file to the current working 182 # directory. Run the test locally. 183 # Compare the dumps; they should match. 184 if { [file exists $testdir/$name.dmp] } { 185 file rename -force \ 186 $testdir/$name.dmp $name.dmp 187 188 foreach test $test_names(plat) { 189 eval $test $method 190 } 191 192 # Discard lines that can differ. 193 discardline $name.dmp \ 194 TEMPFILE "db_pagesize=" 195 file copy -force \ 196 TEMPFILE $name.dmp 197 discardline $testdir/$test.dmp \ 198 TEMPFILE "db_pagesize=" 199 file copy -force \ 200 TEMPFILE $testdir/$test.dmp 201 202 error_check_good compare_dump \ 203 [filecmp $name.dmp \ 204 $testdir/$test.dmp] 0 205 206 fileremove $name.dmp 207 } 208 } 209 } 210 } 211 } 212 set upgrade_dir $saved_upgrade_dir 213 214 set o [open UPGRADE.OUT a] 215 puts -nonewline $o "Completed at: " 216 puts $o [clock format [clock seconds] -format "%H:%M %D"] 217 close $o 218 219 puts -nonewline "Completed at: " 220 puts [clock format [clock seconds] -format "%H:%M %D"] 221 222 # Don't provide a return value. 223 return 224} 225 226proc _upgrade_test { temp_dir version method file endianness } { 227 source include.tcl 228 global errorInfo 229 global passwd 230 global encrypt 231 232 puts "Upgrade: $version $method $file $endianness" 233 234 # Check whether we're working with an encrypted file. 235 if { [string match c-* $file] } { 236 set encrypt 1 237 } 238 239 # Open the database prior to upgrading. If it fails, 240 # it should fail with the DB_OLDVERSION message. 241 set encargs "" 242 set upgradeargs "" 243 if { $encrypt == 1 } { 244 set encargs " -encryptany $passwd " 245 set upgradeargs " -P $passwd " 246 } 247 if { [catch \ 248 { set db [eval {berkdb open} $encargs \ 249 $temp_dir/$file-$endianness.db] } res] } { 250 error_check_good old_version [is_substr $res DB_OLDVERSION] 1 251 } else { 252 error_check_good db_close [$db close] 0 253 } 254 255 # Now upgrade the database. 256 set ret [catch {eval exec {$util_path/db_upgrade} $upgradeargs \ 257 "$temp_dir/$file-$endianness.db" } message] 258 error_check_good dbupgrade $ret 0 259 260 error_check_good dbupgrade_verify [verify_dir $temp_dir "" 0 0 1] 0 261 262 upgrade_dump "$temp_dir/$file-$endianness.db" "$temp_dir/temp.dump" 263 264 error_check_good "Upgrade diff.$endianness: $version $method $file" \ 265 [filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0 266} 267 268proc _db_load_test { temp_dir version method file } { 269 source include.tcl 270 global errorInfo 271 272 puts "Db_load: $version $method $file" 273 274 set ret [catch \ 275 {exec $util_path/db_load -f "$temp_dir/$file.dump" \ 276 "$temp_dir/upgrade.db"} message] 277 error_check_good \ 278 "Upgrade load: $version $method $file $message" $ret 0 279 280 upgrade_dump "$temp_dir/upgrade.db" "$temp_dir/temp.dump" 281 282 error_check_good "Upgrade diff.1.1: $version $method $file" \ 283 [filecmp "$temp_dir/$file.tcldump" "$temp_dir/temp.dump"] 0 284} 285 286proc _log_test { temp_dir release method file } { 287 source ./include.tcl 288 global saved_logvers 289 global passwd 290 puts "Check log file: $temp_dir $release $method $file" 291 292 # Get log version number of current system 293 set env [berkdb_env -create -log -home $testdir] 294 error_check_good is_valid_env [is_valid_env $env] TRUE 295 set current_logvers [get_log_vers $env] 296 error_check_good env_close [$env close] 0 297 error_check_good env_remove [berkdb envremove -home $testdir] 0 298 299 # Rename recd001-x-log.000000000n to log.000000000n. 300 set logfiles [glob -nocomplain $temp_dir/*log.0*] 301 foreach logfile $logfiles { 302 set logname [string replace $logfile 0 \ 303 [string last - $logfile]] 304 file rename -force $logfile $temp_dir/$logname 305 } 306 307 # Use db_printlog to dump the logs. If the current log file 308 # version is greater than the saved log file version, the log 309 # files are expected to be unreadable. If the log file is 310 # readable, check that the current printlog dump matches the 311 # archived printlog. 312 # 313 set ret [catch {exec $util_path/db_printlog -h $temp_dir \ 314 > $temp_dir/logs.prlog} message] 315 if { [is_substr $message "magic number"] } { 316 # The failure is probably due to encryption, try 317 # crypto printlog. 318 set ret [catch {exec $util_path/db_printlog -h $temp_dir \ 319 -P $passwd > $temp_dir/logs.prlog} message] 320 if { $ret == 1 } { 321 # If the failure is because of a historic 322 # log version, that's okay. 323 if { $current_logvers <= $saved_logvers } { 324 puts "db_printlog failed: $message" 325 } 326 } 327 } 328 329 # Log versions prior to 8 can only be read by their own version. 330 # Log versions of 8 or greater are readable by Berkeley DB 4.5 331 # or greater, but the output of printlog does not match unless 332 # the versions are identical. 333 # 334 # As of Berkeley DB 4.8, we'll only try to read back to log 335 # version 11, which came out with 4.4. Backwards compatibility 336 # now only extends back to 4.4 because of page changes. 337 # 338 set logoldver 11 339 if { $current_logvers > $saved_logvers &&\ 340 $saved_logvers < $logoldver } { 341 error_check_good historic_log_version \ 342 [is_substr $message "historic log version"] 1 343 } elseif { $current_logvers > $saved_logvers } { 344 error_check_good db_printlog:$message $ret 0 345 } elseif { $current_logvers == $saved_logvers } { 346 error_check_good db_printlog:$message $ret 0 347 # Compare logs.prlog and $file.prlog (should match) 348 error_check_good "Compare printlogs" [filecmp \ 349 "$temp_dir/logs.prlog" "$temp_dir/$file.prlog"] 0 350 } elseif { $current_logvers < $saved_logvers } { 351 puts -nonewline "FAIL: current log version $current_logvers " 352 puts "cannot be less than saved log version $save_logvers." 353 } 354} 355 356proc gen_upgrade { dir { save_crypto 1 } { save_non_crypto 1 } } { 357 global gen_upgrade 358 global gen_upgrade_log 359 global gen_chksum 360 global gen_dump 361 global upgrade_dir 362 global upgrade_be 363 global upgrade_method 364 global upgrade_name 365 global valid_methods 366 global test_names 367 global parms 368 global encrypt 369 global passwd 370 source ./include.tcl 371 372 set upgrade_dir $dir 373 env_cleanup $testdir 374 375 fileremove -f GENERATE.OUT 376 set o [open GENERATE.OUT a] 377 378 puts -nonewline $o "Generating upgrade files. Started at: " 379 puts $o [clock format [clock seconds] -format "%H:%M %D"] 380 puts $o [berkdb version -string] 381 382 puts -nonewline "Generating upgrade files. Started at: " 383 puts [clock format [clock seconds] -format "%H:%M %D"] 384 puts [berkdb version -string] 385 386 close $o 387 388 # Create a file that contains the log version number. 389 # If necessary, create the directory to contain the file. 390 set env [berkdb_env -create -log -home $testdir] 391 error_check_good is_valid_env [is_valid_env $env] TRUE 392 393 if { [file exists $dir] == 0 } { 394 file mkdir $dir 395 } 396 set lv [open $dir/logversion w] 397 puts $lv [get_log_vers $env] 398 close $lv 399 400 error_check_good env_close [$env close] 0 401 402 # Generate test databases for each access method and endianness. 403 foreach method $valid_methods { 404 set o [open GENERATE.OUT a] 405 puts $o "\nGenerating $method files" 406 close $o 407 puts "\tGenerating $method files" 408 set upgrade_method $method 409 410 # We piggyback testing of dumped sequence files on upgrade 411 # testing because this is the only place that we ship files 412 # from one machine to another. Create files for both 413 # endiannesses, because who knows what platform we'll 414 # be testing on. 415 416 set gen_dump 1 417 foreach test $test_names(plat) { 418 set upgrade_name $test 419 foreach upgrade_be { 0 1 } { 420 eval $test $method 421 cleanup $testdir NULL 422 } 423 } 424 set gen_dump 0 425 426#set test_names(test) "" 427 set gen_upgrade 1 428 foreach test $test_names(test) { 429 if { [info exists parms($test)] != 1 } { 430 continue 431 } 432 433 set o [open GENERATE.OUT a] 434 puts $o "\t\tGenerating files for $test" 435 close $o 436 puts "\t\tGenerating files for $test" 437 438 if { $save_non_crypto == 1 } { 439 set encrypt 0 440 foreach upgrade_be { 0 1 } { 441 set upgrade_name $test 442 if [catch {exec $tclsh_path \ 443 << "source $test_path/test.tcl;\ 444 global gen_upgrade upgrade_be;\ 445 global upgrade_method upgrade_name;\ 446 global encrypt;\ 447 set encrypt $encrypt;\ 448 set gen_upgrade 1;\ 449 set upgrade_be $upgrade_be;\ 450 set upgrade_method $upgrade_method;\ 451 set upgrade_name $upgrade_name;\ 452 run_method -$method $test" \ 453 >>& GENERATE.OUT} res] { 454 puts "FAIL: run_method \ 455 $test $method" 456 } 457 cleanup $testdir NULL 1 458 } 459 # Save checksummed files for only one test. 460 # Checksumming should work in all or no cases. 461 set gen_chksum 1 462 foreach upgrade_be { 0 1 } { 463 set upgrade_name $test 464 if { $test == "test001" } { 465 if { [catch {exec $tclsh_path \ 466 << "source $test_path/test.tcl;\ 467 global gen_upgrade;\ 468 global upgrade_be;\ 469 global upgrade_method;\ 470 global upgrade_name;\ 471 global encrypt gen_chksum;\ 472 set encrypt $encrypt;\ 473 set gen_upgrade 1;\ 474 set gen_chksum 1;\ 475 set upgrade_be $upgrade_be;\ 476 set upgrade_method \ 477 $upgrade_method;\ 478 set upgrade_name \ 479 $upgrade_name;\ 480 run_method -$method $test \ 481 0 1 stdout -chksum" \ 482 >>& GENERATE.OUT} res] } { 483 puts "FAIL: run_method \ 484 $test $method \ 485 -chksum: $res" 486 } 487 cleanup $testdir NULL 1 488 } 489 } 490 set gen_chksum 0 491 } 492 # Save encrypted db's only of native endianness. 493 # Encrypted files are not portable across endianness. 494 if { $save_crypto == 1 } { 495 set upgrade_be [big_endian] 496 set encrypt 1 497 set upgrade_name $test 498 if [catch {exec $tclsh_path \ 499 << "source $test_path/test.tcl;\ 500 global gen_upgrade upgrade_be;\ 501 global upgrade_method upgrade_name;\ 502 global encrypt passwd;\ 503 set encrypt $encrypt;\ 504 set passwd $passwd;\ 505 set gen_upgrade 1;\ 506 set upgrade_be $upgrade_be;\ 507 set upgrade_method $upgrade_method;\ 508 set upgrade_name $upgrade_name;\ 509 run_secmethod $method $test" \ 510 >>& GENERATE.OUT} res] { 511 puts "FAIL: run_secmethod \ 512 $test $method" 513 } 514 cleanup $testdir NULL 1 515 } 516 } 517 set gen_upgrade 0 518 } 519 520 # Set upgrade_be to the native value so log files go to the 521 # right place. 522 set upgrade_be [big_endian] 523 524 # Generate log files. 525 set o [open GENERATE.OUT a] 526 puts $o "\tGenerating log files" 527 close $o 528 puts "\tGenerating log files" 529 530 set gen_upgrade_log 1 531 # Pass the global variables and their values to the new tclsh. 532 if { $save_non_crypto == 1 } { 533 set encrypt 0 534 if [catch {exec $tclsh_path << "source $test_path/test.tcl;\ 535 global gen_upgrade_log upgrade_be upgrade_dir;\ 536 global encrypt;\ 537 set encrypt $encrypt;\ 538 set gen_upgrade_log $gen_upgrade_log; \ 539 set upgrade_be $upgrade_be;\ 540 set upgrade_dir $upgrade_dir;\ 541 run_recds" >>& GENERATE.OUT} res] { 542 puts "FAIL: run_recds: $res" 543 } 544 } 545 if { $save_crypto == 1 } { 546 set encrypt 1 547 if [catch {exec $tclsh_path << "source $test_path/test.tcl;\ 548 global gen_upgrade_log upgrade_be upgrade_dir;\ 549 global encrypt;\ 550 set encrypt $encrypt;\ 551 set gen_upgrade_log $gen_upgrade_log; \ 552 set upgrade_be $upgrade_be;\ 553 set upgrade_dir $upgrade_dir;\ 554 run_recds " >>& GENERATE.OUT} res] { 555 puts "FAIL: run_recds with crypto: $res" 556 } 557 } 558 set gen_upgrade_log 0 559 560 set o [open GENERATE.OUT a] 561 puts -nonewline $o "Completed at: " 562 puts $o [clock format [clock seconds] -format "%H:%M %D"] 563 puts -nonewline "Completed at: " 564 puts [clock format [clock seconds] -format "%H:%M %D"] 565 close $o 566} 567 568proc save_upgrade_files { dir } { 569 global upgrade_dir 570 global upgrade_be 571 global upgrade_method 572 global upgrade_name 573 global gen_upgrade 574 global gen_upgrade_log 575 global gen_dump 576 global encrypt 577 global gen_chksum 578 global passwd 579 source ./include.tcl 580 581 set vers [berkdb version] 582 set maj [lindex $vers 0] 583 set min [lindex $vers 1] 584 585 # Is this machine big or little endian? We want to mark 586 # the test directories appropriately, since testing 587 # little-endian databases generated by a big-endian machine, 588 # and/or vice versa, is interesting. 589 if { [big_endian] } { 590 set myendianness be 591 } else { 592 set myendianness le 593 } 594 595 if { $upgrade_be == 1 } { 596 set version_dir "$myendianness-$maj.${min}be" 597 set en be 598 } else { 599 set version_dir "$myendianness-$maj.${min}le" 600 set en le 601 } 602 603 set dest $upgrade_dir/$version_dir/$upgrade_method 604 exec mkdir -p $dest 605 606 if { $gen_upgrade == 1 } { 607 # Save db files from test001 - testxxx. 608 set dbfiles [glob -nocomplain $dir/*.db] 609 set dumpflag "" 610 # Encrypted files are identified by the prefix "c-". 611 if { $encrypt == 1 } { 612 set upgrade_name c-$upgrade_name 613 set dumpflag " -P $passwd " 614 } 615 # Checksummed files are identified by the prefix "s-". 616 if { $gen_chksum == 1 } { 617 set upgrade_name s-$upgrade_name 618 } 619 foreach dbfile $dbfiles { 620 set basename [string range $dbfile \ 621 [expr [string length $dir] + 1] end-3] 622 623 set newbasename $upgrade_name-$basename 624 625 # db_dump file 626 if { [catch {eval exec $util_path/db_dump -k $dumpflag \ 627 $dbfile > $dir/$newbasename.dump} res] } { 628 puts "FAIL: $res" 629 } 630 631 # tcl_dump file 632 upgrade_dump $dbfile $dir/$newbasename.tcldump 633 634 # Rename dbfile and any dbq files. 635 file rename $dbfile $dir/$newbasename-$en.db 636 foreach dbq \ 637 [glob -nocomplain $dir/__dbq.$basename.db.*] { 638 set s [string length $dir/__dbq.] 639 set newname [string replace $dbq $s \ 640 [expr [string length $basename] + $s - 1] \ 641 $newbasename-$en] 642 file rename $dbq $newname 643 } 644 set cwd [pwd] 645 cd $dir 646 catch {eval exec tar -cvf $dest/$newbasename.tar \ 647 [glob $newbasename* __dbq.$newbasename-$en.db.*]} 648 catch {exec gzip -9v $dest/$newbasename.tar} res 649 cd $cwd 650 } 651 } 652 653 if { $gen_upgrade_log == 1 } { 654 # Save log files from recd tests. 655 set logfiles [glob -nocomplain $dir/log.*] 656 if { [llength $logfiles] > 0 } { 657 # More than one log.0000000001 file may be produced 658 # per recd test, so we generate unique names: 659 # recd001-0-log.0000000001, recd001-1-log.0000000001, 660 # and so on. 661 # We may also have log.0000000001, log.0000000002, 662 # and so on, and they will all be dumped together 663 # by db_printlog. 664 set count 0 665 while { [file exists \ 666 $dest/$upgrade_name-$count-log.tar.gz] \ 667 == 1 } { 668 incr count 669 } 670 set newname $upgrade_name-$count-log 671 672 # Run db_printlog on all the log files 673 if {[catch {exec $util_path/db_printlog -h $dir > \ 674 $dir/$newname.prlog} res] != 0} { 675 puts "Regular printlog failed, try encryption" 676 eval {exec $util_path/db_printlog} -h $dir \ 677 -P $passwd > $dir/$newname.prlog 678 } 679 680 # Rename each log file so we can identify which 681 # recd test created it. 682 foreach logfile $logfiles { 683 set lognum [string range $logfile \ 684 end-9 end] 685 file rename $logfile $dir/$newname.$lognum 686 } 687 688 set cwd [pwd] 689 cd $dir 690 691 catch {eval exec tar -cvf $dest/$newname.tar \ 692 [glob $newname*]} 693 catch {exec gzip -9v $dest/$newname.tar} 694 cd $cwd 695 } 696 } 697 698 if { $gen_dump == 1 } { 699 # Save dump files. We require that the files have 700 # been created with the extension .dmp. 701 set dumpfiles [glob -nocomplain $dir/*.dmp] 702 703 foreach dumpfile $dumpfiles { 704 set basename [string range $dumpfile \ 705 [expr [string length $dir] + 1] end-4] 706 707 set newbasename $upgrade_name-$basename 708 709 # Rename dumpfile. 710 file rename $dumpfile $dir/$newbasename.dmp 711 712 set cwd [pwd] 713 cd $dir 714 catch {eval exec tar -cvf $dest/$newbasename.tar \ 715 [glob $newbasename.dmp]} 716 catch {exec gzip -9v $dest/$newbasename.tar} res 717 cd $cwd 718 } 719 } 720} 721 722proc upgrade_dump { database file {stripnulls 0} } { 723 global errorInfo 724 global encrypt 725 global passwd 726 727 set encargs "" 728 if { $encrypt == 1 } { 729 set encargs " -encryptany $passwd " 730 } 731 set db [eval {berkdb open} -rdonly $encargs $database] 732 set dbc [$db cursor] 733 734 set f [open $file w+] 735 fconfigure $f -encoding binary -translation binary 736 737 # 738 # Get a sorted list of keys 739 # 740 set key_list "" 741 set pair [$dbc get -first] 742 743 while { 1 } { 744 if { [llength $pair] == 0 } { 745 break 746 } 747 set k [lindex [lindex $pair 0] 0] 748 lappend key_list $k 749 set pair [$dbc get -next] 750 } 751 752 # Discard duplicated keys; we now have a key for each 753 # duplicate, not each unique key, and we don't want to get each 754 # duplicate multiple times when we iterate over key_list. 755 set uniq_keys "" 756 foreach key $key_list { 757 if { [info exists existence_list($key)] == 0 } { 758 lappend uniq_keys $key 759 } 760 set existence_list($key) 1 761 } 762 set key_list $uniq_keys 763 764 set key_list [lsort -command _comp $key_list] 765 766 # 767 # Get the data for each key 768 # 769 set i 0 770 foreach key $key_list { 771 set pair [$dbc get -set $key] 772 if { $stripnulls != 0 } { 773 # the Tcl interface to db versions before 3.X 774 # added nulls at the end of all keys and data, so 775 # we provide functionality to strip that out. 776 set key [strip_null $key] 777 } 778 set data_list {} 779 catch { while { [llength $pair] != 0 } { 780 set data [lindex [lindex $pair 0] 1] 781 if { $stripnulls != 0 } { 782 set data [strip_null $data] 783 } 784 lappend data_list [list $data] 785 set pair [$dbc get -nextdup] 786 } } 787 #lsort -command _comp data_list 788 set data_list [lsort -command _comp $data_list] 789 puts -nonewline $f [binary format i [string length $key]] 790 puts -nonewline $f $key 791 puts -nonewline $f [binary format i [llength $data_list]] 792 for { set j 0 } { $j < [llength $data_list] } { incr j } { 793 puts -nonewline $f [binary format i [string length \ 794 [concat [lindex $data_list $j]]]] 795 puts -nonewline $f [concat [lindex $data_list $j]] 796 } 797 if { [llength $data_list] == 0 } { 798 puts "WARNING: zero-length data list" 799 } 800 incr i 801 } 802 803 close $f 804 error_check_good upgrade_dump_c_close [$dbc close] 0 805 error_check_good upgrade_dump_db_close [$db close] 0 806} 807 808proc _comp { a b } { 809 if { 0 } { 810 # XXX 811 set a [strip_null [concat $a]] 812 set b [strip_null [concat $b]] 813 #return [expr [concat $a] < [concat $b]] 814 } else { 815 set an [string first "\0" $a] 816 set bn [string first "\0" $b] 817 818 if { $an != -1 } { 819 set a [string range $a 0 [expr $an - 1]] 820 } 821 if { $bn != -1 } { 822 set b [string range $b 0 [expr $bn - 1]] 823 } 824 } 825 #puts "$a $b" 826 return [string compare $a $b] 827} 828 829proc strip_null { str } { 830 set len [string length $str] 831 set last [expr $len - 1] 832 833 set termchar [string range $str $last $last] 834 if { [string compare $termchar \0] == 0 } { 835 set ret [string range $str 0 [expr $last - 1]] 836 } else { 837 set ret $str 838 } 839 840 return $ret 841} 842 843proc get_log_vers { env } { 844 set stat [$env log_stat] 845 foreach pair $stat { 846 set msg [lindex $pair 0] 847 set val [lindex $pair 1] 848 if { $msg == "Log file Version" } { 849 return $val 850 } 851 } 852 puts "FAIL: Log file Version not found in log_stat" 853 return 0 854} 855 856