1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996-2009 Oracle. All rights reserved. 4# 5# $Id$ 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 general verification (without the custom comparison 80 # function) doesn't fail. 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 # We'll need any encryption args separated from the db args 93 # so we can pass them to dbverify. 94 set encargs "" 95 set dbargs [split_encargs $dbargs encargs] 96 97 # If we are using an env, then testfile should just be the db name. 98 # Otherwise it is the test directory and the name. 99 set eindex [lsearch -exact $dbargs "-env"] 100 set txnenv 0 101 if { $eindex == -1 } { 102 set testfile $testdir/test$tnum.db 103 set env NULL 104 set envargs "" 105 } else { 106 set testfile test$tnum.db 107 incr eindex 108 set env [lindex $dbargs $eindex] 109 set envargs " -env $env " 110 set txnenv [is_txnenv $env] 111 set testdir [get_home $env] 112 } 113 cleanup $testdir $env 114 115 set db [eval {berkdb_open $compflag $cmpfunc \ 116 -create -mode 0644} $method $encargs $dbargs $testfile] 117 error_check_good dbopen [is_valid_db $db] TRUE 118 set did [open $dict] 119 120 set t1 $testdir/t1 121 set t2 $testdir/t2 122 set t3 $testdir/t3 123 set txn "" 124 125 # Use btvals to save the order of the keys as they are 126 # written to the database. The btvalsck variable will contain 127 # the values as sorted by the comparison function. 128 set btvals {} 129 set btvalsck {} 130 131 puts "\tTest$tnum.a: put/get loop" 132 # Here is the loop where we put and get each key/data pair 133 set count 0 134 while { [gets $did str] != -1 && $count < $nentries } { 135 set key $str 136 set str [reverse $str] 137 if { $txnenv == 1 } { 138 set t [$env txn] 139 error_check_good txn [is_valid_txn $t $env] TRUE 140 set txn "-txn $t" 141 } 142 set ret [eval \ 143 {$db put} $txn {$key [chop_data $method $str]}] 144 error_check_good put $ret 0 145 if { $txnenv == 1 } { 146 error_check_good txn [$t commit] 0 147 } 148 149 lappend btvals $key 150 151 set ret [eval {$db get $key}] 152 error_check_good \ 153 get $ret [list [list $key [pad_data $method $str]]] 154 155 incr count 156 } 157 close $did 158 159 # Now we will get each key from the DB and compare the results 160 # to the original. 161 puts "\tTest$tnum.b: dump file" 162 if { $txnenv == 1 } { 163 set t [$env txn] 164 error_check_good txn [is_valid_txn $t $env] TRUE 165 set txn "-txn $t" 166 } 167 dump_file $db $txn $t1 test093_check 168 if { $txnenv == 1 } { 169 error_check_good txn [$t commit] 0 170 } 171 error_check_good db_close [$db close] 0 172 173 # Run verify to check the internal structure and order. 174 if { [catch {eval {berkdb dbverify} $compflag $cmpfunc\ 175 $envargs $encargs {$testfile}} res] } { 176 error "FAIL: Verification failed with $res" 177 } 178 179 # Now compare the keys to see if they match the dictionary (or ints) 180 filehead $nentries $dict $t2 181 filesort $t2 $t3 182 file rename -force $t3 $t2 183 filesort $t1 $t3 184 185 error_check_good Test$tnum:diff($t3,$t2) \ 186 [filecmp $t3 $t2] 0 187 188 puts "\tTest$tnum.c: dump file in order" 189 # Now, reopen the file and run the last test again. 190 # We open it here, ourselves, because all uses of the db 191 # need to have the correct comparison func set. Then 192 # call dump_file_direction directly. 193 set btvalsck {} 194 set db [eval {berkdb_open $compflag $cmpfunc -rdonly} \ 195 $dbargs $encargs $method $testfile] 196 error_check_good dbopen [is_valid_db $db] TRUE 197 if { $txnenv == 1 } { 198 set t [$env txn] 199 error_check_good txn [is_valid_txn $t $env] TRUE 200 set txn "-txn $t" 201 } 202 dump_file_direction $db $txn $t1 test093_check "-first" "-next" 203 if { $txnenv == 1 } { 204 error_check_good txn [$t commit] 0 205 } 206 error_check_good db_close [$db close] 0 207 208 if { [is_hash $method] == 1 || [is_partition_callback $dbargs] == 1 } { 209 return 210 } 211 212 # We need to sort btvals according to the comparison function. 213 # Once that is done, btvalsck and btvals should be the same. 214 puts "\tTest$tnum.d: check file order" 215 216 $sortfunc 217 218 error_check_good btvals:len [llength $btvals] [llength $btvalsck] 219 for {set i 0} {$i < $nentries} {incr i} { 220 error_check_good vals:$i [lindex $btvals $i] \ 221 [lindex $btvalsck $i] 222 } 223} 224 225proc test093_runbig { method dbargs nentries tnum compflag cmpfunc sortfunc } { 226 source ./include.tcl 227 global btvals 228 global btvalsck 229 230 # We'll need any encryption args separated from the db args 231 # so we can pass them to dbverify. 232 set encargs "" 233 set dbargs [split_encargs $dbargs encargs] 234 235 # Create the database and open the dictionary 236 set eindex [lsearch -exact $dbargs "-env"] 237 # 238 # If we are using an env, then testfile should just be the db name. 239 # Otherwise it is the test directory and the name. 240 set txnenv 0 241 if { $eindex == -1 } { 242 set testfile $testdir/test$tnum.db 243 set env NULL 244 set envargs "" 245 } else { 246 set testfile test$tnum.db 247 incr eindex 248 set env [lindex $dbargs $eindex] 249 set envargs " -env $env " 250 set txnenv [is_txnenv $env] 251 set testdir [get_home $env] 252 } 253 cleanup $testdir $env 254 255 set db [eval {berkdb_open $compflag $cmpfunc \ 256 -create -mode 0644} $method $encargs $dbargs $testfile] 257 error_check_good dbopen [is_valid_db $db] TRUE 258 259 set t1 $testdir/t1 260 set t2 $testdir/t2 261 set t3 $testdir/t3 262 set t4 $testdir/t4 263 set t5 $testdir/t5 264 set txn "" 265 set btvals {} 266 set btvalsck {} 267 puts "\tTest$tnum.e:\ 268 big key put/get loop key=filecontents data=filename" 269 270 # Here is the loop where we put and get each key/data pair 271 set file_list [get_file_list 1] 272 273 set count 0 274 foreach f $file_list { 275 set fid [open $f r] 276 fconfigure $fid -translation binary 277 set key [read $fid] 278 close $fid 279 280 set key $f$key 281 282 set fcopy [open $t5 w] 283 fconfigure $fcopy -translation binary 284 puts -nonewline $fcopy $key 285 close $fcopy 286 287 if { $txnenv == 1 } { 288 set t [$env txn] 289 error_check_good txn [is_valid_txn $t $env] TRUE 290 set txn "-txn $t" 291 } 292 set ret [eval {$db put} $txn {$key \ 293 [chop_data $method $f]}] 294 error_check_good put_file $ret 0 295 if { $txnenv == 1 } { 296 error_check_good txn [$t commit] 0 297 } 298 299 lappend btvals $key 300 301 # Should really catch errors 302 set fid [open $t4 w] 303 fconfigure $fid -translation binary 304 if [catch {eval {$db get} {$key}} data] { 305 puts -nonewline $fid $data 306 } else { 307 # Data looks like {{key data}} 308 set key [lindex [lindex $data 0] 0] 309 puts -nonewline $fid $key 310 } 311 close $fid 312 error_check_good \ 313 Test093:diff($t5,$t4) [filecmp $t5 $t4] 0 314 315 incr count 316 } 317 318 # Now we will get each key from the DB and compare the results 319 # to the original. 320 puts "\tTest$tnum.f: big dump file" 321 if { $txnenv == 1 } { 322 set t [$env txn] 323 error_check_good txn [is_valid_txn $t $env] TRUE 324 set txn "-txn $t" 325 } 326 dump_file $db $txn $t1 test093_checkbig 327 if { $txnenv == 1 } { 328 error_check_good txn [$t commit] 0 329 } 330 error_check_good db_close [$db close] 0 331 332 # Run verify to check the internal structure and order. 333 if { [catch {eval {berkdb dbverify} $compflag $cmpfunc\ 334 $envargs $encargs {$testfile}} res] } { 335 error "FAIL: Verification failed with $res" 336 } 337 338 puts "\tTest$tnum.g: dump file in order" 339 # Now, reopen the file and run the last test again. 340 # We open it here, ourselves, because all uses of the db 341 # need to have the correct comparison func set. Then 342 # call dump_file_direction directly. 343 344 set btvalsck {} 345 set db [eval {berkdb_open $compflag $cmpfunc -rdonly} \ 346 $encargs $dbargs $method $testfile] 347 error_check_good dbopen [is_valid_db $db] TRUE 348 if { $txnenv == 1 } { 349 set t [$env txn] 350 error_check_good txn [is_valid_txn $t $env] TRUE 351 set txn "-txn $t" 352 } 353 dump_file_direction $db $txn $t1 test093_checkbig "-first" "-next" 354 if { $txnenv == 1 } { 355 error_check_good txn [$t commit] 0 356 } 357 error_check_good db_close [$db close] 0 358 359 if { [is_hash $method] == 1 || [is_partition_callback $dbargs] == 1 } { 360 return 361 } 362 363 # We need to sort btvals according to the comparison function. 364 # Once that is done, btvalsck and btvals should be the same. 365 puts "\tTest$tnum.h: check file order" 366 367 $sortfunc 368 error_check_good btvals:len [llength $btvals] [llength $btvalsck] 369 370 set end [llength $btvals] 371 for {set i 0} {$i < $end} {incr i} { 372 error_check_good vals:$i [lindex $btvals $i] \ 373 [lindex $btvalsck $i] 374 } 375} 376 377# Simple bt comparison. 378proc test093_cmp1 { a b } { 379 return [string compare $b $a] 380} 381 382# Simple bt sorting. 383proc test093_sort1 {} { 384 global btvals 385 # 386 # This one is easy, just sort in reverse. 387 # 388 set btvals [lsort -decreasing $btvals] 389} 390 391proc test093_cmp2 { a b } { 392 set arev [reverse $a] 393 set brev [reverse $b] 394 return [string compare $arev $brev] 395} 396 397proc test093_sort2 {} { 398 global btvals 399 400 # We have to reverse them, then sorts them. 401 # Then reverse them back to real words. 402 set rbtvals {} 403 foreach i $btvals { 404 lappend rbtvals [reverse $i] 405 } 406 set rbtvals [lsort -increasing $rbtvals] 407 set newbtvals {} 408 foreach i $rbtvals { 409 lappend newbtvals [reverse $i] 410 } 411 set btvals $newbtvals 412} 413 414# Check function for test093; keys and data are identical 415proc test093_check { key data } { 416 global btvalsck 417 418 error_check_good "key/data mismatch" $data [reverse $key] 419 lappend btvalsck $key 420} 421 422# Check function for test093 big keys; 423proc test093_checkbig { key data } { 424 source ./include.tcl 425 global btvalsck 426 427 set fid [open $data r] 428 fconfigure $fid -translation binary 429 set cont [read $fid] 430 close $fid 431 error_check_good "key/data mismatch" $key $data$cont 432 lappend btvalsck $key 433} 434 435