1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: test014.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test014 8# TEST Exercise partial puts on short data 9# TEST Run 5 combinations of numbers of characters to replace, 10# TEST and number of times to increase the size by. 11# TEST 12# TEST Partial put test, small data, replacing with same size. The data set 13# TEST consists of the first nentries of the dictionary. We will insert them 14# TEST (and retrieve them) as we do in test 1 (equal key/data pairs). Then 15# TEST we'll try to perform partial puts of some characters at the beginning, 16# TEST some at the end, and some at the middle. 17proc test014 { method {nentries 10000} args } { 18 set fixed 0 19 set args [convert_args $method $args] 20 21 if { [is_fixed_length $method] == 1 } { 22 set fixed 1 23 } 24 25 puts "Test014: $method ($args) $nentries equal key/data pairs, put test" 26 27 # flagp indicates whether this is a postpend or a 28 # normal partial put 29 set flagp 0 30 31 eval {test014_body $method $flagp 1 1 $nentries} $args 32 eval {test014_body $method $flagp 1 4 $nentries} $args 33 eval {test014_body $method $flagp 2 4 $nentries} $args 34 eval {test014_body $method $flagp 1 128 $nentries} $args 35 eval {test014_body $method $flagp 2 16 $nentries} $args 36 if { $fixed == 0 } { 37 eval {test014_body $method $flagp 0 1 $nentries} $args 38 eval {test014_body $method $flagp 0 4 $nentries} $args 39 eval {test014_body $method $flagp 0 128 $nentries} $args 40 41 # POST-PENDS : 42 # partial put data after the end of the existent record 43 # chars: number of empty spaces that will be padded with null 44 # increase: is the length of the str to be appended (after pad) 45 # 46 set flagp 1 47 eval {test014_body $method $flagp 1 1 $nentries} $args 48 eval {test014_body $method $flagp 4 1 $nentries} $args 49 eval {test014_body $method $flagp 128 1 $nentries} $args 50 eval {test014_body $method $flagp 1 4 $nentries} $args 51 eval {test014_body $method $flagp 1 128 $nentries} $args 52 } 53 puts "Test014 complete." 54} 55 56proc test014_body { method flagp chars increase {nentries 10000} args } { 57 source ./include.tcl 58 59 set omethod [convert_method $method] 60 61 if { [is_fixed_length $method] == 1 && $chars != $increase } { 62 puts "Test014: $method: skipping replace\ 63 $chars chars with string $increase times larger." 64 return 65 } 66 67 if { $flagp == 1} { 68 puts "Test014: Postpending string of len $increase with \ 69 gap $chars." 70 } else { 71 puts "Test014: Replace $chars chars with string \ 72 $increase times larger" 73 } 74 75 # Create the database and open the dictionary 76 set txnenv 0 77 set eindex [lsearch -exact $args "-env"] 78 # 79 # If we are using an env, then testfile should just be the db name. 80 # Otherwise it is the test directory and the name. 81 if { $eindex == -1 } { 82 set testfile $testdir/test014.db 83 set env NULL 84 } else { 85 set testfile test014.db 86 incr eindex 87 set env [lindex $args $eindex] 88 set txnenv [is_txnenv $env] 89 if { $txnenv == 1 } { 90 append args " -auto_commit " 91 # 92 # If we are using txns and running with the 93 # default, set the default down a bit. 94 # 95 if { $nentries == 10000 } { 96 set nentries 100 97 } 98 } 99 set testdir [get_home $env] 100 } 101 set t1 $testdir/t1 102 set t2 $testdir/t2 103 set t3 $testdir/t3 104 cleanup $testdir $env 105 106 set db [eval {berkdb_open \ 107 -create -mode 0644} $args {$omethod $testfile}] 108 error_check_good dbopen [is_valid_db $db] TRUE 109 110 set gflags "" 111 set pflags "" 112 set txn "" 113 set count 0 114 115 if { [is_record_based $method] == 1 } { 116 append gflags " -recno" 117 } 118 119 puts "\tTest014.a: put/get loop" 120 # Here is the loop where we put and get each key/data pair 121 # We will do the initial put and then three Partial Puts 122 # for the beginning, middle and end of the string. 123 set did [open $dict] 124 while { [gets $did str] != -1 && $count < $nentries } { 125 if { [is_record_based $method] == 1 } { 126 set key [expr $count + 1] 127 } else { 128 set key $str 129 } 130 if { $flagp == 1 } { 131 # this is for postpend only 132 global dvals 133 134 # initial put 135 if { $txnenv == 1 } { 136 set t [$env txn] 137 error_check_good txn [is_valid_txn $t $env] TRUE 138 set txn "-txn $t" 139 } 140 set ret [eval {$db put} $txn {$key $str}] 141 if { $txnenv == 1 } { 142 error_check_good txn [$t commit] 0 143 } 144 error_check_good dbput $ret 0 145 146 set offset [string length $str] 147 148 # increase is the actual number of new bytes 149 # to be postpended (besides the null padding) 150 set data [repeat "P" $increase] 151 152 # chars is the amount of padding in between 153 # the old data and the new 154 set len [expr $offset + $chars + $increase] 155 set dvals($key) [binary format \ 156 a[set offset]x[set chars]a[set increase] \ 157 $str $data] 158 set offset [expr $offset + $chars] 159 if { $txnenv == 1 } { 160 set t [$env txn] 161 error_check_good txn [is_valid_txn $t $env] TRUE 162 set txn "-txn $t" 163 } 164 set ret [eval {$db put -partial [list $offset 0]} \ 165 $txn {$key $data}] 166 error_check_good dbput:post $ret 0 167 if { $txnenv == 1 } { 168 error_check_good txn [$t commit] 0 169 } 170 } else { 171 if { $txnenv == 1 } { 172 set t [$env txn] 173 error_check_good txn [is_valid_txn $t $env] TRUE 174 set txn "-txn $t" 175 } 176 partial_put $method $db $txn \ 177 $gflags $key $str $chars $increase 178 if { $txnenv == 1 } { 179 error_check_good txn [$t commit] 0 180 } 181 } 182 incr count 183 } 184 close $did 185 186 # Now make sure that everything looks OK 187 puts "\tTest014.b: check entire file contents" 188 if { $txnenv == 1 } { 189 set t [$env txn] 190 error_check_good txn [is_valid_txn $t $env] TRUE 191 set txn "-txn $t" 192 } 193 dump_file $db $txn $t1 test014.check 194 if { $txnenv == 1 } { 195 error_check_good txn [$t commit] 0 196 } 197 error_check_good db_close [$db close] 0 198 199 # Now compare the keys to see if they match the dictionary (or ints) 200 if { [is_record_based $method] == 1 } { 201 set oid [open $t2 w] 202 for {set i 1} {$i <= $nentries} {set i [incr i]} { 203 puts $oid $i 204 } 205 close $oid 206 file rename -force $t1 $t3 207 } else { 208 set q q 209 filehead $nentries $dict $t3 210 filesort $t3 $t2 211 filesort $t1 $t3 212 } 213 214 error_check_good \ 215 Test014:diff($t3,$t2) [filecmp $t3 $t2] 0 216 217 puts "\tTest014.c: close, open, and dump file" 218 # Now, reopen the file and run the last test again. 219 open_and_dump_file $testfile $env \ 220 $t1 test014.check dump_file_direction "-first" "-next" 221 222 if { [string compare $omethod "-recno"] != 0 } { 223 filesort $t2 $t3 224 file rename -force $t3 $t2 225 filesort $t1 $t3 226 } 227 228 error_check_good \ 229 Test014:diff($t3,$t2) [filecmp $t3 $t2] 0 230 # Now, reopen the file and run the last test again in the 231 # reverse direction. 232 puts "\tTest014.d: close, open, and dump file in reverse direction" 233 open_and_dump_file $testfile $env $t1 \ 234 test014.check dump_file_direction "-last" "-prev" 235 236 if { [string compare $omethod "-recno"] != 0 } { 237 filesort $t2 $t3 238 file rename -force $t3 $t2 239 filesort $t1 $t3 240 } 241 242 error_check_good \ 243 Test014:diff($t3,$t2) [filecmp $t3 $t2] 0 244} 245 246# Check function for test014; keys and data are identical 247proc test014.check { key data } { 248 global dvals 249 250 error_check_good key"$key"_exists [info exists dvals($key)] 1 251 error_check_good "data mismatch for key $key" $data $dvals($key) 252} 253