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