1N/A#!/usr/bin/perl
1N/A#
1N/A# Check interactions of deferred writing
1N/A# with miscellaneous methods like DELETE, EXISTS,
1N/A# FETCHSIZE, STORESIZE, CLEAR, EXTEND
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..53\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) EXISTS
1N/Aif ($] >= 5.006) {
1N/A eval << 'TESTS';
1N/A$o->defer;
1N/Aexpect(not exists $a[4]);
1N/A$a[4] = "rec4";
1N/Aexpect(exists $a[4]);
1N/Acheck_contents($data); # nothing written yet
1N/A$o->discard;
1N/ATESTS
1N/A} else {
1N/A for (3..6) {
1N/A print "ok $_ \# skipped (no exists for arrays)\n";
1N/A $N++;
1N/A }
1N/A}
1N/A
1N/A# (7-10) FETCHSIZE
1N/A$o->defer;
1N/Aexpect($#a, 2);
1N/A$a[4] = "rec4";
1N/Aexpect($#a, 4);
1N/Acheck_contents($data); # nothing written yet
1N/A$o->discard;
1N/A
1N/A# (11-21) STORESIZE
1N/A$o->defer;
1N/A$#a = 4;
1N/Acheck_contents($data); # nothing written yet
1N/Aexpect($#a, 4);
1N/A$o->flush;
1N/Aexpect($#a, 4);
1N/Acheck_contents("$data$:$:"); # two extra empty records
1N/A
1N/A$o->defer;
1N/A$a[4] = "rec4";
1N/A$#a = 2;
1N/Aexpect($a[4], undef);
1N/Acheck_contents($data); # written data was unwritten
1N/A$o->flush;
1N/Acheck_contents($data); # nothing left to write
1N/A
1N/A# (22-28) CLEAR
1N/A$o->defer;
1N/A$a[9] = "rec9";
1N/Acheck_contents($data); # nothing written yet
1N/A@a = ();
1N/Acheck_contents(""); # this happens right away
1N/Aexpect($a[9], undef);
1N/A$o->flush;
1N/Acheck_contents(""); # nothing left to write
1N/A
1N/A# (29-34) EXTEND
1N/A# Actually it's not real clear what these tests are for
1N/A# since EXTEND has no defined semantics
1N/A$o->defer;
1N/A@a = (0..3);
1N/Acheck_contents(""); # nothing happened yet
1N/Aexpect($a[3], "3");
1N/Aexpect($a[4], undef);
1N/A$o->flush;
1N/Acheck_contents("0$:1$:2$:3$:"); # file now 4 records long
1N/A
1N/A# (35-53) DELETE
1N/Aif ($] >= 5.006) {
1N/A eval << 'TESTS';
1N/Amy $del;
1N/A$o->defer;
1N/A$del = delete $a[2];
1N/Acheck_contents("0$:1$:2$:3$:"); # nothing happened yet
1N/Aexpect($a[2], "");
1N/Aexpect($del, "2");
1N/A$del = delete $a[3]; # shortens file!
1N/Acheck_contents("0$:1$:2$:"); # deferred writes NOT flushed
1N/Aexpect($a[3], undef);
1N/Aexpect($a[2], "");
1N/Aexpect($del, "3");
1N/A$a[2] = "cookies";
1N/A$del = delete $a[2]; # shortens file!
1N/Aexpect($a[2], undef);
1N/Aexpect($del, 'cookies');
1N/Acheck_contents("0$:1$:");
1N/A$a[0] = "crackers";
1N/A$del = delete $a[0]; # file unchanged
1N/Aexpect($a[0], "");
1N/Aexpect($del, 'crackers');
1N/Acheck_contents("0$:1$:"); # no change yet
1N/A$o->flush;
1N/Acheck_contents("$:1$:"); # record 0 is NOT 'cookies';
1N/ATESTS
1N/A} else {
1N/A for (35..53) {
1N/A print "ok $_ \# skipped (no delete for arrays)\n";
1N/A $N++;
1N/A }
1N/A}
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 $good &&= hash_equal($o->{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 expect {
1N/A if (@_ == 1) {
1N/A print $_[0] ? "ok $N\n" : "not ok $N\n";
1N/A } elsif (@_ == 2) {
1N/A my ($a, $x) = @_;
1N/A if (! defined($a) && ! defined($x)) { print "ok $N\n" }
1N/A elsif ( defined($a) && ! defined($x)) {
1N/A ctrlfix(my $msg = "expected UNDEF, got <$a>");
1N/A print "not ok $N \# $msg\n";
1N/A }
1N/A elsif (! defined($a) && defined($x)) {
1N/A ctrlfix(my $msg = "expected <$x>, got UNDEF");
1N/A print "not ok $N \# $msg\n";
1N/A } elsif ($a eq $x) { print "ok $N\n" }
1N/A else {
1N/A ctrlfix(my $msg = "expected <$x>, got <$a>");
1N/A print "not ok $N \# $msg\n";
1N/A }
1N/A } else {
1N/A die "expect() got ", scalar(@_), " args, should have been 1 or 2";
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;
1N/A 1 while unlink $file;
1N/A}
1N/A