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