1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: test015.tcl,v 12.7 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test015 8# TEST Partial put test 9# TEST Partial put test where the key does not initially exist. 10proc test015 { method {nentries 7500} { start 0 } args } { 11 global fixed_len testdir 12 set orig_tdir $testdir 13 14 set low_range 50 15 set mid_range 100 16 set high_range 1000 17 18 if { [is_fixed_length $method] } { 19 set low_range [expr $fixed_len/2 - 2] 20 set mid_range [expr $fixed_len/2] 21 set high_range $fixed_len 22 } 23 24 set t_table { 25 { 1 { 1 1 1 } } 26 { 2 { 1 1 5 } } 27 { 3 { 1 1 $low_range } } 28 { 4 { 1 $mid_range 1 } } 29 { 5 { $mid_range $high_range 5 } } 30 { 6 { 1 $mid_range $low_range } } 31 } 32 33 puts "Test015: \ 34 $method ($args) $nentries equal key/data pairs, partial put test" 35 test015_init 36 if { $start == 0 } { 37 set start { 1 2 3 4 5 6 } 38 } 39 foreach entry $t_table { 40 set this [lindex $entry 0] 41 if { [lsearch $start $this] == -1 } { 42 continue 43 } 44 puts -nonewline "$this: " 45 eval [concat test015_body $method [lindex $entry 1] \ 46 $nentries $args] 47 set eindex [lsearch -exact $args "-env"] 48 if { $eindex != -1 } { 49 incr eindex 50 set env [lindex $args $eindex] 51 set testdir [get_home $env] 52 } 53 54 error_check_good verify [verify_dir $testdir "\tTest015.e: "] 0 55 } 56 set testdir $orig_tdir 57} 58 59proc test015_init { } { 60 global rand_init 61 62 berkdb srand $rand_init 63} 64 65proc test015_body { method off_low off_hi rcount {nentries 10000} args } { 66 global dvals 67 global fixed_len 68 global testdir 69 source ./include.tcl 70 71 set args [convert_args $method $args] 72 set omethod [convert_method $method] 73 74 set orig_tdir $testdir 75 set checkfunc test015.check 76 77 if { [is_fixed_length $method] && \ 78 [string compare $omethod "-recno"] == 0} { 79 # is fixed recno method 80 set checkfunc test015.check 81 } 82 83 puts "Put $rcount strings random offsets between $off_low and $off_hi" 84 85 # Create the database and open the dictionary 86 set txnenv 0 87 set eindex [lsearch -exact $args "-env"] 88 # 89 # If we are using an env, then testfile should just be the db name. 90 # Otherwise it is the test directory and the name. 91 if { $eindex == -1 } { 92 set testfile $testdir/test015.db 93 set env NULL 94 } else { 95 set testfile test015.db 96 incr eindex 97 set env [lindex $args $eindex] 98 set txnenv [is_txnenv $env] 99 if { $txnenv == 1 } { 100 append args " -auto_commit " 101 # 102 # If we are using txns and running with the 103 # default, set the default down a bit. 104 # 105 if { $nentries > 5000 } { 106 set nentries 100 107 } 108 } 109 set testdir [get_home $env] 110 } 111 set retdir $testdir 112 set t1 $testdir/t1 113 set t2 $testdir/t2 114 set t3 $testdir/t3 115 cleanup $testdir $env 116 117 set db [eval {berkdb_open \ 118 -create -mode 0644} $args {$omethod $testfile}] 119 error_check_good dbopen [is_valid_db $db] TRUE 120 121 set pflags "" 122 set gflags "" 123 set txn "" 124 set count 0 125 126 puts "\tTest015.a: put/get loop for $nentries entries" 127 128 # Here is the loop where we put and get each key/data pair 129 # Each put is a partial put of a record that does not exist. 130 set did [open $dict] 131 while { [gets $did str] != -1 && $count < $nentries } { 132 if { [is_record_based $method] == 1 } { 133 if { [string length $str] > $fixed_len } { 134 continue 135 } 136 set key [expr $count + 1] 137 } else { 138 set key $str 139 } 140 141 if { 0 } { 142 set data [replicate $str $rcount] 143 set off [ berkdb random_int $off_low $off_hi ] 144 set offn [expr $off + 1] 145 if { [is_fixed_length $method] && \ 146 [expr [string length $data] + $off] >= $fixed_len} { 147 set data [string range $data 0 [expr $fixed_len-$offn]] 148 } 149 set dvals($key) [partial_shift $data $off right] 150 } else { 151 set data [chop_data $method [replicate $str $rcount]] 152 153 # This is a hack. In DB we will store the records with 154 # some padding, but these will get lost if we just return 155 # them in TCL. As a result, we're going to have to hack 156 # get to check for 0 padding and return a list consisting 157 # of the number of 0's and the actual data. 158 set off [ berkdb random_int $off_low $off_hi ] 159 160 # There is no string concatenation function in Tcl 161 # (although there is one in TclX), so we have to resort 162 # to this hack. Ugh. 163 set slen [string length $data] 164 if {[is_fixed_length $method] && \ 165 $slen > $fixed_len - $off} { 166 set $slen [expr $fixed_len - $off] 167 } 168 set a "a" 169 set dvals($key) [pad_data \ 170 $method [eval "binary format x$off$a$slen" {$data}]] 171 } 172 if {[is_fixed_length $method] && \ 173 [string length $data] > ($fixed_len - $off)} { 174 set slen [expr $fixed_len - $off] 175 set data [eval "binary format a$slen" {$data}] 176 } 177 if { $txnenv == 1 } { 178 set t [$env txn] 179 error_check_good txn [is_valid_txn $t $env] TRUE 180 set txn "-txn $t" 181 } 182 set ret [eval {$db put} $txn \ 183 {-partial [list $off [string length $data]] $key $data}] 184 error_check_good put $ret 0 185 if { $txnenv == 1 } { 186 error_check_good txn [$t commit] 0 187 } 188 189 incr count 190 } 191 close $did 192 193 # Now make sure that everything looks OK 194 puts "\tTest015.b: check entire file contents" 195 if { $txnenv == 1 } { 196 set t [$env txn] 197 error_check_good txn [is_valid_txn $t $env] TRUE 198 set txn "-txn $t" 199 } 200 dump_file $db $txn $t1 $checkfunc 201 if { $txnenv == 1 } { 202 error_check_good txn [$t commit] 0 203 } 204 error_check_good db_close [$db close] 0 205 206 # Now compare the keys to see if they match the dictionary (or ints) 207 if { [is_record_based $method] == 1 } { 208 set oid [open $t2 w] 209 for {set i 1} {$i <= $nentries} {set i [incr i]} { 210 puts $oid $i 211 } 212 close $oid 213 filesort $t2 $t3 214 file rename -force $t3 $t2 215 filesort $t1 $t3 216 } else { 217 set q q 218 filehead $nentries $dict $t3 219 filesort $t3 $t2 220 filesort $t1 $t3 221 } 222 223 error_check_good Test015:diff($t3,$t2) \ 224 [filecmp $t3 $t2] 0 225 226 puts "\tTest015.c: close, open, and dump file" 227 # Now, reopen the file and run the last test again. 228 open_and_dump_file $testfile $env $t1 \ 229 $checkfunc dump_file_direction "-first" "-next" 230 231 if { [string compare $omethod "-recno"] != 0 } { 232 filesort $t1 $t3 233 } 234 235 error_check_good Test015:diff($t3,$t2) \ 236 [filecmp $t3 $t2] 0 237 238 # Now, reopen the file and run the last test again in the 239 # reverse direction. 240 puts "\tTest015.d: close, open, and dump file in reverse direction" 241 open_and_dump_file $testfile $env $t1 \ 242 $checkfunc dump_file_direction "-last" "-prev" 243 244 if { [string compare $omethod "-recno"] != 0 } { 245 filesort $t1 $t3 246 } 247 248 error_check_good Test015:diff($t3,$t2) \ 249 [filecmp $t3 $t2] 0 250 251 unset dvals 252 set testdir $orig_tdir 253} 254 255# Check function for test015; keys and data are identical 256proc test015.check { key data } { 257 global dvals 258 259 error_check_good key"$key"_exists [info exists dvals($key)] 1 260 binary scan $data "c[string length $data]" a 261 binary scan $dvals($key) "c[string length $dvals($key)]" b 262 error_check_good "mismatch on padding for key $key" $a $b 263} 264 265proc test015.fixed.check { key data } { 266 global dvals 267 global fixed_len 268 269 error_check_good key"$key"_exists [info exists dvals($key)] 1 270 if { [string length $data] > $fixed_len } { 271 error_check_bad \ 272 "data length:[string length $data] \ 273 for fixed:$fixed_len" 1 1 274 } 275 puts "$data : $dvals($key)" 276 error_check_good compare_data($data,$dvals($key) \ 277 $dvals($key) $data 278} 279