1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 2000,2008 Oracle. All rights reserved. 4# 5# $Id: test095.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test095 8# TEST Bulk get test for methods supporting dups. [#2934] 9proc test095 { method {tnum "095"} args } { 10 source ./include.tcl 11 global is_je_test 12 global is_qnx_test 13 14 set args [convert_args $method $args] 15 set omethod [convert_method $method] 16 17 set txnenv 0 18 set eindex [lsearch -exact $args "-env"] 19 # 20 # If we are using an env, then testfile should just be the db name. 21 # Otherwise it is the test directory and the name. 22 if { $eindex == -1 } { 23 set basename $testdir/test$tnum 24 set env NULL 25 # If we've our own env, no reason to swap--this isn't 26 # an mpool test. 27 set carg { -cachesize {0 25000000 0} } 28 } else { 29 set basename test$tnum 30 incr eindex 31 set env [lindex $args $eindex] 32 set txnenv [is_txnenv $env] 33 if { $txnenv == 1 } { 34 puts "Skipping for environment with txns" 35 return 36 } 37 set testdir [get_home $env] 38 set carg {} 39 } 40 cleanup $testdir $env 41 42 puts "Test$tnum: $method ($args) Bulk get test" 43 44 # Tcl leaves a lot of memory allocated after this test 45 # is run in the tclsh. This ends up being a problem on 46 # QNX runs as later tests then run out of memory. 47 if { $is_qnx_test } { 48 puts "Test$tnum skipping for QNX" 49 return 50 } 51 if { [is_record_based $method] == 1 || [is_rbtree $method] == 1 } { 52 puts "Test$tnum skipping for method $method" 53 return 54 } 55 56 # The test's success is dependent on the relationship between 57 # the amount of data loaded and the buffer sizes we pick, so 58 # these parameters don't belong on the command line. 59 set nsets 300 60 set noverflows 25 61 62 # We run the meat of the test twice: once with unsorted dups, 63 # once with sorted dups. 64 foreach { dflag sort } { -dup unsorted {-dup -dupsort} sorted } { 65 if { $is_je_test && $sort == "unsorted" } { 66 continue 67 } 68 69 set testfile $basename-$sort.db 70 set did [open $dict] 71 72 # Open and populate the database with $nsets sets of dups. 73 # Each set contains as many dups as its number 74 puts "\tTest$tnum.a:\ 75 Creating database with $nsets sets of $sort dups." 76 set dargs "$dflag $carg $args" 77 set db [eval {berkdb_open_noerr -create} \ 78 $omethod $dargs $testfile] 79 error_check_good db_open [is_valid_db $db] TRUE 80 t95_populate $db $did $nsets 0 81 82 # Determine the pagesize so we can use it to size the buffer. 83 set stat [$db stat] 84 set pagesize [get_pagesize $stat] 85 86 # Run basic get tests. 87 # 88 # A small buffer will fail if it is smaller than the pagesize. 89 # Skip small buffer tests if the page size is so small that 90 # we can't define a buffer smaller than the page size. 91 # (Buffers must be 1024 or multiples of 1024.) 92 # 93 # A big buffer of 66560 (64K + 1K) should always be large 94 # enough to contain the data, so the test should succeed 95 # on all platforms. We picked this number because it 96 # is larger than the largest allowed pagesize, so the test 97 # always fills more than a page at some point. 98 99 set maxpage [expr 1024 * 64] 100 set bigbuf [expr $maxpage + 1024] 101 set smallbuf 1024 102 103 if { $pagesize > 1024 } { 104 t95_gettest $db $tnum b $smallbuf 1 105 } else { 106 puts "Skipping small buffer test Test$tnum.b" 107 } 108 t95_gettest $db $tnum c $bigbuf 0 109 110 # Run cursor get tests. 111 if { $pagesize > 1024 } { 112 t95_cgettest $db $tnum b $smallbuf 1 113 } else { 114 puts "Skipping small buffer test Test$tnum.d" 115 } 116 t95_cgettest $db $tnum e $bigbuf 0 117 118 # Run invalid flag combination tests 119 # Sync and reopen test file so errors won't be sent to stderr 120 error_check_good db_sync [$db sync] 0 121 set noerrdb [eval berkdb_open_noerr $dargs $testfile] 122 t95_flagtest $noerrdb $tnum f [expr 8192] 123 t95_cflagtest $noerrdb $tnum g [expr 100] 124 error_check_good noerrdb_close [$noerrdb close] 0 125 126 # Set up for overflow tests 127 set max [expr 4096 * $noverflows] 128 puts "\tTest$tnum.h: Add $noverflows overflow sets\ 129 to database (max item size $max)" 130 t95_populate $db $did $noverflows 4096 131 132 # Run overflow get tests. The overflow test fails with 133 # our standard big buffer doubled, but succeeds with a 134 # buffer sized to handle $noverflows pairs of data of 135 # size $max. 136 t95_gettest $db $tnum i $bigbuf 1 137 t95_gettest $db $tnum j [expr $bigbuf * 2] 1 138 t95_gettest $db $tnum k [expr $max * $noverflows * 2] 0 139 140 # Run overflow cursor get tests. 141 t95_cgettest $db $tnum l $bigbuf 1 142 # Expand buffer to accommodate basekey as well as the padding. 143 t95_cgettest $db $tnum m [expr ($max + 512) * 2] 0 144 145 error_check_good db_close [$db close] 0 146 close $did 147 } 148} 149 150proc t95_gettest { db tnum letter bufsize expectfail } { 151 t95_gettest_body $db $tnum $letter $bufsize $expectfail 0 152} 153proc t95_cgettest { db tnum letter bufsize expectfail } { 154 t95_gettest_body $db $tnum $letter $bufsize $expectfail 1 155} 156proc t95_flagtest { db tnum letter bufsize } { 157 t95_flagtest_body $db $tnum $letter $bufsize 0 158} 159proc t95_cflagtest { db tnum letter bufsize } { 160 t95_flagtest_body $db $tnum $letter $bufsize 1 161} 162 163# Basic get test 164proc t95_gettest_body { db tnum letter bufsize expectfail usecursor } { 165 global errorCode 166 167 foreach flag { multi multi_key } { 168 if { $usecursor == 0 } { 169 if { $flag == "multi_key" } { 170 # db->get does not allow multi_key 171 continue 172 } else { 173 set action "db get -$flag" 174 } 175 } else { 176 set action "dbc get -$flag -set/-next" 177 } 178 puts "\tTest$tnum.$letter: $action with bufsize $bufsize" 179 set allpassed TRUE 180 set saved_err "" 181 182 # Cursor for $usecursor. 183 if { $usecursor != 0 } { 184 set getcurs [$db cursor] 185 error_check_good getcurs [is_valid_cursor $getcurs $db] TRUE 186 } 187 188 # Traverse DB with cursor; do get/c_get($flag) on each item. 189 set dbc [$db cursor] 190 error_check_good is_valid_dbc [is_valid_cursor $dbc $db] TRUE 191 for { set dbt [$dbc get -first] } { [llength $dbt] != 0 } \ 192 { set dbt [$dbc get -nextnodup] } { 193 set key [lindex [lindex $dbt 0] 0] 194 set datum [lindex [lindex $dbt 0] 1] 195 196 if { $usecursor == 0 } { 197 set ret [catch {eval $db get -$flag $bufsize $key} res] 198 } else { 199 set res {} 200 for { set ret [catch {eval $getcurs get -$flag $bufsize\ 201 -set $key} tres] } \ 202 { $ret == 0 && [llength $tres] != 0 } \ 203 { set ret [catch {eval $getcurs get -$flag $bufsize\ 204 -nextdup} tres]} { 205 eval lappend res $tres 206 } 207 } 208 209 # If we expect a failure, be more tolerant if the above 210 # fails; just make sure it's a DB_BUFFER_SMALL or an 211 # EINVAL (if the buffer is smaller than the pagesize, 212 # it's EINVAL), mark it, and move along. 213 if { $expectfail != 0 && $ret != 0 } { 214 if { [is_substr $errorCode DB_BUFFER_SMALL] != 1 && \ 215 [is_substr $errorCode EINVAL] != 1 } { 216 error_check_good \ 217 "$flag failure errcode" \ 218 $errorCode "DB_BUFFER_SMALL or EINVAL" 219 } 220 set allpassed FALSE 221 continue 222 } 223 error_check_good "get_$flag ($key)" $ret 0 224 if { $flag == "multi_key" } { 225 t95_verify $res TRUE 226 } else { 227 t95_verify $res FALSE 228 } 229 } 230 set ret [catch {eval $db get -$flag $bufsize} res] 231 232 if { $expectfail == 1 } { 233 error_check_good allpassed $allpassed FALSE 234 puts "\t\tTest$tnum.$letter:\ 235 returned at least one DB_BUFFER_SMALL (as expected)" 236 } else { 237 error_check_good allpassed $allpassed TRUE 238 puts "\t\tTest$tnum.$letter: succeeded (as expected)" 239 } 240 241 error_check_good dbc_close [$dbc close] 0 242 if { $usecursor != 0 } { 243 error_check_good getcurs_close [$getcurs close] 0 244 } 245 } 246} 247 248# Test of invalid flag combinations 249proc t95_flagtest_body { db tnum letter bufsize usecursor } { 250 global errorCode 251 252 foreach flag { multi multi_key } { 253 if { $usecursor == 0 } { 254 if { $flag == "multi_key" } { 255 # db->get does not allow multi_key 256 continue 257 } else { 258 set action "db get -$flag" 259 } 260 } else { 261 set action "dbc get -$flag" 262 } 263 puts "\tTest$tnum.$letter: $action with invalid flag combinations" 264 265 # Cursor for $usecursor. 266 if { $usecursor != 0 } { 267 set getcurs [$db cursor] 268 error_check_good getcurs [is_valid_cursor $getcurs $db] TRUE 269 } 270 271 if { $usecursor == 0 } { 272 # Disallowed flags for db->get 273 set badflags [list consume consume_wait {rmw some_key}] 274 275 foreach badflag $badflags { 276 catch {eval $db get -$flag $bufsize -$badflag} ret 277 error_check_good \ 278 db:get:$flag:$badflag [is_substr $errorCode EINVAL] 1 279 } 280 } else { 281 # Disallowed flags for db->cget 282 set cbadflags [list last get_recno join_item \ 283 {multi_key 1000} prev prevnodup] 284 285 set dbc [$db cursor] 286 $dbc get -first 287 foreach badflag $cbadflags { 288 catch {eval $dbc get -$flag $bufsize -$badflag} ret 289 error_check_good dbc:get:$flag:$badflag \ 290 [is_substr $errorCode EINVAL] 1 291 } 292 error_check_good dbc_close [$dbc close] 0 293 } 294 if { $usecursor != 0 } { 295 error_check_good getcurs_close [$getcurs close] 0 296 } 297 } 298 puts "\t\tTest$tnum.$letter completed" 299} 300 301# Verify that a passed-in list of key/data pairs all match the predicted 302# structure (e.g. {{thing1 thing1.0}}, {{key2 key2.0} {key2 key2.1}}). 303proc t95_verify { res multiple_keys } { 304 global alphabet 305 306 set i 0 307 set orig_key [lindex [lindex $res 0] 0] 308 set nkeys [string trim $orig_key $alphabet'] 309 set base_key [string trim $orig_key 0123456789] 310 set datum_count 0 311 312 while { 1 } { 313 set key [lindex [lindex $res $i] 0] 314 set datum [lindex [lindex $res $i] 1] 315 if { $datum_count >= $nkeys } { 316 if { [llength $key] != 0 } { 317 # If there are keys beyond $nkeys, we'd 318 # better have multiple_keys set. 319 error_check_bad "keys beyond number $i allowed"\ 320 $multiple_keys FALSE 321 322 # If multiple_keys is set, accept the new key. 323 set orig_key $key 324 set nkeys [eval string trim \ 325 $orig_key {$alphabet'}] 326 set base_key [eval string trim \ 327 $orig_key 0123456789] 328 set datum_count 0 329 } else { 330 # datum_count has hit nkeys. We're done. 331 return 332 } 333 } 334 335 error_check_good returned_key($i) $key $orig_key 336 error_check_good returned_datum($i) \ 337 $datum $base_key.[format %4u $datum_count] 338 incr datum_count 339 incr i 340 } 341} 342 343# Add nsets dup sets, each consisting of {word$ndups word$n} pairs, 344# with "word" having (i * pad_bytes) bytes extra padding. 345proc t95_populate { db did nsets pad_bytes } { 346 set txn "" 347 for { set i 1 } { $i <= $nsets } { incr i } { 348 # basekey is a padded dictionary word 349 gets $did basekey 350 351 append basekey [repeat "a" [expr $pad_bytes * $i]] 352 353 # key is basekey with the number of dups stuck on. 354 set key $basekey$i 355 356 for { set j 0 } { $j < $i } { incr j } { 357 set data $basekey.[format %4u $j] 358 error_check_good db_put($key,$data) \ 359 [eval {$db put} $txn {$key $data}] 0 360 } 361 } 362 363 # This will make debugging easier, and since the database is 364 # read-only from here out, it's cheap. 365 error_check_good db_sync [$db sync] 0 366} 367