1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: dbm.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST dbm 8# TEST Historic DBM interface test. Use the first 1000 entries from the 9# TEST dictionary. Insert each with self as key and data; retrieve each. 10# TEST After all are entered, retrieve all; compare output to original. 11# TEST Then reopen the file, re-retrieve everything. Finally, delete 12# TEST everything. 13proc dbm { { nentries 1000 } } { 14 source ./include.tcl 15 16 puts "DBM interfaces test: $nentries" 17 18 # Create the database and open the dictionary 19 set testfile $testdir/dbmtest 20 set t1 $testdir/t1 21 set t2 $testdir/t2 22 set t3 $testdir/t3 23 cleanup $testdir NULL 24 25 error_check_good dbminit [berkdb dbminit $testfile] 0 26 set did [open $dict] 27 28 set flags "" 29 set txn "" 30 set count 0 31 set skippednullkey 0 32 33 puts "\tDBM.a: put/get loop" 34 # Here is the loop where we put and get each key/data pair 35 while { [gets $did str] != -1 && $count < $nentries } { 36 # DBM can't handle zero-length keys 37 if { [string length $str] == 0 } { 38 set skippednullkey 1 39 continue 40 } 41 42 set ret [berkdb store $str $str] 43 error_check_good dbm_store $ret 0 44 45 set d [berkdb fetch $str] 46 error_check_good dbm_fetch $d $str 47 incr count 48 } 49 close $did 50 51 # Now we will get each key from the DB and compare the results 52 # to the original. 53 puts "\tDBM.b: dump file" 54 set oid [open $t1 w] 55 for { set key [berkdb firstkey] } { $key != -1 } {\ 56 set key [berkdb nextkey $key] } { 57 puts $oid $key 58 set d [berkdb fetch $key] 59 error_check_good dbm_refetch $d $key 60 } 61 62 # If we had to skip a zero-length key, juggle things to cover up 63 # this fact in the dump. 64 if { $skippednullkey == 1 } { 65 puts $oid "" 66 incr nentries 1 67 } 68 69 close $oid 70 71 # Now compare the keys to see if they match the dictionary (or ints) 72 set q q 73 filehead $nentries $dict $t3 74 filesort $t3 $t2 75 filesort $t1 $t3 76 77 error_check_good DBM:diff($t3,$t2) \ 78 [filecmp $t3 $t2] 0 79 80 puts "\tDBM.c: close, open, and dump file" 81 82 # Now, reopen the file and run the last test again. 83 error_check_good dbminit2 [berkdb dbminit $testfile] 0 84 set oid [open $t1 w] 85 86 for { set key [berkdb firstkey] } { $key != -1 } {\ 87 set key [berkdb nextkey $key] } { 88 puts $oid $key 89 set d [berkdb fetch $key] 90 error_check_good dbm_refetch $d $key 91 } 92 if { $skippednullkey == 1 } { 93 puts $oid "" 94 } 95 close $oid 96 97 # Now compare the keys to see if they match the dictionary (or ints) 98 filesort $t1 $t3 99 100 error_check_good DBM:diff($t2,$t3) \ 101 [filecmp $t2 $t3] 0 102 103 # Now, reopen the file and delete each entry 104 puts "\tDBM.d: sequential scan and delete" 105 106 error_check_good dbminit3 [berkdb dbminit $testfile] 0 107 set oid [open $t1 w] 108 109 for { set key [berkdb firstkey] } { $key != -1 } {\ 110 set key [berkdb nextkey $key] } { 111 puts $oid $key 112 set ret [berkdb delete $key] 113 error_check_good dbm_delete $ret 0 114 } 115 if { $skippednullkey == 1 } { 116 puts $oid "" 117 } 118 close $oid 119 120 # Now compare the keys to see if they match the dictionary (or ints) 121 filesort $t1 $t3 122 123 error_check_good DBM:diff($t2,$t3) \ 124 [filecmp $t2 $t3] 0 125 126 error_check_good "dbm_close" [berkdb dbmclose] 0 127} 128