1# See the file LICENSE for redistribution information.
2#
3# Copyright (c) 1996,2008 Oracle.  All rights reserved.
4#
5# $Id: test015.tcl,v 12.7 2008/01/08 20:58:53 bostic Exp $
6#
7# TEST	test015
8# TEST	Partial put test
9# TEST		Partial put test where the key does not initially exist.
10proc test015 { method {nentries 7500} { start 0 } args } {
11	global fixed_len testdir
12	set orig_tdir $testdir
13
14	set low_range 50
15	set mid_range 100
16	set high_range 1000
17
18	if { [is_fixed_length $method] } {
19		set low_range [expr $fixed_len/2 - 2]
20		set mid_range [expr $fixed_len/2]
21		set high_range $fixed_len
22	}
23
24	set t_table {
25		{ 1 { 1 1 1 } }
26		{ 2 { 1 1 5 } }
27		{ 3 { 1 1 $low_range } }
28		{ 4 { 1 $mid_range 1 } }
29		{ 5 { $mid_range $high_range 5 } }
30		{ 6 { 1 $mid_range $low_range } }
31	}
32
33	puts "Test015: \
34	    $method ($args) $nentries equal key/data pairs, partial put test"
35	test015_init
36	if { $start == 0 } {
37		set start { 1 2 3 4 5 6 }
38	}
39	foreach entry $t_table {
40		set this [lindex $entry 0]
41		if { [lsearch $start $this] == -1 } {
42			continue
43		}
44		puts -nonewline "$this: "
45		eval [concat test015_body $method [lindex $entry 1] \
46		    $nentries $args]
47		set eindex [lsearch -exact $args "-env"]
48		if { $eindex != -1 } {
49			incr eindex
50			set env [lindex $args $eindex]
51			set testdir [get_home $env]
52		}
53
54		error_check_good verify [verify_dir $testdir "\tTest015.e: "] 0
55	}
56	set testdir $orig_tdir
57}
58
59proc test015_init { } {
60	global rand_init
61
62	berkdb srand $rand_init
63}
64
65proc test015_body { method off_low off_hi rcount {nentries 10000} args } {
66	global dvals
67	global fixed_len
68	global testdir
69	source ./include.tcl
70
71	set args [convert_args $method $args]
72	set omethod [convert_method $method]
73
74	set orig_tdir $testdir
75	set checkfunc test015.check
76
77	if { [is_fixed_length $method] && \
78		[string compare $omethod "-recno"] == 0} {
79		# is fixed recno method
80		set checkfunc test015.check
81	}
82
83	puts "Put $rcount strings random offsets between $off_low and $off_hi"
84
85	# Create the database and open the dictionary
86	set txnenv 0
87	set eindex [lsearch -exact $args "-env"]
88	#
89	# If we are using an env, then testfile should just be the db name.
90	# Otherwise it is the test directory and the name.
91	if { $eindex == -1 } {
92		set testfile $testdir/test015.db
93		set env NULL
94	} else {
95		set testfile test015.db
96		incr eindex
97		set env [lindex $args $eindex]
98		set txnenv [is_txnenv $env]
99		if { $txnenv == 1 } {
100			append args " -auto_commit "
101			#
102			# If we are using txns and running with the
103			# default, set the default down a bit.
104			#
105			if { $nentries > 5000 } {
106				set nentries 100
107			}
108		}
109		set testdir [get_home $env]
110	}
111	set retdir $testdir
112	set t1 $testdir/t1
113	set t2 $testdir/t2
114	set t3 $testdir/t3
115	cleanup $testdir $env
116
117	set db [eval {berkdb_open \
118	     -create -mode 0644} $args {$omethod $testfile}]
119	error_check_good dbopen [is_valid_db $db] TRUE
120
121	set pflags ""
122	set gflags ""
123	set txn ""
124	set count 0
125
126	puts "\tTest015.a: put/get loop for $nentries entries"
127
128	# Here is the loop where we put and get each key/data pair
129	# Each put is a partial put of a record that does not exist.
130	set did [open $dict]
131	while { [gets $did str] != -1 && $count < $nentries } {
132		if { [is_record_based $method] == 1 } {
133			if { [string length $str] > $fixed_len } {
134				continue
135			}
136			set key [expr $count + 1]
137		} else {
138			set key $str
139		}
140
141		if { 0 } {
142			set data [replicate $str $rcount]
143			set off [ berkdb random_int $off_low $off_hi ]
144			set offn [expr $off + 1]
145			if { [is_fixed_length $method] && \
146			    [expr [string length $data] + $off] >= $fixed_len} {
147			    set data [string range $data 0 [expr $fixed_len-$offn]]
148			}
149			set dvals($key) [partial_shift $data $off right]
150		} else {
151			set data [chop_data $method [replicate $str $rcount]]
152
153			# This is a hack.  In DB we will store the records with
154			# some padding, but these will get lost if we just return
155			# them in TCL.  As a result, we're going to have to hack
156			# get to check for 0 padding and return a list consisting
157			# of the number of 0's and the actual data.
158			set off [ berkdb random_int $off_low $off_hi ]
159
160			# There is no string concatenation function in Tcl
161			# (although there is one in TclX), so we have to resort
162			# to this hack. Ugh.
163			set slen [string length $data]
164			if {[is_fixed_length $method] && \
165			    $slen > $fixed_len - $off} {
166				set $slen [expr $fixed_len - $off]
167			}
168			set a "a"
169			set dvals($key) [pad_data \
170			    $method [eval "binary format x$off$a$slen" {$data}]]
171		}
172		if {[is_fixed_length $method] && \
173		    [string length $data] > ($fixed_len - $off)} {
174		    set slen [expr $fixed_len - $off]
175		    set data [eval "binary format a$slen" {$data}]
176		}
177		if { $txnenv == 1 } {
178			set t [$env txn]
179			error_check_good txn [is_valid_txn $t $env] TRUE
180			set txn "-txn $t"
181		}
182		set ret [eval {$db put} $txn \
183		    {-partial [list $off [string length $data]] $key $data}]
184		error_check_good put $ret 0
185		if { $txnenv == 1 } {
186			error_check_good txn [$t commit] 0
187		}
188
189		incr count
190	}
191	close $did
192
193	# Now make sure that everything looks OK
194	puts "\tTest015.b: check entire file contents"
195	if { $txnenv == 1 } {
196		set t [$env txn]
197		error_check_good txn [is_valid_txn $t $env] TRUE
198		set txn "-txn $t"
199	}
200	dump_file $db $txn $t1 $checkfunc
201	if { $txnenv == 1 } {
202		error_check_good txn [$t commit] 0
203	}
204	error_check_good db_close [$db close] 0
205
206	# Now compare the keys to see if they match the dictionary (or ints)
207	if { [is_record_based $method] == 1 } {
208		set oid [open $t2 w]
209		for {set i 1} {$i <= $nentries} {set i [incr i]} {
210			puts $oid $i
211		}
212		close $oid
213		filesort $t2 $t3
214		file rename -force $t3 $t2
215		filesort $t1 $t3
216	} else {
217		set q q
218		filehead $nentries $dict $t3
219		filesort $t3 $t2
220		filesort $t1 $t3
221	}
222
223	error_check_good Test015:diff($t3,$t2) \
224	    [filecmp $t3 $t2] 0
225
226	puts "\tTest015.c: close, open, and dump file"
227	# Now, reopen the file and run the last test again.
228	open_and_dump_file $testfile $env $t1 \
229	    $checkfunc dump_file_direction "-first" "-next"
230
231	if { [string compare $omethod "-recno"] != 0 } {
232		filesort $t1 $t3
233	}
234
235	error_check_good Test015:diff($t3,$t2) \
236	    [filecmp $t3 $t2] 0
237
238	# Now, reopen the file and run the last test again in the
239	# reverse direction.
240	puts "\tTest015.d: close, open, and dump file in reverse direction"
241	open_and_dump_file $testfile $env $t1 \
242	    $checkfunc dump_file_direction "-last" "-prev"
243
244	if { [string compare $omethod "-recno"] != 0 } {
245		filesort $t1 $t3
246	}
247
248	error_check_good Test015:diff($t3,$t2) \
249	    [filecmp $t3 $t2] 0
250
251	unset dvals
252	set testdir $orig_tdir
253}
254
255# Check function for test015; keys and data are identical
256proc test015.check { key data } {
257	global dvals
258
259	error_check_good key"$key"_exists [info exists dvals($key)] 1
260	binary scan $data "c[string length $data]" a
261	binary scan $dvals($key) "c[string length $dvals($key)]" b
262	error_check_good "mismatch on padding for key $key" $a $b
263}
264
265proc test015.fixed.check { key data } {
266	global dvals
267	global fixed_len
268
269	error_check_good key"$key"_exists [info exists dvals($key)] 1
270	if { [string length $data] > $fixed_len } {
271		error_check_bad \
272		    "data length:[string length $data] \
273		    for fixed:$fixed_len" 1 1
274	}
275	puts "$data : $dvals($key)"
276	error_check_good compare_data($data,$dvals($key) \
277	    $dvals($key) $data
278}
279