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