1# See the file LICENSE for redistribution information.
2#
3# Copyright (c) 1996,2008 Oracle.  All rights reserved.
4#
5# $Id: memp001.tcl,v 12.7 2008/01/08 20:58:53 bostic Exp $
6#
7
8# TEST	memp001
9# TEST	Randomly updates pages.
10proc memp001 { } {
11
12	memp001_body 1 ""
13	memp001_body 3 ""
14	memp001_body 1 -private
15	memp001_body 3 -private
16	memp001_body 1 "-system_mem -shm_key 1"
17	memp001_body 3 "-system_mem -shm_key 1"
18
19}
20
21proc memp001_body { ncache flags } {
22	source ./include.tcl
23	global rand_init
24
25	set nfiles 5
26	set iter 500
27	set psize 512
28	set cachearg "-cachesize {0 400000 $ncache}"
29
30	puts \
31"Memp001: { $flags } random update $iter iterations on $nfiles files."
32	#
33	# Check if this platform supports this set of flags
34	#
35	if { [mem_chk $flags] == 1 } {
36		return
37	}
38
39	env_cleanup $testdir
40	puts "\tMemp001.a: Create env with $ncache caches"
41	set env [eval {berkdb_env -create -mode 0644} \
42	    $cachearg {-home $testdir} $flags]
43	error_check_good env_open [is_valid_env $env] TRUE
44
45	#
46	# Do a simple mpool_stat call to verify the number of caches
47	# just to exercise the stat code.
48	set stat [$env mpool_stat]
49	set str "Number of caches"
50	set checked 0
51	foreach statpair $stat {
52		if { $checked == 1 } {
53			break
54		}
55		if { [is_substr [lindex $statpair 0] $str] != 0} {
56			set checked 1
57			error_check_good ncache [lindex $statpair 1] $ncache
58		}
59	}
60	error_check_good checked $checked 1
61
62	# Open N memp files
63	puts "\tMemp001.b: Create $nfiles mpool files"
64	for {set i 1} {$i <= $nfiles} {incr i} {
65		set fname "data_file.$i"
66		file_create $testdir/$fname 50 $psize
67
68		set mpools($i) \
69		    [$env mpool -create -pagesize $psize -mode 0644 $fname]
70		error_check_good mp_open [is_substr $mpools($i) $env.mp] 1
71	}
72
73	# Now, loop, picking files at random
74	berkdb srand $rand_init
75	puts "\tMemp001.c: Random page replacement loop"
76	for {set i 0} {$i < $iter} {incr i} {
77		set mpool $mpools([berkdb random_int 1 $nfiles])
78		set p(1) [get_range $mpool 10]
79		set p(2) [get_range $mpool 10]
80		set p(3) [get_range $mpool 10]
81		set p(1) [replace $mpool $p(1)]
82		set p(3) [replace $mpool $p(3)]
83		set p(4) [get_range $mpool 20]
84		set p(4) [replace $mpool $p(4)]
85		set p(5) [get_range $mpool 10]
86		set p(6) [get_range $mpool 20]
87		set p(7) [get_range $mpool 10]
88		set p(8) [get_range $mpool 20]
89		set p(5) [replace $mpool $p(5)]
90		set p(6) [replace $mpool $p(6)]
91		set p(9) [get_range $mpool 40]
92		set p(9) [replace $mpool $p(9)]
93		set p(10) [get_range $mpool 40]
94		set p(7) [replace $mpool $p(7)]
95		set p(8) [replace $mpool $p(8)]
96		set p(9) [replace $mpool $p(9) -dirty]
97		set p(10) [replace $mpool $p(10)]
98		#
99		# We now need to put all the pages we have here or
100		# else they end up pinned.
101		#
102		for {set x 1} { $x <= 10} {incr x} {
103			error_check_good pgput [$p($x) put] 0
104		}
105	}
106
107	# Close N memp files, close the environment.
108	puts "\tMemp001.d: Close mpools"
109	for {set i 1} {$i <= $nfiles} {incr i} {
110		error_check_good memp_close:$mpools($i) [$mpools($i) close] 0
111	}
112	error_check_good envclose [$env close] 0
113
114	for {set i 1} {$i <= $nfiles} {incr i} {
115		fileremove -f $testdir/data_file.$i
116	}
117}
118
119proc file_create { fname nblocks blocksize } {
120	set fid [open $fname w]
121	for {set i 0} {$i < $nblocks} {incr i} {
122		seek $fid [expr $i * $blocksize] start
123		puts -nonewline $fid $i
124	}
125	seek $fid [expr $nblocks * $blocksize - 1]
126
127	# We don't end the file with a newline, because some platforms (like
128	# Windows) emit CR/NL.  There does not appear to be a BINARY open flag
129	# that prevents this.
130	puts -nonewline $fid "Z"
131	close $fid
132
133	# Make sure it worked
134	if { [file size $fname] != $nblocks * $blocksize } {
135		error "FAIL: file_create could not create correct file size"
136	}
137}
138
139proc get_range { mpool max } {
140	set pno [berkdb random_int 0 $max]
141	set p [eval $mpool get -dirty $pno]
142	error_check_good page [is_valid_page $p $mpool] TRUE
143	set got [$p pgnum]
144	if { $got != $pno } {
145		puts "Get_range: Page mismatch page |$pno| val |$got|"
146	}
147	set ret [$p init "Page is pinned by [pid]"]
148	error_check_good page_init $ret 0
149
150	return $p
151}
152
153proc replace { mpool p { args "" } } {
154	set pgno [$p pgnum]
155
156	set ret [$p init "Page is unpinned by [pid]"]
157	error_check_good page_init $ret 0
158
159	set ret [$p put]
160	error_check_good page_put $ret 0
161
162	set p2 [eval $mpool get $args $pgno]
163	error_check_good page [is_valid_page $p2 $mpool] TRUE
164
165	return $p2
166}
167
168proc mem_chk { flags } {
169	source ./include.tcl
170	global errorCode
171
172	# Open the memp with region init specified
173	env_cleanup $testdir
174
175	set cachearg " -cachesize {0 400000 3}"
176	set ret [catch {eval {berkdb_env_noerr -create -mode 0644}\
177	    $cachearg {-region_init -home $testdir} $flags} env]
178	if { $ret != 0 } {
179		# If the env open failed, it may be because we're on a platform
180		# such as HP-UX 10 that won't support mutexes in shmget memory.
181		# Or QNX, which doesn't support system memory at all.
182		# Verify that the return value was EINVAL or EOPNOTSUPP
183		# and bail gracefully.
184		error_check_good is_shm_test [is_substr $flags -system_mem] 1
185		error_check_good returned_error [expr \
186		    [is_substr $errorCode EINVAL] || \
187		    [is_substr $errorCode EOPNOTSUPP]] 1
188		puts "Warning:\
189		     platform does not support mutexes in shmget memory."
190		puts "Skipping shared memory mpool test."
191		return 1
192	}
193	error_check_good env_open [is_valid_env $env] TRUE
194	error_check_good env_close [$env close] 0
195	env_cleanup $testdir
196
197	return 0
198}
199