1#!/usr/bin/perl
2#
3# Check FETCHSIZE and SETSIZE functions
4# PUSH POP SHIFT UNSHIFT
5#
6
7use strict;
8use warnings;
9
10use POSIX 'SEEK_SET';
11
12my $file = "tf05-$$.txt";
13my ($o, $n);
14
15print "1..16\n";
16
17my $N = 1;
18use Tie::File;
19print "ok $N\n"; $N++;
20
21# 2-3 FETCHSIZE 0-length file
22open F, '>', $file or die $!;
23binmode F;
24close F;
25
26my @a;
27$o = tie @a, 'Tie::File', $file;
28print $o ? "ok $N\n" : "not ok $N\n";
29$N++;
30
31$: = $o->{recsep};
32
33$n = @a;
34print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
35$N++;
36
37# Reset everything
38undef $o;
39untie @a;
40
41my $data = "rec0$:rec1$:rec2$:";
42open F, '>', $file or die $!;
43binmode F;
44print F $data;
45close F;
46
47$o = tie @a, 'Tie::File', $file;
48print $o ? "ok $N\n" : "not ok $N\n";
49$N++;
50
51# 4-5 FETCHSIZE positive-length file
52$n = @a;
53print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
54$N++;
55
56# STORESIZE
57# (6-7) Make it longer:
58populate();
59$#a = 4;
60check_contents("$data$:$:");
61
62# (8-9) Make it longer again:
63populate();
64$#a = 6;
65check_contents("$data$:$:$:$:");
66
67# (10-11) Make it shorter:
68populate();
69$#a = 4;
70check_contents("$data$:$:");
71
72# (12-13) Make it shorter again:
73populate();
74$#a = 2;
75check_contents($data);
76
77# (14-15) Get rid of it completely:
78populate();
79$#a = -1;
80check_contents('');
81
82# (16) 20020324 I have an idea that shortening the array will not
83# expunge a cached record at the end if one is present.
84$o->defer;
85$a[3] = "record";
86my $r = $a[3];
87$#a = -1;
88$r = $a[3];
89print (! defined $r ? "ok $N\n" : "not ok $N \# was <$r>; should be UNDEF\n");
90# Turns out not to be the case---STORESIZE explicitly removes them later
91# 20020326 Well, but happily, this test did fail today.
92
93# In the past, there was a bug in STORESIZE that it didn't correctly
94# remove deleted records from the cache.  This wasn't detected
95# because these tests were all done with an empty cache.  populate()
96# will ensure that the cache is fully populated.
97sub populate {
98  my $z;
99  $z = $a[$_] for 0 .. $#a;
100}
101
102sub check_contents {
103  my $x = shift;
104  local *FH = $o->{fh};
105  seek FH, 0, SEEK_SET;
106  my $a;
107  { local $/; $a = <FH> }
108  $a = "" unless defined $a;
109  if ($a eq $x) {
110    print "ok $N\n";
111  } else {
112    ctrlfix($a, $x);
113    print "not ok $N\n# expected <$x>, got <$a>\n";
114  }
115  $N++;
116  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
117  print $integrity ? "ok $N\n" : "not ok $N \# integrity\n";
118  $N++;
119}
120
121
122sub ctrlfix {
123  for (@_) {
124    s/\n/\\n/g;
125    s/\r/\\r/g;
126  }
127}
128
129END {
130  undef $o;
131  untie @a;
132  1 while unlink $file;
133}
134
135