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