1#!/usr/bin/perl 2 3use strict; 4use warnings; 5 6# 7# Check ->defer and ->flush methods 8# 9# This is the old version, which you used in the past when 10# there was a defer buffer separate from the read cache. 11# There isn't any longer. 12# 13 14use POSIX 'SEEK_SET'; 15my $file = "tf30-$$.txt"; 16$: = Tie::File::_default_recsep(); 17my $data = "rec0$:rec1$:rec2$:"; 18my ($o, $n); 19 20print "1..79\n"; 21 22my $N = 1; 23use Tie::File; 24print "ok $N\n"; $N++; 25 26open F, '>', $file or die $!; 27binmode F; 28print F $data; 29close F; 30 31my @a; 32$o = tie @a, 'Tie::File', $file; 33print $o ? "ok $N\n" : "not ok $N\n"; 34$N++; 35 36# (3-6) Deferred storage 37$o->defer; 38$a[3] = "rec3"; 39check_contents($data); # nothing written yet 40$a[4] = "rec4"; 41check_contents($data); # nothing written yet 42 43# (7-8) Flush 44$o->flush; 45check_contents($data . "rec3$:rec4$:"); # now it's written 46 47# (9-12) Deferred writing disabled? 48$a[3] = "rec9"; 49check_contents("${data}rec9$:rec4$:"); 50$a[4] = "rec8"; 51check_contents("${data}rec9$:rec8$:"); 52 53# (13-18) Now let's try two batches of records 54$#a = 2; 55$o->defer; 56$a[0] = "record0"; 57check_contents($data); # nothing written yet 58$a[2] = "record2"; 59check_contents($data); # nothing written yet 60$o->flush; 61check_contents("record0$:rec1$:record2$:"); 62 63# (19-22) Deferred writing past the end of the file 64$o->defer; 65$a[4] = "record4"; 66check_contents("record0$:rec1$:record2$:"); 67$o->flush; 68check_contents("record0$:rec1$:record2$:$:record4$:"); 69 70 71# (23-26) Now two long batches 72$o->defer; 73for (0..2, 4..6) { 74 $a[$_] = "r$_"; 75} 76check_contents("record0$:rec1$:record2$:$:record4$:"); 77$o->flush; 78check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); 79 80# (27-30) Now let's make sure that discarded writes are really discarded 81# We have a 2Mib buffer here, so we can be sure that we aren't accidentally 82# filling it up 83$o->defer; 84for (0, 3, 7) { 85 $a[$_] = "discarded$_"; 86} 87check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); 88$o->discard; 89check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); 90 91################################################################ 92# 93# Now we're going to test the results of a small memory limit 94# 95# 96undef $o; untie @a; 97$data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long 98open F, '>', $file or die $!; 99binmode F; 100print F $data; 101close F; 102 103# Limit cache+buffer size to 47 bytes 104my $MAX = 47; 105# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems 106my $BUF = 20; 107# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems 108$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF; 109print $o ? "ok $N\n" : "not ok $N\n"; 110$N++; 111 112# (31-32) Fill up the read cache 113my @z; 114@z = @a; 115# the cache now contains records 3,4,5,6,7. 116check_caches({map(($_ => "record$_$:"), 3..7)}, 117 {}); 118 119# (33-44) See if overloading the defer starts by flushing the read cache 120# and then flushes out the defer 121$o->defer; 122$a[0] = "recordA"; # That should flush record 3 from the cache 123check_caches({map(($_ => "record$_$:"), 4..7)}, 124 {0 => "recordA$:"}); 125check_contents($data); 126 127$a[1] = "recordB"; # That should flush record 4 from the cache 128check_caches({map(($_ => "record$_$:"), 5..7)}, 129 {0 => "recordA$:", 130 1 => "recordB$:"}); 131check_contents($data); 132 133$a[2] = "recordC"; # That should flush the whole darn defer 134# This shouldn't change the cache contents 135check_caches({map(($_ => "record$_$:"), 5..7)}, 136 {}); # URRRP 137check_contents(join("$:", qw(recordA recordB recordC 138 record3 record4 record5 record6 record7)) . "$:"); 139 140$a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED 141check_caches({map(($_ => "record$_$:"), 5..7)}, 142 {3 => "recordD$:"}); 143check_contents(join("$:", qw(recordA recordB recordC 144 record3 record4 record5 record6 record7)) . "$:"); 145 146# Check readcache-deferbuffer interactions 147 148# (45-47) This should remove outdated data from the read cache 149$a[5] = "recordE"; 150check_caches({6 => "record6$:", 7 => "record7$:"}, 151 {3 => "recordD$:", 5 => "recordE$:"}); 152check_contents(join("$:", qw(recordA recordB recordC 153 record3 record4 record5 record6 record7)) . "$:"); 154 155# (48-51) This should read back out of the defer buffer 156# without adding anything to the read cache 157my $z; 158$z = $a[5]; 159print $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++; 160check_caches({6 => "record6$:", 7 => "record7$:"}, 161 {3 => "recordD$:", 5 => "recordE$:"}); 162check_contents(join("$:", qw(recordA recordB recordC 163 record3 record4 record5 record6 record7)) . "$:"); 164 165# (52-55) This should repopulate the read cache with a new record 166$z = $a[0]; 167print $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++; 168check_caches({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"}, 169 {3 => "recordD$:", 5 => "recordE$:"}); 170check_contents(join("$:", qw(recordA recordB recordC 171 record3 record4 record5 record6 record7)) . "$:"); 172 173# (56-59) This should flush the LRU record from the read cache 174$z = $a[4]; 175print $z eq "record4" ? "ok $N\n" : "not ok $N\n"; $N++; 176check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"}, 177 {3 => "recordD$:", 5 => "recordE$:"}); 178check_contents(join("$:", qw(recordA recordB recordC 179 record3 record4 record5 record6 record7)) . "$:"); 180 181# (60-63) This should FLUSH the deferred buffer 182$z = splice @a, 3, 1, "recordZ"; 183print $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++; 184check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, 185 {}); 186check_contents(join("$:", qw(recordA recordB recordC 187 recordZ record4 recordE record6 record7)) . "$:"); 188 189# (64-66) We should STILL be in deferred writing mode 190$a[5] = "recordX"; 191check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, 192 {5 => "recordX$:"}); 193check_contents(join("$:", qw(recordA recordB recordC 194 recordZ record4 recordE record6 record7)) . "$:"); 195 196# Fill up the defer buffer again 197$a[4] = "recordP"; 198# (67-69) This should OVERWRITE the existing deferred record 199# and NOT flush the buffer 200$a[5] = "recordQ"; 201check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, 202 {5 => "recordQ$:", 4 => "recordP$:"}); 203check_contents(join("$:", qw(recordA recordB recordC 204 recordZ record4 recordE record6 record7)) . "$:"); 205 206# (70-72) Discard should just dump the whole deferbuffer 207$o->discard; 208check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, 209 {}); 210check_contents(join("$:", qw(recordA recordB recordC 211 recordZ record4 recordE record6 record7)) . "$:"); 212 213# (73-75) NOW we are out of deferred writing mode 214$a[0] = "recordF"; 215check_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"}, 216 {}); 217check_contents(join("$:", qw(recordF recordB recordC 218 recordZ record4 recordE record6 record7)) . "$:"); 219 220# (76-79) Last call--untying the array should flush the deferbuffer 221$o->defer; 222$a[0] = "flushed"; 223check_caches({7 => "record7$:", 3 => "recordZ$:"}, 224 {0 => "flushed$:" }); 225check_contents(join("$:", qw(recordF recordB recordC 226 recordZ record4 recordE record6 record7)) . "$:"); 227undef $o; 228untie @a; 229# (79) We can't use check_contents any more, because the object is dead 230open F, '<', $file or die; 231binmode F; 232{ local $/ ; $z = <F> } 233close F; 234my $x = join("$:", qw(flushed recordB recordC 235 recordZ record4 recordE record6 record7)) . "$:"; 236if ($z eq $x) { 237 print "ok $N\n"; 238} else { 239 my $msg = ctrlfix("expected <$x>, got <$z>"); 240 print "not ok $N \# $msg\n"; 241} 242$N++; 243 244################################################################ 245 246 247sub check_caches { 248 my ($xcache, $xdefer) = @_; 249 250# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); 251# print $integrity ? "ok $N\n" : "not ok $N\n"; 252# $N++; 253 254 my $good = 1; 255 256 # Copy the contents of the cache into a regular hash 257 my %cache; 258 for my $k ($o->{cache}->ckeys) { 259 $cache{$k} = $o->{cache}->_produce($k); 260 } 261 262 $good &&= hash_equal(\%cache, $xcache, "true cache", "expected cache"); 263 $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer"); 264 print $good ? "ok $N\n" : "not ok $N\n"; 265 $N++; 266} 267 268sub hash_equal { 269 my ($a, $b, $ha, $hb) = @_; 270 $ha = 'first hash' unless defined $ha; 271 $hb = 'second hash' unless defined $hb; 272 273 my $good = 1; 274 my %b_seen; 275 276 for my $k (keys %$a) { 277 if (! exists $b->{$k}) { 278 print ctrlfix("# Key $k is in $ha but not $hb"), "\n"; 279 $good = 0; 280 } elsif ($b->{$k} ne $a->{$k}) { 281 print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n"; 282 $b_seen{$k} = 1; 283 $good = 0; 284 } else { 285 $b_seen{$k} = 1; 286 } 287 } 288 289 for my $k (keys %$b) { 290 unless ($b_seen{$k}) { 291 print ctrlfix("# Key $k is in $hb but not $ha"), "\n"; 292 $good = 0; 293 } 294 } 295 296 $good; 297} 298 299 300sub check_contents { 301 my $x = shift; 302 303 my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); 304 print $integrity ? "ok $N\n" : "not ok $N\n"; 305 $N++; 306 307 local *FH = $o->{fh}; 308 seek FH, 0, SEEK_SET; 309 310 my $a; 311 { local $/; $a = <FH> } 312 $a = "" unless defined $a; 313 if ($a eq $x) { 314 print "ok $N\n"; 315 } else { 316 my $msg = ctrlfix("# expected <$x>, got <$a>"); 317 print "not ok $N\n$msg\n"; 318 } 319 $N++; 320} 321 322sub ctrlfix { 323 local $_ = shift; 324 s/\n/\\n/g; 325 s/\r/\\r/g; 326 $_; 327} 328 329END { 330 undef $o; 331 untie @a if tied @a; 332 1 while unlink $file; 333} 334 335