summaryrefslogtreecommitdiff
path: root/lib/Tie/File
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Tie/File')
-rw-r--r--lib/Tie/File/t/00_version.t10
-rw-r--r--lib/Tie/File/t/15_pushpop.t1
-rw-r--r--lib/Tie/File/t/17_misc_meth.t68
-rw-r--r--lib/Tie/File/t/22_autochomp.t12
-rw-r--r--lib/Tie/File/t/30_defer.t319
-rw-r--r--lib/Tie/File/t/31_autodefer.t65
-rw-r--r--lib/Tie/File/t/32_defer_misc.t230
7 files changed, 688 insertions, 17 deletions
diff --git a/lib/Tie/File/t/00_version.t b/lib/Tie/File/t/00_version.t
index 8a154b1b72..5d950b9c20 100644
--- a/lib/Tie/File/t/00_version.t
+++ b/lib/Tie/File/t/00_version.t
@@ -2,14 +2,16 @@
print "1..1\n";
+my $testversion = "0.21";
use Tie::File;
-if ($Tie::File::VERSION != 0.20) {
+if ($Tie::File::VERSION != $testversion) {
print STDERR "
-WHOA THERE!!
-You seem to be running version $Tie::File::VERSION of the module against
-version 0.20 of the test suite!
+*** WHOA THERE!!! ***
+
+You seem to be running version $Tie::File::VERSION of the module
+against version $testversion of the test suite!
None of the other test results will be reliable.
";
diff --git a/lib/Tie/File/t/15_pushpop.t b/lib/Tie/File/t/15_pushpop.t
index cc09b02d5d..4b6d1bc959 100644
--- a/lib/Tie/File/t/15_pushpop.t
+++ b/lib/Tie/File/t/15_pushpop.t
@@ -28,7 +28,6 @@ $N++;
my ($n, @r);
-
# (3-11) PUSH tests
$n = push @a, "rec0", "rec1", "rec2";
check_contents($data);
diff --git a/lib/Tie/File/t/17_misc_meth.t b/lib/Tie/File/t/17_misc_meth.t
index 87749616fc..b7543898d4 100644
--- a/lib/Tie/File/t/17_misc_meth.t
+++ b/lib/Tie/File/t/17_misc_meth.t
@@ -8,7 +8,7 @@ my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
1 while unlink $file;
-print "1..24\n";
+print "1..35\n";
my $N = 1;
use Tie::File;
@@ -30,7 +30,7 @@ check_contents("$:$:$:$:");
@a = ();
check_contents("");
-# (11-16) EXISTS
+# (11-20) EXISTS
if ($] >= 5.006) {
eval << 'TESTS';
print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
@@ -48,28 +48,52 @@ print exists $a[1] ? "ok $N\n" : "ok $N\n";
$N++;
print exists $a[2] ? "ok $N\n" : "not ok $N\n";
$N++;
+print exists $a[-1] ? "ok $N\n" : "not ok $N\n";
+$N++;
+print exists $a[-2] ? "ok $N\n" : "not ok $N\n";
+$N++;
+print exists $a[-3] ? "ok $N\n" : "not ok $N\n";
+$N++;
+print !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
+$N++;
TESTS
} else { # perl 5.005 doesn't have exists $array[1]
- for (11..16) {
+ for (11..20) {
print "ok $_ \# skipped (no exists for arrays)\n";
$N++;
}
}
-# (17-24) DELETE
+my $del;
+
+# (21-35) DELETE
if ($] >= 5.006) {
eval << 'TESTS';
-delete $a[0];
+$del = delete $a[0];
check_contents("$:$:GIVE ME PIE$:");
-delete $a[2];
+# 20020317 Through 0.20, the 'delete' function returned the wrong values.
+expect($del, "I like pie.");
+$del = delete $a[2];
check_contents("$:$:");
-delete $a[0];
+expect($del, "GIVE ME PIE");
+$del = delete $a[0];
check_contents("$:$:");
-delete $a[1];
+expect($del, "");
+$del = delete $a[1];
check_contents("$:");
+expect($del, "");
+
+# 20020317 Through 0.20, we had a bug where deleting an element past the
+# end of the array would actually extend the array to that length.
+$del = delete $a[4];
+check_contents("$:");
+expect($del, undef);
+
+
+
TESTS
} else { # perl 5.005 doesn't have delete $array[1]
- for (17..24) {
+ for (21..35) {
print "ok $_ \# skipped (no delete for arrays)\n";
$N++;
}
@@ -87,13 +111,37 @@ sub check_contents {
print "ok $N\n";
} else {
ctrlfix(my $msg = "# expected <$x>, got <$a>");
- print "not ok $N\n$msg\n";
+ print "not ok $N # $msg\n";
}
$N++;
print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
$N++;
}
+sub expect {
+ if (@_ == 1) {
+ print $_[0] ? "ok $N\n" : "not ok $N\n";
+ } elsif (@_ == 2) {
+ my ($a, $x) = @_;
+ if (! defined($a) && ! defined($x)) { print "ok $N\n" }
+ elsif ( defined($a) && ! defined($x)) {
+ ctrlfix(my $msg = "expected UNDEF, got <$a>");
+ print "not ok $N \# $msg\n";
+ }
+ elsif (! defined($a) && defined($x)) {
+ ctrlfix(my $msg = "expected <$x>, got UNDEF");
+ print "not ok $N \# $msg\n";
+ } elsif ($a eq $x) { print "ok $N\n" }
+ else {
+ ctrlfix(my $msg = "expected <$x>, got <$a>");
+ print "not ok $N \# $msg\n";
+ }
+ } else {
+ die "expect() got ", scalar(@_), " args, should have been 1 or 2";
+ }
+ $N++;
+}
+
sub ctrlfix {
for (@_) {
s/\n/\\n/g;
diff --git a/lib/Tie/File/t/22_autochomp.t b/lib/Tie/File/t/22_autochomp.t
index 70974d4b49..caa7150e0c 100644
--- a/lib/Tie/File/t/22_autochomp.t
+++ b/lib/Tie/File/t/22_autochomp.t
@@ -141,10 +141,18 @@ sub expect {
print $_[0] ? "ok $N\n" : "not ok $N\n";
} elsif (@_ == 2) {
my ($a, $x) = @_;
- if ($a eq $x) { print "ok $N\n" }
+ if (! defined($a) && ! defined($x)) { print "ok $N\n" }
+ elsif ( defined($a) && ! defined($x)) {
+ ctrlfix(my $msg = "expected UNDEF, got <$a>");
+ print "not ok $N \# $msg\n";
+ }
+ elsif (! defined($a) && defined($x)) {
+ ctrlfix(my $msg = "expected <$x>, got UNDEF");
+ print "not ok $N \# $msg\n";
+ } elsif ($a eq $x) { print "ok $N\n" }
else {
ctrlfix(my $msg = "expected <$x>, got <$a>");
- print "not ok $N # $msg\n";
+ print "not ok $N \# $msg\n";
}
} else {
die "expect() got ", scalar(@_), " args, should have been 1 or 2";
diff --git a/lib/Tie/File/t/30_defer.t b/lib/Tie/File/t/30_defer.t
new file mode 100644
index 0000000000..4c32825fe2
--- /dev/null
+++ b/lib/Tie/File/t/30_defer.t
@@ -0,0 +1,319 @@
+#!/usr/bin/perl
+#
+# Check ->defer and ->flush methods
+#
+
+use POSIX 'SEEK_SET';
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+my $data = "rec0$:rec1$:rec2$:";
+my ($o, $n);
+
+print "1..79\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+$o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# (3-6) Deferred storage
+$o->defer;
+$a[3] = "rec3";
+check_contents($data); # nothing written yet
+$a[4] = "rec4";
+check_contents($data); # nothing written yet
+
+# (7-8) Flush
+$o->flush;
+check_contents($data . "rec3$:rec4$:"); # now it's written
+
+# (9-12) Deferred writing disabled?
+$a[3] = "rec9";
+check_contents("${data}rec9$:rec4$:");
+$a[4] = "rec8";
+check_contents("${data}rec9$:rec8$:");
+
+# (13-18) Now let's try two batches of records
+$#a = 2;
+$o->defer;
+$a[0] = "record0";
+check_contents($data); # nothing written yet
+$a[2] = "record2";
+check_contents($data); # nothing written yet
+$o->flush;
+check_contents("record0$:rec1$:record2$:");
+
+# (19-22) Deferred writing past the end of the file
+$o->defer;
+$a[4] = "record4";
+check_contents("record0$:rec1$:record2$:");
+$o->flush;
+check_contents("record0$:rec1$:record2$:$:record4$:");
+
+
+# (23-26) Now two long batches
+$o->defer;
+for (0..2, 4..6) {
+ $a[$_] = "r$_";
+}
+check_contents("record0$:rec1$:record2$:$:record4$:");
+$o->flush;
+check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
+
+# (27-30) Now let's make sure that discarded writes are really discarded
+# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
+# filling it up
+$o->defer;
+for (0, 3, 7) {
+ $a[$_] = "discarded$_";
+}
+check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
+$o->discard;
+check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
+
+################################################################
+#
+# Now we're going to test the results of a small memory limit
+#
+#
+undef $o; untie @a;
+$data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+
+# Limit cache+buffer size to 47 bytes
+my $MAX = 47;
+# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
+my $BUF = 20;
+# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
+$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# (31-32) Fill up the read cache
+my @z;
+@z = @a;
+# the cache now contains records 3,4,5,6,7.
+check_caches({map(($_ => "record$_$:"), 3..7)},
+ {});
+
+# (33-44) See if overloading the defer starts by flushing the read cache
+# and then flushes out the defer
+$o->defer;
+$a[0] = "recordA"; # That should flush record 3 from the cache
+check_caches({map(($_ => "record$_$:"), 4..7)},
+ {0 => "recordA$:"});
+check_contents($data);
+
+$a[1] = "recordB"; # That should flush record 4 from the cache
+check_caches({map(($_ => "record$_$:"), 5..7)},
+ {0 => "recordA$:",
+ 1 => "recordB$:"});
+check_contents($data);
+
+$a[2] = "recordC"; # That should flush the whole darn defer
+# Flushing the defer requires looking up the true lengths of records
+# 0..2, which flushes out the read cache, leaving only 1..2 there.
+# Then the splicer updates the cached versions of 1..2 to contain the
+# new data
+check_caches({1 => "recordB$:", 2 => "recordC$:"},
+ {}); # URRRP
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+$a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED
+check_caches({1 => "recordB$:", 2 => "recordC$:"},
+ {3 => "recordD$:"});
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+# Check readcache-deferbuffer interactions
+
+# (45-47) This should remove outdated data from the read cache
+$a[2] = "recordE";
+check_caches({1 => "recordB$:", },
+ {3 => "recordD$:", 2 => "recordE$:"});
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+# (48-51) This should read back out of the defer buffer
+# without adding anything to the read cache
+my $z;
+$z = $a[2];
+print $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++;
+check_caches({1 => "recordB$:", },
+ {3 => "recordD$:", 2 => "recordE$:"});
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+# (52-55) This should repopulate the read cache with a new record
+$z = $a[0];
+print $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++;
+check_caches({1 => "recordB$:", 0 => "recordA$:"},
+ {3 => "recordD$:", 2 => "recordE$:"});
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+# (56-59) This should flush the LRU record from the read cache
+$z = $a[4]; $z = $a[5];
+print $z eq "record5" ? "ok $N\n" : "not ok $N\n"; $N++;
+check_caches({5 => "record5$:", 0 => "recordA$:", 4 => "record4$:"},
+ {3 => "recordD$:", 2 => "recordE$:"});
+check_contents(join("$:", qw(recordA recordB recordC
+ record3 record4 record5 record6 record7)) . "$:");
+
+# (60-63) This should FLUSH the deferred buffer
+# In doing so, it will read in records 2 and 3, flushing 0 and 4
+# from the read cache, leaving 2, 3, and 5.
+$z = splice @a, 3, 1, "recordZ";
+print $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++;
+check_caches({5 => "record5$:", 3 => "recordZ$:", 2 => "recordE$:"},
+ {});
+check_contents(join("$:", qw(recordA recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+
+# (64-66) We should STILL be in deferred writing mode
+$a[5] = "recordX";
+check_caches({3 => "recordZ$:", 2 => "recordE$:"},
+ {5 => "recordX$:"});
+check_contents(join("$:", qw(recordA recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+
+# Fill up the defer buffer again
+$a[4] = "recordP";
+# (67-69) This should OVERWRITE the existing deferred record
+# and NOT flush the buffer
+$a[5] = "recordQ";
+check_caches({3 => "recordZ$:", 2 => "recordE$:"},
+ {5 => "recordQ$:", 4 => "recordP$:"});
+check_contents(join("$:", qw(recordA recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+
+
+# (70-72) Discard should just dump the whole deferbuffer
+$o->discard;
+check_caches({3 => "recordZ$:", 2 => "recordE$:"},
+ {});
+check_contents(join("$:", qw(recordA recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+# (73-75) NOW we are out of deferred writing mode
+$a[0] = "recordF";
+check_caches({3 => "recordZ$:", 2 => "recordE$:", 0 => "recordF$:"},
+ {});
+check_contents(join("$:", qw(recordF recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+
+# (76-79) Last call--untying the array should flush the deferbuffer
+$o->defer;
+$a[0] = "flushed";
+check_caches({3 => "recordZ$:", 2 => "recordE$:"},
+ {0 => "flushed$:" });
+check_contents(join("$:", qw(recordF recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:");
+undef $o;
+untie @a;
+# (79) We can't use check_contents any more, because the object is dead
+open F, "< $file" or die;
+{ local $/ ; $z = <F> }
+close F;
+my $x = join("$:", qw(flushed recordB recordE
+ recordZ record4 record5 record6 record7)) . "$:";
+if ($z eq $x) {
+ print "ok $N\n";
+} else {
+ my $msg = ctrlfix("expected <$x>, got <$z>");
+ print "not ok $N \# $msg\n";
+}
+$N++;
+
+################################################################
+
+
+sub check_caches {
+ my ($xcache, $xdefer) = @_;
+
+# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+# print $integrity ? "ok $N\n" : "not ok $N\n";
+# $N++;
+
+ my $good = 1;
+ $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
+ $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
+ print $good ? "ok $N\n" : "not ok $N\n";
+ $N++;
+}
+
+sub hash_equal {
+ my ($a, $b, $ha, $hb) = @_;
+ $ha = 'first hash' unless defined $ha;
+ $hb = 'second hash' unless defined $hb;
+
+ my $good = 1;
+ my %b_seen;
+
+ for my $k (keys %$a) {
+ if (! exists $b->{$k}) {
+ print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
+ $good = 0;
+ } elsif ($b->{$k} ne $a->{$k}) {
+ print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
+ $b_seen{$k} = 1;
+ $good = 0;
+ } else {
+ $b_seen{$k} = 1;
+ }
+ }
+
+ for my $k (keys %$b) {
+ unless ($b_seen{$k}) {
+ print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
+ $good = 0;
+ }
+ }
+
+ $good;
+}
+
+
+sub check_contents {
+ my $x = shift;
+
+ my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+ print $integrity ? "ok $N\n" : "not ok $N\n";
+ $N++;
+
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+
+ my $a;
+ { local $/; $a = <FH> }
+ $a = "" unless defined $a;
+ if ($a eq $x) {
+ print "ok $N\n";
+ } else {
+ my $msg = ctrlfix("# expected <$x>, got <$a>");
+ print "not ok $N\n$msg\n";
+ }
+ $N++;
+}
+
+sub ctrlfix {
+ local $_ = shift;
+ s/\n/\\n/g;
+ s/\r/\\r/g;
+ $_;
+}
+
+END {
+ 1 while unlink $file;
+}
+
diff --git a/lib/Tie/File/t/31_autodefer.t b/lib/Tie/File/t/31_autodefer.t
new file mode 100644
index 0000000000..38d89dacd3
--- /dev/null
+++ b/lib/Tie/File/t/31_autodefer.t
@@ -0,0 +1,65 @@
+#!/usr/bin/perl
+#
+# Check behavior of 'autodefer' feature
+# Mostly this isn't implemented yet
+# This file is primarily here to make sure that the promised ->autodefer
+# method doesn't croak.
+#
+
+use POSIX 'SEEK_SET';
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+my $data = "rec0$:rec1$:rec2$:";
+my ($o, $n, @a);
+
+print "1..3\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+$o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# (3) You promised this interface, so it better not die
+
+eval {$o->autodefer(0)};
+print $@ ? "not ok $N # $@\n" : "ok $N\n";
+
+
+
+sub check_contents {
+ my $x = shift;
+ my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+ print $integrity ? "ok $N\n" : "not ok $N\n";
+ $N++;
+ my $a;
+ { local $/; $a = <FH> }
+ $a = "" unless defined $a;
+ if ($a eq $x) {
+ print "ok $N\n";
+ } else {
+ ctrlfix(my $msg = "# expected <$x>, got <$a>");
+ print "not ok $N\n$msg\n";
+ }
+ $N++;
+}
+
+sub ctrlfix {
+ for (@_) {
+ s/\n/\\n/g;
+ s/\r/\\r/g;
+ }
+}
+
+END {
+ 1 while unlink $file;
+}
+
diff --git a/lib/Tie/File/t/32_defer_misc.t b/lib/Tie/File/t/32_defer_misc.t
new file mode 100644
index 0000000000..8e6edf94a4
--- /dev/null
+++ b/lib/Tie/File/t/32_defer_misc.t
@@ -0,0 +1,230 @@
+#!/usr/bin/perl
+#
+# Check interactions of deferred writing
+# with miscellaneous methods like DELETE, EXISTS,
+# FETCHSIZE, STORESIZE, CLEAR, EXTEND
+#
+
+use POSIX 'SEEK_SET';
+my $file = "tf$$.txt";
+$: = Tie::File::_default_recsep();
+my $data = "rec0$:rec1$:rec2$:";
+my ($o, $n);
+
+print "1..42\n";
+
+my $N = 1;
+use Tie::File;
+print "ok $N\n"; $N++;
+
+open F, "> $file" or die $!;
+binmode F;
+print F $data;
+close F;
+$o = tie @a, 'Tie::File', $file;
+print $o ? "ok $N\n" : "not ok $N\n";
+$N++;
+
+# (3-6) EXISTS
+if ($] >= 5.006) {
+ eval << 'TESTS';
+$o->defer;
+expect(not exists $a[4]);
+$a[4] = "rec4";
+expect(exists $a[4]);
+check_contents($data); # nothing written yet
+$o->discard;
+TESTS
+} else {
+ for (3..6) {
+ print "ok $_ \# skipped (no exists for arrays)\n";
+ $N++;
+ }
+}
+
+# (7-10) FETCHSIZE
+$o->defer;
+expect($#a, 2);
+$a[4] = "rec4";
+expect($#a, 4);
+check_contents($data); # nothing written yet
+$o->discard;
+
+# (11-21) STORESIZE
+$o->defer;
+$#a = 4;
+check_contents($data); # nothing written yet
+expect($#a, 4);
+$o->flush;
+expect($#a, 4);
+check_contents("$data$:$:"); # two extra empty records
+
+$o->defer;
+$a[4] = "rec4";
+$#a = 2;
+expect($a[4], undef);
+check_contents($data); # written data was unwritten
+$o->flush;
+check_contents($data); # nothing left to write
+
+# (22-28) CLEAR
+$o->defer;
+$a[9] = "rec9";
+check_contents($data); # nothing written yet
+@a = ();
+check_contents(""); # this happens right away
+expect($a[9], undef);
+$o->flush;
+check_contents(""); # nothing left to write
+
+# (29-34) EXTEND
+# Actually it's not real clear what these tests are for
+# since EXTEND has no defined semantics
+$o->defer;
+@a = (0..3);
+check_contents(""); # nothing happened yet
+expect($a[3], "3");
+expect($a[4], undef);
+$o->flush;
+check_contents("0$:1$:2$:3$:"); # file now 4 records long
+
+# (35-53) DELETE
+if ($] >= 5.006) {
+ eval << 'TESTS';
+my $del;
+$o->defer;
+$del = delete $a[2];
+check_contents("0$:1$:2$:3$:"); # nothing happened yet
+expect($a[2], "");
+expect($del, "2");
+$del = delete $a[3]; # shortens file!
+check_contents("0$:1$:2$:"); # deferred writes NOT flushed
+expect($a[3], undef);
+expect($a[2], "");
+exoect($del, "3");
+$a[2] = "cookies";
+$del = delete $a[2]; # shortens file!
+expect($a[2], undef);
+exoect($del, 'cookies');
+check_contents("0$:1$:");
+$a[0] = "crackers";
+$del = delete $a[0]; # file unchanged
+expect($a[0], "");
+exoect($del, 'crackers');
+check_contents("0$:1$:"); # no change yet
+$o->flush;
+check_contents("$:1$:"); # record 0 is NOT 'cookies';
+TESTS
+} else {
+ for (35..53) {
+ print "ok $_ \# skipped (no delete for arrays)\n";
+ $N++;
+ }
+}
+
+################################################################
+
+
+sub check_caches {
+ my ($xcache, $xdefer) = @_;
+
+# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+# print $integrity ? "ok $N\n" : "not ok $N\n";
+# $N++;
+
+ my $good = 1;
+ $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
+ $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
+ print $good ? "ok $N\n" : "not ok $N\n";
+ $N++;
+}
+
+sub hash_equal {
+ my ($a, $b, $ha, $hb) = @_;
+ $ha = 'first hash' unless defined $ha;
+ $hb = 'second hash' unless defined $hb;
+
+ my $good = 1;
+ my %b_seen;
+
+ for my $k (keys %$a) {
+ if (! exists $b->{$k}) {
+ print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
+ $good = 0;
+ } elsif ($b->{$k} ne $a->{$k}) {
+ print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
+ $b_seen{$k} = 1;
+ $good = 0;
+ } else {
+ $b_seen{$k} = 1;
+ }
+ }
+
+ for my $k (keys %$b) {
+ unless ($b_seen{$k}) {
+ print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
+ $good = 0;
+ }
+ }
+
+ $good;
+}
+
+
+sub check_contents {
+ my $x = shift;
+
+ my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
+ print $integrity ? "ok $N\n" : "not ok $N\n";
+ $N++;
+
+ local *FH = $o->{fh};
+ seek FH, 0, SEEK_SET;
+
+ my $a;
+ { local $/; $a = <FH> }
+ $a = "" unless defined $a;
+ if ($a eq $x) {
+ print "ok $N\n";
+ } else {
+ my $msg = ctrlfix("# expected <$x>, got <$a>");
+ print "not ok $N\n$msg\n";
+ }
+ $N++;
+}
+
+sub expect {
+ if (@_ == 1) {
+ print $_[0] ? "ok $N\n" : "not ok $N\n";
+ } elsif (@_ == 2) {
+ my ($a, $x) = @_;
+ if (! defined($a) && ! defined($x)) { print "ok $N\n" }
+ elsif ( defined($a) && ! defined($x)) {
+ ctrlfix(my $msg = "expected UNDEF, got <$a>");
+ print "not ok $N \# $msg\n";
+ }
+ elsif (! defined($a) && defined($x)) {
+ ctrlfix(my $msg = "expected <$x>, got UNDEF");
+ print "not ok $N \# $msg\n";
+ } elsif ($a eq $x) { print "ok $N\n" }
+ else {
+ ctrlfix(my $msg = "expected <$x>, got <$a>");
+ print "not ok $N \# $msg\n";
+ }
+ } else {
+ die "expect() got ", scalar(@_), " args, should have been 1 or 2";
+ }
+ $N++;
+}
+
+sub ctrlfix {
+ local $_ = shift;
+ s/\n/\\n/g;
+ s/\r/\\r/g;
+ $_;
+}
+
+END {
+ 1 while unlink $file;
+}
+
View Lorry Controller Status