1N/A#!/usr/bin/perl
1N/A#
1N/A# Check PUSH, POP, SHIFT, and UNSHIFT
1N/A#
1N/A# Each call to 'check_contents' actually performs two tests.
1N/A# First, it calls the tied object's own 'check_integrity' method,
1N/A# which makes sure that the contents of the read cache and offset tables
1N/A# accurately reflect the contents of the file.
1N/A# Then, it checks the actual contents of the file against the expected
1N/A# contents.
1N/A
1N/Ause POSIX 'SEEK_SET';
1N/A
1N/Amy $file = "tf$$.txt";
1N/A1 while unlink $file;
1N/A$: = Tie::File::_default_recsep();
1N/Amy $data = "rec0$:rec1$:rec2$:";
1N/A
1N/Aprint "1..38\n";
1N/A
1N/Amy $N = 1;
1N/Ause Tie::File;
1N/Aprint "ok $N\n"; $N++; # partial credit just for showing up
1N/A
1N/Amy $o = tie @a, 'Tie::File', $file, autochomp => 0;
1N/Aprint $o ? "ok $N\n" : "not ok $N\n";
1N/A$N++;
1N/Amy ($n, @r);
1N/A
1N/A
1N/A# (3-11) PUSH tests
1N/A$n = push @a, "rec0", "rec1", "rec2";
1N/Acheck_contents($data);
1N/Aprint $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
1N/A$N++;
1N/A
1N/A$n = push @a, "rec3", "rec4$:";
1N/Acheck_contents("$ {data}rec3$:rec4$:");
1N/Aprint $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
1N/A$N++;
1N/A
1N/A# Trivial push
1N/A$n = push @a, ();
1N/Acheck_contents("$ {data}rec3$:rec4$:");
1N/Aprint $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
1N/A$N++;
1N/A
1N/A# (12-20) POP tests
1N/A$n = pop @a;
1N/Acheck_contents("$ {data}rec3$:");
1N/Aprint $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
1N/A$N++;
1N/A
1N/A# Presumably we have already tested this to death
1N/Asplice(@a, 1, 3);
1N/A$n = pop @a;
1N/Acheck_contents("");
1N/Aprint $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n";
1N/A$N++;
1N/A
1N/A$n = pop @a;
1N/Acheck_contents("");
1N/Aprint ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
1N/A$N++;
1N/A
1N/A
1N/A# (21-29) UNSHIFT tests
1N/A$n = unshift @a, "rec0", "rec1", "rec2";
1N/Acheck_contents($data);
1N/Aprint $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
1N/A$N++;
1N/A
1N/A$n = unshift @a, "rec3", "rec4$:";
1N/Acheck_contents("rec3$:rec4$:$data");
1N/Aprint $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
1N/A$N++;
1N/A
1N/A# Trivial unshift
1N/A$n = unshift @a, ();
1N/Acheck_contents("rec3$:rec4$:$data");
1N/Aprint $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
1N/A$N++;
1N/A
1N/A# (30-38) SHIFT tests
1N/A$n = shift @a;
1N/Acheck_contents("rec4$:$data");
1N/Aprint $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n";
1N/A$N++;
1N/A
1N/A# Presumably we have already tested this to death
1N/Asplice(@a, 1, 3);
1N/A$n = shift @a;
1N/Acheck_contents("");
1N/Aprint $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
1N/A$N++;
1N/A
1N/A$n = shift @a;
1N/Acheck_contents("");
1N/Aprint ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
1N/A$N++;
1N/A
1N/A
1N/Asub check_contents {
1N/A my $x = shift;
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 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 ctrlfix(my $msg = "# 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 for (@_) {
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