1N/A#!/usr/bin/perl
1N/A#
1N/A# Check ->defer and ->flush methods
1N/A#
1N/A# This is the old version, which you used in the past when
1N/A# there was a defer buffer separate from the read cache.
1N/A# There isn't any longer.
1N/A#
1N/A
1N/Ause POSIX 'SEEK_SET';
1N/Amy $file = "tf$$.txt";
1N/A$: = Tie::File::_default_recsep();
1N/Amy $data = "rec0$:rec1$:rec2$:";
1N/Amy ($o, $n);
1N/A
1N/Aprint "1..79\n";
1N/A
1N/Amy $N = 1;
1N/Ause Tie::File;
1N/Aprint "ok $N\n"; $N++;
1N/A
1N/Aopen F, "> $file" or die $!;
1N/Abinmode F;
1N/Aprint F $data;
1N/Aclose F;
1N/A$o = tie @a, 'Tie::File', $file;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/A
1N/A# (3-6) Deferred storage
1N/A$o->defer;
1N/A$a[3] = "rec3";
1N/Acheck_contents($data); # nothing written yet
1N/A$a[4] = "rec4";
1N/Acheck_contents($data); # nothing written yet
1N/A
1N/A# (7-8) Flush
1N/A$o->flush;
1N/Acheck_contents($data . "rec3$:rec4$:"); # now it's written
1N/A
1N/A# (9-12) Deferred writing disabled?
1N/A$a[3] = "rec9";
1N/Acheck_contents("${data}rec9$:rec4$:");
1N/A$a[4] = "rec8";
1N/Acheck_contents("${data}rec9$:rec8$:");
1N/A
1N/A# (13-18) Now let's try two batches of records
1N/A$#a = 2;
1N/A$o->defer;
1N/A$a[0] = "record0";
1N/Acheck_contents($data); # nothing written yet
1N/A$a[2] = "record2";
1N/Acheck_contents($data); # nothing written yet
1N/A$o->flush;
1N/Acheck_contents("record0$:rec1$:record2$:");
1N/A
1N/A# (19-22) Deferred writing past the end of the file
1N/A$o->defer;
1N/A$a[4] = "record4";
1N/Acheck_contents("record0$:rec1$:record2$:");
1N/A$o->flush;
1N/Acheck_contents("record0$:rec1$:record2$:$:record4$:");
1N/A
1N/A
1N/A# (23-26) Now two long batches
1N/A$o->defer;
1N/Afor (0..2, 4..6) {
1N/A $a[$_] = "r$_";
1N/A}
1N/Acheck_contents("record0$:rec1$:record2$:$:record4$:");
1N/A$o->flush;
1N/Acheck_contents(join $:, "r0".."r2", "", "r4".."r6", "");
1N/A
1N/A# (27-30) Now let's make sure that discarded writes are really discarded
1N/A# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
1N/A# filling it up
1N/A$o->defer;
1N/Afor (0, 3, 7) {
1N/A $a[$_] = "discarded$_";
1N/A}
1N/Acheck_contents(join $:, "r0".."r2", "", "r4".."r6", "");
1N/A$o->discard;
1N/Acheck_contents(join $:, "r0".."r2", "", "r4".."r6", "");
1N/A
1N/A################################################################
1N/A#
1N/A# Now we're going to test the results of a small memory limit
1N/A#
1N/A#
1N/Aundef $o; untie @a;
1N/A$data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long
1N/Aopen F, "> $file" or die $!;
1N/Abinmode F;
1N/Aprint F $data;
1N/Aclose F;
1N/A
1N/A# Limit cache+buffer size to 47 bytes
1N/Amy $MAX = 47;
1N/A# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
1N/Amy $BUF = 20;
1N/A# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
1N/A$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/A
1N/A# (31-32) Fill up the read cache
1N/Amy @z;
1N/A@z = @a;
1N/A# the cache now contains records 3,4,5,6,7.
1N/Acheck_caches({map(($_ => "record$_$:"), 3..7)},
1N/A {});
1N/A
1N/A# (33-44) See if overloading the defer starts by flushing the read cache
1N/A# and then flushes out the defer
1N/A$o->defer;
1N/A$a[0] = "recordA"; # That should flush record 3 from the cache
1N/Acheck_caches({map(($_ => "record$_$:"), 4..7)},
1N/A {0 => "recordA$:"});
1N/Acheck_contents($data);
1N/A
1N/A$a[1] = "recordB"; # That should flush record 4 from the cache
1N/Acheck_caches({map(($_ => "record$_$:"), 5..7)},
1N/A {0 => "recordA$:",
1N/A 1 => "recordB$:"});
1N/Acheck_contents($data);
1N/A
1N/A$a[2] = "recordC"; # That should flush the whole darn defer
1N/A# This shouldn't change the cache contents
1N/Acheck_caches({map(($_ => "record$_$:"), 5..7)},
1N/A {}); # URRRP
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A$a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED
1N/Acheck_caches({map(($_ => "record$_$:"), 5..7)},
1N/A {3 => "recordD$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A# Check readcache-deferbuffer interactions
1N/A
1N/A# (45-47) This should remove outdated data from the read cache
1N/A$a[5] = "recordE";
1N/Acheck_caches({6 => "record6$:", 7 => "record7$:"},
1N/A {3 => "recordD$:", 5 => "recordE$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A# (48-51) This should read back out of the defer buffer
1N/A# without adding anything to the read cache
1N/Amy $z;
1N/A$z = $a[5];
1N/Aprint $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++;
1N/Acheck_caches({6 => "record6$:", 7 => "record7$:"},
1N/A {3 => "recordD$:", 5 => "recordE$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A# (52-55) This should repopulate the read cache with a new record
1N/A$z = $a[0];
1N/Aprint $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++;
1N/Acheck_caches({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"},
1N/A {3 => "recordD$:", 5 => "recordE$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A# (56-59) This should flush the LRU record from the read cache
1N/A$z = $a[4];
1N/Aprint $z eq "record4" ? "ok $N\n" : "not ok $N\n"; $N++;
1N/Acheck_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"},
1N/A {3 => "recordD$:", 5 => "recordE$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A record3 record4 record5 record6 record7)) . "$:");
1N/A
1N/A# (60-63) This should FLUSH the deferred buffer
1N/A$z = splice @a, 3, 1, "recordZ";
1N/Aprint $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++;
1N/Acheck_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
1N/A {});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/A
1N/A# (64-66) We should STILL be in deferred writing mode
1N/A$a[5] = "recordX";
1N/Acheck_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
1N/A {5 => "recordX$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/A
1N/A# Fill up the defer buffer again
1N/A$a[4] = "recordP";
1N/A# (67-69) This should OVERWRITE the existing deferred record
1N/A# and NOT flush the buffer
1N/A$a[5] = "recordQ";
1N/Acheck_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
1N/A {5 => "recordQ$:", 4 => "recordP$:"});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/A
1N/A# (70-72) Discard should just dump the whole deferbuffer
1N/A$o->discard;
1N/Acheck_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
1N/A {});
1N/Acheck_contents(join("$:", qw(recordA recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/A
1N/A# (73-75) NOW we are out of deferred writing mode
1N/A$a[0] = "recordF";
1N/Acheck_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"},
1N/A {});
1N/Acheck_contents(join("$:", qw(recordF recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/A
1N/A# (76-79) Last call--untying the array should flush the deferbuffer
1N/A$o->defer;
1N/A$a[0] = "flushed";
1N/Acheck_caches({7 => "record7$:", 3 => "recordZ$:"},
1N/A {0 => "flushed$:" });
1N/Acheck_contents(join("$:", qw(recordF recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:");
1N/Aundef $o;
1N/Auntie @a;
1N/A# (79) We can't use check_contents any more, because the object is dead
1N/Aopen F, "< $file" or die;
1N/Abinmode F;
1N/A{ local $/ ; $z = <F> }
1N/Aclose F;
1N/Amy $x = join("$:", qw(flushed recordB recordC
1N/A recordZ record4 recordE record6 record7)) . "$:";
1N/Aif ($z eq $x) {
1N/A print "ok $N\n";
1N/A} else {
1N/A my $msg = ctrlfix("expected <$x>, got <$z>");
1N/A print "not ok $N \# $msg\n";
1N/A}
1N/A$N++;
1N/A
1N/A################################################################
1N/A
1N/A
1N/Asub check_caches {
1N/A my ($xcache, $xdefer) = @_;
1N/A
1N/A# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
1N/A# print $integrity ? "ok $N\n" : "not ok $N\n";
1N/A# $N++;
1N/A
1N/A my $good = 1;
1N/A
1N/A # Copy the contents of the cache into a regular hash
1N/A my %cache;
1N/A for my $k ($o->{cache}->ckeys) {
1N/A $cache{$k} = $o->{cache}->_produce($k);
1N/A }
1N/A
1N/A $good &&= hash_equal(\%cache, $xcache, "true cache", "expected cache");
1N/A $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
1N/A print $good ? "ok $N\n" : "not ok $N\n";
1N/A $N++;
1N/A}
1N/A
1N/Asub hash_equal {
1N/A my ($a, $b, $ha, $hb) = @_;
1N/A $ha = 'first hash' unless defined $ha;
1N/A $hb = 'second hash' unless defined $hb;
1N/A
1N/A my $good = 1;
1N/A my %b_seen;
1N/A
1N/A for my $k (keys %$a) {
1N/A if (! exists $b->{$k}) {
1N/A print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
1N/A $good = 0;
1N/A } elsif ($b->{$k} ne $a->{$k}) {
1N/A print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
1N/A $b_seen{$k} = 1;
1N/A $good = 0;
1N/A } else {
1N/A $b_seen{$k} = 1;
1N/A }
1N/A }
1N/A
1N/A for my $k (keys %$b) {
1N/A unless ($b_seen{$k}) {
1N/A print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
1N/A $good = 0;
1N/A }
1N/A }
1N/A
1N/A $good;
1N/A}
1N/A
1N/A
1N/Asub check_contents {
1N/A my $x = shift;
1N/A
1N/A my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
1N/A print $integrity ? "ok $N\n" : "not ok $N\n";
1N/A $N++;
1N/A
1N/A local *FH = $o->{fh};
1N/A seek FH, 0, SEEK_SET;
1N/A
1N/A my $a;
1N/A { local $/; $a = <FH> }
1N/A $a = "" unless defined $a;
1N/A if ($a eq $x) {
1N/A print "ok $N\n";
1N/A } else {
1N/A my $msg = ctrlfix("# expected <$x>, got <$a>");
1N/A print "not ok $N\n$msg\n";
1N/A }
1N/A $N++;
1N/A}
1N/A
1N/Asub ctrlfix {
1N/A local $_ = shift;
1N/A s/\n/\\n/g;
1N/A s/\r/\\r/g;
1N/A $_;
1N/A}
1N/A
1N/AEND {
1N/A undef $o;
1N/A untie @a if tied @a;
1N/A 1 while unlink $file;
1N/A}
1N/A