1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 2004,2008 Oracle. All rights reserved. 4# 5# $Id: test110.tcl,v 1.11 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test110 8# TEST Partial get test with duplicates. 9# TEST 10# TEST For hash and btree, create and populate a database 11# TEST with dups. Randomly selecting offset and length, 12# TEST retrieve data from each record and make sure we 13# TEST get what we expect. 14proc test110 { method {nentries 10000} {ndups 3} args } { 15 global rand_init 16 source ./include.tcl 17 18 set args [convert_args $method $args] 19 set omethod [convert_method $method] 20 21 if { [is_record_based $method] == 1 || \ 22 [is_rbtree $method] == 1 } { 23 puts "Test110 skipping for method $method" 24 return 25 } 26 27 # Create the database and open the dictionary 28 set txnenv 0 29 set eindex [lsearch -exact $args "-env"] 30 # 31 # If we are using an env, then testfile should just be the db name. 32 # Otherwise it is the test directory and the name. 33 if { $eindex == -1 } { 34 set testfile $testdir/test110.db 35 set env NULL 36 } else { 37 set testfile test110.db 38 incr eindex 39 set env [lindex $args $eindex] 40 set txnenv [is_txnenv $env] 41 if { $txnenv == 1 } { 42 append args " -auto_commit " 43 # 44 # If we are using txns and running with the 45 # default, set the default down a bit. 46 # 47 if { $nentries == 10000 } { 48 set nentries 100 49 } 50 } 51 set testdir [get_home $env] 52 } 53 puts "Test110: $method ($args) $nentries partial get test with duplicates" 54 55 cleanup $testdir $env 56 57 set db [eval {berkdb_open \ 58 -create -mode 0644} -dup $args {$omethod $testfile}] 59 error_check_good dbopen [is_valid_db $db] TRUE 60 set did [open $dict] 61 berkdb srand $rand_init 62 63 set txn "" 64 set count 0 65 66 puts "\tTest110.a: put/get loop" 67 for { set i 0 } { [gets $did str] != -1 && $i < $nentries } \ 68 { incr i } { 69 70 set key $str 71 set repl [berkdb random_int 1 100] 72 set kvals($key) $repl 73 set data [chop_data $method [replicate $str $repl]] 74 if { $txnenv == 1 } { 75 set t [$env txn] 76 error_check_good txn [is_valid_txn $t $env] TRUE 77 set txn "-txn $t" 78 } 79 for { set j 0 } { $j < $ndups } { incr j } { 80 set ret [eval {$db put} $txn {$key $j.$data}] 81 error_check_good dbput:$key:$j $ret 0 82 } 83 84 set dbc [eval {$db cursor} $txn] 85 error_check_good db_cursor [is_valid_cursor $dbc $db] TRUE 86 87 set ret [$dbc get -set $key] 88 89 set j 0 90 for { set dbt [$dbc get -current] } \ 91 { $j < $ndups } \ 92 { set dbt [$dbc get -next] } { 93 set d [lindex [lindex $dbt 0] 1] 94 error_check_good dupget:$key:$j $d [pad_data $method $j.$data] 95 incr j 96 } 97 error_check_good cursor_close [$dbc close] 0 98 if { $txnenv == 1 } { 99 error_check_good txn [$t commit] 0 100 } 101 } 102 close $did 103 104 puts "\tTest110.b: partial get loop" 105 set did [open $dict] 106 for { set i 0 } { [gets $did str] != -1 && $i < $nentries } \ 107 { incr i } { 108 set key $str 109 110 set data [pad_data $method [replicate $str $kvals($key)]] 111 set j 0 112 113 # Set up cursor. We will use the cursor to walk the dups. 114 if { $txnenv == 1 } { 115 set t [$env txn] 116 error_check_good txn [is_valid_txn $t $env] TRUE 117 set txn "-txn $t" 118 } 119 120 set dbc [eval {$db cursor} $txn] 121 error_check_good db_cursor [is_valid_cursor $dbc $db] TRUE 122 123 # Position cursor at the first of the dups. 124 set ret [$dbc get -set $key] 125 126 for { set dbt [$dbc get -current] } \ 127 { $j < $ndups } \ 128 { set dbt [$dbc get -next] } { 129 130 set dupdata $j.$data 131 set length [expr [string length $dupdata]] 132 set maxndx [expr $length + 1] 133 134 if { $maxndx > 0 } { 135 set beg [berkdb random_int 0 [expr $maxndx - 1]] 136 set len [berkdb random_int 0 [expr $maxndx * 2]] 137 } else { 138 set beg 0 139 set len 0 140 } 141 142 set ret [eval {$dbc get} -current \ 143 {-partial [list $beg $len]}] 144 145 # In order for tcl to handle this, we have to overwrite the 146 # last character with a NULL. That makes the length one less 147 # than we expect. 148 set k [lindex [lindex $ret 0] 0] 149 set d [lindex [lindex $ret 0] 1] 150 error_check_good dbget_key $k $key 151 error_check_good dbget_data $d \ 152 [string range $dupdata $beg [expr $beg + $len - 1]] 153 incr j 154 } 155 156 error_check_good cursor_close [$dbc close] 0 157 if { $txnenv == 1 } { 158 error_check_good txn [$t commit] 0 159 } 160 } 161 error_check_good db_close [$db close] 0 162 close $did 163} 164