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