1# See the file LICENSE for redistribution information. 2# 3# Copyright (c) 1996,2008 Oracle. All rights reserved. 4# 5# $Id: test019.tcl,v 12.6 2008/01/08 20:58:53 bostic Exp $ 6# 7# TEST test019 8# TEST Partial get test. 9proc test019 { method {nentries 10000} args } { 10 global fixed_len 11 global rand_init 12 source ./include.tcl 13 14 set args [convert_args $method $args] 15 set omethod [convert_method $method] 16 # Create the database and open the dictionary 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 testfile $testdir/test019.db 24 set env NULL 25 } else { 26 set testfile test019.db 27 incr eindex 28 set env [lindex $args $eindex] 29 set txnenv [is_txnenv $env] 30 if { $txnenv == 1 } { 31 append args " -auto_commit " 32 # 33 # If we are using txns and running with the 34 # default, set the default down a bit. 35 # 36 if { $nentries == 10000 } { 37 set nentries 100 38 } 39 } 40 set testdir [get_home $env] 41 } 42 puts "Test019: $method ($args) $nentries partial get test" 43 44 cleanup $testdir $env 45 46 set db [eval {berkdb_open \ 47 -create -mode 0644} $args {$omethod $testfile}] 48 error_check_good dbopen [is_valid_db $db] TRUE 49 set did [open $dict] 50 berkdb srand $rand_init 51 52 set pflags "" 53 set gflags "" 54 set txn "" 55 set count 0 56 57 if { [is_record_based $method] == 1 } { 58 append gflags " -recno" 59 } 60 61 puts "\tTest019.a: put/get loop" 62 for { set i 0 } { [gets $did str] != -1 && $i < $nentries } \ 63 { incr i } { 64 65 if { [is_record_based $method] == 1 } { 66 set key [expr $i + 1] 67 } else { 68 set key $str 69 } 70 set repl [berkdb random_int $fixed_len 100] 71 set data [chop_data $method [replicate $str $repl]] 72 if { $txnenv == 1 } { 73 set t [$env txn] 74 error_check_good txn [is_valid_txn $t $env] TRUE 75 set txn "-txn $t" 76 } 77 set ret [eval {$db put} $txn {-nooverwrite $key $data}] 78 error_check_good dbput:$key $ret 0 79 80 set ret [eval {$db get} $txn $gflags {$key}] 81 error_check_good \ 82 dbget:$key $ret [list [list $key [pad_data $method $data]]] 83 set kvals($key) $repl 84 if { $txnenv == 1 } { 85 error_check_good txn [$t commit] 0 86 } 87 } 88 close $did 89 90 puts "\tTest019.b: partial get loop" 91 set did [open $dict] 92 for { set i 0 } { [gets $did str] != -1 && $i < $nentries } \ 93 { incr i } { 94 if { [is_record_based $method] == 1 } { 95 set key [expr $i + 1] 96 } else { 97 set key $str 98 } 99 set data [pad_data $method [replicate $str $kvals($key)]] 100 101 set maxndx [expr [string length $data] - 1] 102 103 if { $maxndx > 0 } { 104 set beg [berkdb random_int 0 [expr $maxndx - 1]] 105 set len [berkdb random_int 0 [expr $maxndx * 2]] 106 } else { 107 set beg 0 108 set len 0 109 } 110 111 if { $txnenv == 1 } { 112 set t [$env txn] 113 error_check_good txn [is_valid_txn $t $env] TRUE 114 set txn "-txn $t" 115 } 116 set ret [eval {$db get} \ 117 $txn {-partial [list $beg $len]} $gflags {$key}] 118 if { $txnenv == 1 } { 119 error_check_good txn [$t commit] 0 120 } 121 122 # In order for tcl to handle this, we have to overwrite the 123 # last character with a NULL. That makes the length one less 124 # than we expect. 125 set k [lindex [lindex $ret 0] 0] 126 set d [lindex [lindex $ret 0] 1] 127 error_check_good dbget_key $k $key 128 129 error_check_good dbget_data $d \ 130 [string range $data $beg [expr $beg + $len - 1]] 131 132 } 133 error_check_good db_close [$db close] 0 134 close $did 135} 136