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