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