Import BSDDB 4.7.25 (as of svn r89086)
This commit is contained in:
Zachary Ware
366
test/test095.tcl
Normal file
366
test/test095.tcl
Normal file
@@ -0,0 +1,366 @@
|
||||
# See the file LICENSE for redistribution information.
|
||||
#
|
||||
# Copyright (c) 2000,2008 Oracle. All rights reserved.
|
||||
#
|
||||
# $Id: test095.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $
|
||||
#
|
||||
# TEST test095
|
||||
# TEST Bulk get test for methods supporting dups. [#2934]
|
||||
proc test095 { method {tnum "095"} args } {
|
||||
source ./include.tcl
|
||||
global is_je_test
|
||||
global is_qnx_test
|
||||
|
||||
set args [convert_args $method $args]
|
||||
set omethod [convert_method $method]
|
||||
|
||||
set txnenv 0
|
||||
set eindex [lsearch -exact $args "-env"]
|
||||
#
|
||||
# If we are using an env, then testfile should just be the db name.
|
||||
# Otherwise it is the test directory and the name.
|
||||
if { $eindex == -1 } {
|
||||
set basename $testdir/test$tnum
|
||||
set env NULL
|
||||
# If we've our own env, no reason to swap--this isn't
|
||||
# an mpool test.
|
||||
set carg { -cachesize {0 25000000 0} }
|
||||
} else {
|
||||
set basename test$tnum
|
||||
incr eindex
|
||||
set env [lindex $args $eindex]
|
||||
set txnenv [is_txnenv $env]
|
||||
if { $txnenv == 1 } {
|
||||
puts "Skipping for environment with txns"
|
||||
return
|
||||
}
|
||||
set testdir [get_home $env]
|
||||
set carg {}
|
||||
}
|
||||
cleanup $testdir $env
|
||||
|
||||
puts "Test$tnum: $method ($args) Bulk get test"
|
||||
|
||||
# Tcl leaves a lot of memory allocated after this test
|
||||
# is run in the tclsh. This ends up being a problem on
|
||||
# QNX runs as later tests then run out of memory.
|
||||
if { $is_qnx_test } {
|
||||
puts "Test$tnum skipping for QNX"
|
||||
return
|
||||
}
|
||||
if { [is_record_based $method] == 1 || [is_rbtree $method] == 1 } {
|
||||
puts "Test$tnum skipping for method $method"
|
||||
return
|
||||
}
|
||||
|
||||
# The test's success is dependent on the relationship between
|
||||
# the amount of data loaded and the buffer sizes we pick, so
|
||||
# these parameters don't belong on the command line.
|
||||
set nsets 300
|
||||
set noverflows 25
|
||||
|
||||
# We run the meat of the test twice: once with unsorted dups,
|
||||
# once with sorted dups.
|
||||
foreach { dflag sort } { -dup unsorted {-dup -dupsort} sorted } {
|
||||
if { $is_je_test && $sort == "unsorted" } {
|
||||
continue
|
||||
}
|
||||
|
||||
set testfile $basename-$sort.db
|
||||
set did [open $dict]
|
||||
|
||||
# Open and populate the database with $nsets sets of dups.
|
||||
# Each set contains as many dups as its number
|
||||
puts "\tTest$tnum.a:\
|
||||
Creating database with $nsets sets of $sort dups."
|
||||
set dargs "$dflag $carg $args"
|
||||
set db [eval {berkdb_open_noerr -create} \
|
||||
$omethod $dargs $testfile]
|
||||
error_check_good db_open [is_valid_db $db] TRUE
|
||||
t95_populate $db $did $nsets 0
|
||||
|
||||
# Determine the pagesize so we can use it to size the buffer.
|
||||
set stat [$db stat]
|
||||
set pagesize [get_pagesize $stat]
|
||||
|
||||
# Run basic get tests.
|
||||
#
|
||||
# A small buffer will fail if it is smaller than the pagesize.
|
||||
# Skip small buffer tests if the page size is so small that
|
||||
# we can't define a buffer smaller than the page size.
|
||||
# (Buffers must be 1024 or multiples of 1024.)
|
||||
#
|
||||
# A big buffer of 66560 (64K + 1K) should always be large
|
||||
# enough to contain the data, so the test should succeed
|
||||
# on all platforms. We picked this number because it
|
||||
# is larger than the largest allowed pagesize, so the test
|
||||
# always fills more than a page at some point.
|
||||
|
||||
set maxpage [expr 1024 * 64]
|
||||
set bigbuf [expr $maxpage + 1024]
|
||||
set smallbuf 1024
|
||||
|
||||
if { $pagesize > 1024 } {
|
||||
t95_gettest $db $tnum b $smallbuf 1
|
||||
} else {
|
||||
puts "Skipping small buffer test Test$tnum.b"
|
||||
}
|
||||
t95_gettest $db $tnum c $bigbuf 0
|
||||
|
||||
# Run cursor get tests.
|
||||
if { $pagesize > 1024 } {
|
||||
t95_cgettest $db $tnum b $smallbuf 1
|
||||
} else {
|
||||
puts "Skipping small buffer test Test$tnum.d"
|
||||
}
|
||||
t95_cgettest $db $tnum e $bigbuf 0
|
||||
|
||||
# Run invalid flag combination tests
|
||||
# Sync and reopen test file so errors won't be sent to stderr
|
||||
error_check_good db_sync [$db sync] 0
|
||||
set noerrdb [eval berkdb_open_noerr $dargs $testfile]
|
||||
t95_flagtest $noerrdb $tnum f [expr 8192]
|
||||
t95_cflagtest $noerrdb $tnum g [expr 100]
|
||||
error_check_good noerrdb_close [$noerrdb close] 0
|
||||
|
||||
# Set up for overflow tests
|
||||
set max [expr 4096 * $noverflows]
|
||||
puts "\tTest$tnum.h: Add $noverflows overflow sets\
|
||||
to database (max item size $max)"
|
||||
t95_populate $db $did $noverflows 4096
|
||||
|
||||
# Run overflow get tests. The overflow test fails with
|
||||
# our standard big buffer doubled, but succeeds with a
|
||||
# buffer sized to handle $noverflows pairs of data of
|
||||
# size $max.
|
||||
t95_gettest $db $tnum i $bigbuf 1
|
||||
t95_gettest $db $tnum j [expr $bigbuf * 2] 1
|
||||
t95_gettest $db $tnum k [expr $max * $noverflows * 2] 0
|
||||
|
||||
# Run overflow cursor get tests.
|
||||
t95_cgettest $db $tnum l $bigbuf 1
|
||||
# Expand buffer to accommodate basekey as well as the padding.
|
||||
t95_cgettest $db $tnum m [expr ($max + 512) * 2] 0
|
||||
|
||||
error_check_good db_close [$db close] 0
|
||||
close $did
|
||||
}
|
||||
}
|
||||
|
||||
proc t95_gettest { db tnum letter bufsize expectfail } {
|
||||
t95_gettest_body $db $tnum $letter $bufsize $expectfail 0
|
||||
}
|
||||
proc t95_cgettest { db tnum letter bufsize expectfail } {
|
||||
t95_gettest_body $db $tnum $letter $bufsize $expectfail 1
|
||||
}
|
||||
proc t95_flagtest { db tnum letter bufsize } {
|
||||
t95_flagtest_body $db $tnum $letter $bufsize 0
|
||||
}
|
||||
proc t95_cflagtest { db tnum letter bufsize } {
|
||||
t95_flagtest_body $db $tnum $letter $bufsize 1
|
||||
}
|
||||
|
||||
# Basic get test
|
||||
proc t95_gettest_body { db tnum letter bufsize expectfail usecursor } {
|
||||
global errorCode
|
||||
|
||||
foreach flag { multi multi_key } {
|
||||
if { $usecursor == 0 } {
|
||||
if { $flag == "multi_key" } {
|
||||
# db->get does not allow multi_key
|
||||
continue
|
||||
} else {
|
||||
set action "db get -$flag"
|
||||
}
|
||||
} else {
|
||||
set action "dbc get -$flag -set/-next"
|
||||
}
|
||||
puts "\tTest$tnum.$letter: $action with bufsize $bufsize"
|
||||
set allpassed TRUE
|
||||
set saved_err ""
|
||||
|
||||
# Cursor for $usecursor.
|
||||
if { $usecursor != 0 } {
|
||||
set getcurs [$db cursor]
|
||||
error_check_good getcurs [is_valid_cursor $getcurs $db] TRUE
|
||||
}
|
||||
|
||||
# Traverse DB with cursor; do get/c_get($flag) on each item.
|
||||
set dbc [$db cursor]
|
||||
error_check_good is_valid_dbc [is_valid_cursor $dbc $db] TRUE
|
||||
for { set dbt [$dbc get -first] } { [llength $dbt] != 0 } \
|
||||
{ set dbt [$dbc get -nextnodup] } {
|
||||
set key [lindex [lindex $dbt 0] 0]
|
||||
set datum [lindex [lindex $dbt 0] 1]
|
||||
|
||||
if { $usecursor == 0 } {
|
||||
set ret [catch {eval $db get -$flag $bufsize $key} res]
|
||||
} else {
|
||||
set res {}
|
||||
for { set ret [catch {eval $getcurs get -$flag $bufsize\
|
||||
-set $key} tres] } \
|
||||
{ $ret == 0 && [llength $tres] != 0 } \
|
||||
{ set ret [catch {eval $getcurs get -$flag $bufsize\
|
||||
-nextdup} tres]} {
|
||||
eval lappend res $tres
|
||||
}
|
||||
}
|
||||
|
||||
# If we expect a failure, be more tolerant if the above
|
||||
# fails; just make sure it's a DB_BUFFER_SMALL or an
|
||||
# EINVAL (if the buffer is smaller than the pagesize,
|
||||
# it's EINVAL), mark it, and move along.
|
||||
if { $expectfail != 0 && $ret != 0 } {
|
||||
if { [is_substr $errorCode DB_BUFFER_SMALL] != 1 && \
|
||||
[is_substr $errorCode EINVAL] != 1 } {
|
||||
error_check_good \
|
||||
"$flag failure errcode" \
|
||||
$errorCode "DB_BUFFER_SMALL or EINVAL"
|
||||
}
|
||||
set allpassed FALSE
|
||||
continue
|
||||
}
|
||||
error_check_good "get_$flag ($key)" $ret 0
|
||||
if { $flag == "multi_key" } {
|
||||
t95_verify $res TRUE
|
||||
} else {
|
||||
t95_verify $res FALSE
|
||||
}
|
||||
}
|
||||
set ret [catch {eval $db get -$flag $bufsize} res]
|
||||
|
||||
if { $expectfail == 1 } {
|
||||
error_check_good allpassed $allpassed FALSE
|
||||
puts "\t\tTest$tnum.$letter:\
|
||||
returned at least one DB_BUFFER_SMALL (as expected)"
|
||||
} else {
|
||||
error_check_good allpassed $allpassed TRUE
|
||||
puts "\t\tTest$tnum.$letter: succeeded (as expected)"
|
||||
}
|
||||
|
||||
error_check_good dbc_close [$dbc close] 0
|
||||
if { $usecursor != 0 } {
|
||||
error_check_good getcurs_close [$getcurs close] 0
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Test of invalid flag combinations
|
||||
proc t95_flagtest_body { db tnum letter bufsize usecursor } {
|
||||
global errorCode
|
||||
|
||||
foreach flag { multi multi_key } {
|
||||
if { $usecursor == 0 } {
|
||||
if { $flag == "multi_key" } {
|
||||
# db->get does not allow multi_key
|
||||
continue
|
||||
} else {
|
||||
set action "db get -$flag"
|
||||
}
|
||||
} else {
|
||||
set action "dbc get -$flag"
|
||||
}
|
||||
puts "\tTest$tnum.$letter: $action with invalid flag combinations"
|
||||
|
||||
# Cursor for $usecursor.
|
||||
if { $usecursor != 0 } {
|
||||
set getcurs [$db cursor]
|
||||
error_check_good getcurs [is_valid_cursor $getcurs $db] TRUE
|
||||
}
|
||||
|
||||
if { $usecursor == 0 } {
|
||||
# Disallowed flags for db->get
|
||||
set badflags [list consume consume_wait {rmw some_key}]
|
||||
|
||||
foreach badflag $badflags {
|
||||
catch {eval $db get -$flag $bufsize -$badflag} ret
|
||||
error_check_good \
|
||||
db:get:$flag:$badflag [is_substr $errorCode EINVAL] 1
|
||||
}
|
||||
} else {
|
||||
# Disallowed flags for db->cget
|
||||
set cbadflags [list last get_recno join_item \
|
||||
{multi_key 1000} prev prevnodup]
|
||||
|
||||
set dbc [$db cursor]
|
||||
$dbc get -first
|
||||
foreach badflag $cbadflags {
|
||||
catch {eval $dbc get -$flag $bufsize -$badflag} ret
|
||||
error_check_good dbc:get:$flag:$badflag \
|
||||
[is_substr $errorCode EINVAL] 1
|
||||
}
|
||||
error_check_good dbc_close [$dbc close] 0
|
||||
}
|
||||
if { $usecursor != 0 } {
|
||||
error_check_good getcurs_close [$getcurs close] 0
|
||||
}
|
||||
}
|
||||
puts "\t\tTest$tnum.$letter completed"
|
||||
}
|
||||
|
||||
# Verify that a passed-in list of key/data pairs all match the predicted
|
||||
# structure (e.g. {{thing1 thing1.0}}, {{key2 key2.0} {key2 key2.1}}).
|
||||
proc t95_verify { res multiple_keys } {
|
||||
global alphabet
|
||||
|
||||
set i 0
|
||||
set orig_key [lindex [lindex $res 0] 0]
|
||||
set nkeys [string trim $orig_key $alphabet']
|
||||
set base_key [string trim $orig_key 0123456789]
|
||||
set datum_count 0
|
||||
|
||||
while { 1 } {
|
||||
set key [lindex [lindex $res $i] 0]
|
||||
set datum [lindex [lindex $res $i] 1]
|
||||
if { $datum_count >= $nkeys } {
|
||||
if { [llength $key] != 0 } {
|
||||
# If there are keys beyond $nkeys, we'd
|
||||
# better have multiple_keys set.
|
||||
error_check_bad "keys beyond number $i allowed"\
|
||||
$multiple_keys FALSE
|
||||
|
||||
# If multiple_keys is set, accept the new key.
|
||||
set orig_key $key
|
||||
set nkeys [eval string trim \
|
||||
$orig_key {$alphabet'}]
|
||||
set base_key [eval string trim \
|
||||
$orig_key 0123456789]
|
||||
set datum_count 0
|
||||
} else {
|
||||
# datum_count has hit nkeys. We're done.
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
error_check_good returned_key($i) $key $orig_key
|
||||
error_check_good returned_datum($i) \
|
||||
$datum $base_key.[format %4u $datum_count]
|
||||
incr datum_count
|
||||
incr i
|
||||
}
|
||||
}
|
||||
|
||||
# Add nsets dup sets, each consisting of {word$ndups word$n} pairs,
|
||||
# with "word" having (i * pad_bytes) bytes extra padding.
|
||||
proc t95_populate { db did nsets pad_bytes } {
|
||||
set txn ""
|
||||
for { set i 1 } { $i <= $nsets } { incr i } {
|
||||
# basekey is a padded dictionary word
|
||||
gets $did basekey
|
||||
|
||||
append basekey [repeat "a" [expr $pad_bytes * $i]]
|
||||
|
||||
# key is basekey with the number of dups stuck on.
|
||||
set key $basekey$i
|
||||
|
||||
for { set j 0 } { $j < $i } { incr j } {
|
||||
set data $basekey.[format %4u $j]
|
||||
error_check_good db_put($key,$data) \
|
||||
[eval {$db put} $txn {$key $data}] 0
|
||||
}
|
||||
}
|
||||
|
||||
# This will make debugging easier, and since the database is
|
||||
# read-only from here out, it's cheap.
|
||||
error_check_good db_sync [$db sync] 0
|
||||
}
|
||||
Reference in New Issue
Block a user