1#!/usr/bin/perl
2#
3# Check PUSH, POP, SHIFT, and UNSHIFT
4#
5# Each call to 'check_contents' actually performs two tests.
6# First, it calls the tied object's own 'check_integrity' method,
7# which makes sure that the contents of the read cache and offset tables
8# accurately reflect the contents of the file.
9# Then, it checks the actual contents of the file against the expected
10# contents.
11
12use POSIX 'SEEK_SET';
13
14my $file = "tf$$.txt";
151 while unlink $file;
16$: = Tie::File::_default_recsep();
17my $data = "rec0$:rec1$:rec2$:";
18
19print "1..38\n";
20
21my $N = 1;
22use Tie::File;
23print "ok $N\n"; $N++;  # partial credit just for showing up
24
25my $o = tie @a, 'Tie::File', $file, autochomp => 0;
26print $o ? "ok $N\n" : "not ok $N\n";
27$N++;
28my ($n, @r);
29
30
31# (3-11) PUSH tests
32$n = push @a, "rec0", "rec1", "rec2";
33check_contents($data);
34print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
35$N++;
36
37$n = push @a, "rec3", "rec4$:";
38check_contents("$ {data}rec3$:rec4$:");
39print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
40$N++;
41
42# Trivial push
43$n = push @a, ();
44check_contents("$ {data}rec3$:rec4$:");
45print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
46$N++;
47
48# (12-20) POP tests
49$n = pop @a;
50check_contents("$ {data}rec3$:");
51print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
52$N++;
53
54# Presumably we have already tested this to death
55splice(@a, 1, 3);
56$n = pop @a;
57check_contents("");
58print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n";
59$N++;
60
61$n = pop @a;
62check_contents("");
63print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
64$N++;
65
66
67# (21-29) UNSHIFT tests
68$n = unshift @a, "rec0", "rec1", "rec2";
69check_contents($data);
70print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
71$N++;
72
73$n = unshift @a, "rec3", "rec4$:";
74check_contents("rec3$:rec4$:$data");
75print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
76$N++;
77
78# Trivial unshift
79$n = unshift @a, ();
80check_contents("rec3$:rec4$:$data");
81print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
82$N++;
83
84# (30-38) SHIFT tests
85$n = shift @a;
86check_contents("rec4$:$data");
87print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n";
88$N++;
89
90# Presumably we have already tested this to death
91splice(@a, 1, 3);
92$n = shift @a;
93check_contents("");
94print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
95$N++;
96
97$n = shift @a;
98check_contents("");
99print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
100$N++;
101
102
103sub check_contents {
104  my $x = shift;
105  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
106  print $integrity ? "ok $N\n" : "not ok $N\n";
107  $N++;
108
109  local *FH = $o->{fh};
110  seek FH, 0, SEEK_SET;
111  my $a;
112  { local $/; $a = <FH> }
113  $a = "" unless defined $a;
114  if ($a eq $x) {
115    print "ok $N\n";
116  } else {
117    ctrlfix(my $msg = "# expected <$x>, got <$a>");
118    print "not ok $N\n$msg\n";
119  }
120  $N++;
121}
122
123sub ctrlfix {
124  for (@_) {
125    s/\n/\\n/g;
126    s/\r/\\r/g;
127  }
128}
129
130END {
131  undef $o;
132  untie @a;
133  1 while unlink $file;
134}
135
136