1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: test093.tcl,v 12.10 2008/01/23 15:14:55 carol Exp $ 6# 7# TEST test093 8# TEST Test set_bt_compare (btree key comparison function) and 9# TEST set_h_compare (hash key comparison function). 10# TEST 11# TEST Open a database with a comparison function specified, 12# TEST populate, and close, saving a list with that key order as 13# TEST we do so. Reopen and read in the keys, saving in another 14# TEST list; the keys should be in the order specified by the 15# TEST comparison function. Sort the original saved list of keys 16# TEST using the comparison function, and verify that it matches 17# TEST the keys as read out of the database. 18 19proc test093 { method {nentries 10000} {tnum "093"} args} { 20 source ./include.tcl 21 22 set dbargs [convert_args $method $args] 23 set omethod [convert_method $method] 24 25 if { [is_btree $method] == 1 } { 26 set compflag -btcompare 27 } elseif { [is_hash $method] == 1 } { 28 set compflag -hashcompare 29 } else { 30 puts "Test$tnum: skipping for method $method." 31 return 32 } 33 34 set txnenv 0 35 set eindex [lsearch -exact $dbargs "-env"] 36 if { $eindex != -1 } { 37 incr eindex 38 set env [lindex $dbargs $eindex] 39 set envflags [$env get_open_flags] 40 41 # We can't run this test for the -thread option because 42 # the comparison function requires the ability to allocate 43 # memory at the DBT level and our Tcl interface does not 44 # offer that. 45 if { [lsearch -exact $envflags "-thread"] != -1 } { 46 puts "Skipping Test$tnum for threaded env" 47 return 48 } 49 set rpcenv [is_rpcenv $env] 50 if { $rpcenv == 1 } { 51 puts "Test$tnum: skipping for RPC" 52 return 53 } 54 set txnenv [is_txnenv $env] 55 if { $txnenv == 1 } { 56 append dbargs " -auto_commit " 57 if { $nentries == 10000 } { 58 set nentries 100 59 } 60 } 61 set testdir [get_home $env] 62 cleanup $testdir $env 63 } else { 64 set env NULL 65 } 66 67 puts "Test$tnum: $method ($args) $nentries entries using $compflag" 68 69 test093_run $omethod $dbargs $nentries $tnum \ 70 $compflag test093_cmp1 test093_sort1 71 test093_runbig $omethod $dbargs $nentries $tnum \ 72 $compflag test093_cmp1 test093_sort1 73 test093_run $omethod $dbargs $nentries $tnum \ 74 $compflag test093_cmp2 test093_sort2 75 76 # Don't bother running the second, really slow, comparison 77 # function on test093_runbig (file contents). 78 79 # Clean up so verification doesn't fail. (There's currently 80 # no way to specify a comparison function to berkdb dbverify.) 81 if { $env != "NULL" } { 82 set testdir [get_home $env] 83 } 84 cleanup $testdir $env 85} 86 87proc test093_run { method dbargs nentries tnum compflag cmpfunc sortfunc } { 88 source ./include.tcl 89 global btvals 90 global btvalsck 91 92 # If we are using an env, then testfile should just be the db name. 93 # Otherwise it is the test directory and the name. 94 set eindex [lsearch -exact $dbargs "-env"] 95 set txnenv 0 96 if { $eindex == -1 } { 97 set testfile $testdir/test$tnum.db 98 set env NULL 99 } else { 100 set testfile test$tnum.db 101 incr eindex 102 set env [lindex $dbargs $eindex] 103 set txnenv [is_txnenv $env] 104 set testdir [get_home $env] 105 } 106 cleanup $testdir $env 107 108 set db [eval {berkdb_open $compflag $cmpfunc \ 109 -create -mode 0644} $method $dbargs $testfile] 110 error_check_good dbopen [is_valid_db $db] TRUE 111 set did [open $dict] 112 113 set t1 $testdir/t1 114 set t2 $testdir/t2 115 set t3 $testdir/t3 116 set txn "" 117 118 # Use btvals to save the order of the keys as they are 119 # written to the database. The btvalsck variable will contain 120 # the values as sorted by the comparison function. 121 set btvals {} 122 set btvalsck {} 123 124 puts "\tTest$tnum.a: put/get loop" 125 # Here is the loop where we put and get each key/data pair 126 set count 0 127 while { [gets $did str] != -1 && $count < $nentries } { 128 set key $str 129 set str [reverse $str] 130 if { $txnenv == 1 } { 131 set t [$env txn] 132 error_check_good txn [is_valid_txn $t $env] TRUE 133 set txn "-txn $t" 134 } 135 set ret [eval \ 136 {$db put} $txn {$key [chop_data $method $str]}] 137 error_check_good put $ret 0 138 if { $txnenv == 1 } { 139 error_check_good txn [$t commit] 0 140 } 141 142 lappend btvals $key 143 144 set ret [eval {$db get $key}] 145 error_check_good \ 146 get $ret [list [list $key [pad_data $method $str]]] 147 148 incr count 149 } 150 close $did 151 152 # Now we will get each key from the DB and compare the results 153 # to the original. 154 puts "\tTest$tnum.b: dump file" 155 if { $txnenv == 1 } { 156 set t [$env txn] 157 error_check_good txn [is_valid_txn $t $env] TRUE 158 set txn "-txn $t" 159 } 160 dump_file $db $txn $t1 test093_check 161 if { $txnenv == 1 } { 162 error_check_good txn [$t commit] 0 163 } 164 error_check_good db_close [$db close] 0 165 166 # Now compare the keys to see if they match the dictionary (or ints) 167 filehead $nentries $dict $t2 168 filesort $t2 $t3 169 file rename -force $t3 $t2 170 filesort $t1 $t3 171 172 error_check_good Test$tnum:diff($t3,$t2) \ 173 [filecmp $t3 $t2] 0 174 175 puts "\tTest$tnum.c: dump file in order" 176 # Now, reopen the file and run the last test again. 177 # We open it here, ourselves, because all uses of the db 178 # need to have the correct comparison func set. Then 179 # call dump_file_direction directly. 180 set btvalsck {} 181 set db [eval {berkdb_open $compflag $cmpfunc -rdonly} \ 182 $dbargs $method $testfile] 183 error_check_good dbopen [is_valid_db $db] TRUE 184 if { $txnenv == 1 } { 185 set t [$env txn] 186 error_check_good txn [is_valid_txn $t $env] TRUE 187 set txn "-txn $t" 188 } 189 dump_file_direction $db $txn $t1 test093_check "-first" "-next" 190 if { $txnenv == 1 } { 191 error_check_good txn [$t commit] 0 192 } 193 error_check_good db_close [$db close] 0 194 195 if { [is_hash $method] == 1 } { 196 return 197 } 198 199 # We need to sort btvals according to the comparison function. 200 # Once that is done, btvalsck and btvals should be the same. 201 puts "\tTest$tnum.d: check file order" 202 203 $sortfunc 204 205 error_check_good btvals:len [llength $btvals] [llength $btvalsck] 206 for {set i 0} {$i < $nentries} {incr i} { 207 error_check_good vals:$i [lindex $btvals $i] \ 208 [lindex $btvalsck $i] 209 } 210} 211 212proc test093_runbig { method dbargs nentries tnum compflag cmpfunc sortfunc } { 213 source ./include.tcl 214 global btvals 215 global btvalsck 216 217 # Create the database and open the dictionary 218 set eindex [lsearch -exact $dbargs "-env"] 219 # 220 # If we are using an env, then testfile should just be the db name. 221 # Otherwise it is the test directory and the name. 222 set txnenv 0 223 if { $eindex == -1 } { 224 set testfile $testdir/test$tnum.db 225 set env NULL 226 } else { 227 set testfile test$tnum.db 228 incr eindex 229 set env [lindex $dbargs $eindex] 230 set txnenv [is_txnenv $env] 231 set testdir [get_home $env] 232 } 233 cleanup $testdir $env 234 235 set db [eval {berkdb_open $compflag $cmpfunc \ 236 -create -mode 0644} $method $dbargs $testfile] 237 error_check_good dbopen [is_valid_db $db] TRUE 238 239 set t1 $testdir/t1 240 set t2 $testdir/t2 241 set t3 $testdir/t3 242 set t4 $testdir/t4 243 set t5 $testdir/t5 244 set txn "" 245 set btvals {} 246 set btvalsck {} 247 puts "\tTest$tnum.e:\ 248 big key put/get loop key=filecontents data=filename" 249 250 # Here is the loop where we put and get each key/data pair 251 set file_list [get_file_list 1] 252 253 set count 0 254 foreach f $file_list { 255 set fid [open $f r] 256 fconfigure $fid -translation binary 257 set key [read $fid] 258 close $fid 259 260 set key $f$key 261 262 set fcopy [open $t5 w] 263 fconfigure $fcopy -translation binary 264 puts -nonewline $fcopy $key 265 close $fcopy 266 267 if { $txnenv == 1 } { 268 set t [$env txn] 269 error_check_good txn [is_valid_txn $t $env] TRUE 270 set txn "-txn $t" 271 } 272 set ret [eval {$db put} $txn {$key \ 273 [chop_data $method $f]}] 274 error_check_good put_file $ret 0 275 if { $txnenv == 1 } { 276 error_check_good txn [$t commit] 0 277 } 278 279 lappend btvals $key 280 281 # Should really catch errors 282 set fid [open $t4 w] 283 fconfigure $fid -translation binary 284 if [catch {eval {$db get} {$key}} data] { 285 puts -nonewline $fid $data 286 } else { 287 # Data looks like {{key data}} 288 set key [lindex [lindex $data 0] 0] 289 puts -nonewline $fid $key 290 } 291 close $fid 292 error_check_good \ 293 Test093:diff($t5,$t4) [filecmp $t5 $t4] 0 294 295 incr count 296 } 297 298 # Now we will get each key from the DB and compare the results 299 # to the original. 300 puts "\tTest$tnum.f: big dump file" 301 if { $txnenv == 1 } { 302 set t [$env txn] 303 error_check_good txn [is_valid_txn $t $env] TRUE 304 set txn "-txn $t" 305 } 306 dump_file $db $txn $t1 test093_checkbig 307 if { $txnenv == 1 } { 308 error_check_good txn [$t commit] 0 309 } 310 error_check_good db_close [$db close] 0 311 312 puts "\tTest$tnum.g: dump file in order" 313 # Now, reopen the file and run the last test again. 314 # We open it here, ourselves, because all uses of the db 315 # need to have the correct comparison func set. Then 316 # call dump_file_direction directly. 317 318 set btvalsck {} 319 set db [eval {berkdb_open $compflag $cmpfunc -rdonly} \ 320 $dbargs $method $testfile] 321 error_check_good dbopen [is_valid_db $db] TRUE 322 if { $txnenv == 1 } { 323 set t [$env txn] 324 error_check_good txn [is_valid_txn $t $env] TRUE 325 set txn "-txn $t" 326 } 327 dump_file_direction $db $txn $t1 test093_checkbig "-first" "-next" 328 if { $txnenv == 1 } { 329 error_check_good txn [$t commit] 0 330 } 331 error_check_good db_close [$db close] 0 332 333 if { [is_hash $method] == 1 } { 334 return 335 } 336 337 # We need to sort btvals according to the comparison function. 338 # Once that is done, btvalsck and btvals should be the same. 339 puts "\tTest$tnum.h: check file order" 340 341 $sortfunc 342 error_check_good btvals:len [llength $btvals] [llength $btvalsck] 343 344 set end [llength $btvals] 345 for {set i 0} {$i < $end} {incr i} { 346 error_check_good vals:$i [lindex $btvals $i] \ 347 [lindex $btvalsck $i] 348 } 349} 350 351# Simple bt comparison. 352proc test093_cmp1 { a b } { 353 return [string compare $b $a] 354} 355 356# Simple bt sorting. 357proc test093_sort1 {} { 358 global btvals 359 # 360 # This one is easy, just sort in reverse. 361 # 362 set btvals [lsort -decreasing $btvals] 363} 364 365proc test093_cmp2 { a b } { 366 set arev [reverse $a] 367 set brev [reverse $b] 368 return [string compare $arev $brev] 369} 370 371proc test093_sort2 {} { 372 global btvals 373 374 # We have to reverse them, then sorts them. 375 # Then reverse them back to real words. 376 set rbtvals {} 377 foreach i $btvals { 378 lappend rbtvals [reverse $i] 379 } 380 set rbtvals [lsort -increasing $rbtvals] 381 set newbtvals {} 382 foreach i $rbtvals { 383 lappend newbtvals [reverse $i] 384 } 385 set btvals $newbtvals 386} 387 388# Check function for test093; keys and data are identical 389proc test093_check { key data } { 390 global btvalsck 391 392 error_check_good "key/data mismatch" $data [reverse $key] 393 lappend btvalsck $key 394} 395 396# Check function for test093 big keys; 397proc test093_checkbig { key data } { 398 source ./include.tcl 399 global btvalsck 400 401 set fid [open $data r] 402 fconfigure $fid -translation binary 403 set cont [read $fid] 404 close $fid 405 error_check_good "key/data mismatch" $key $data$cont 406 lappend btvalsck $key 407} 408 409