1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6#
7# Check behavior of 'autodefer' feature
8# Mostly this isn't implemented yet
9# This file is primarily here to make sure that the promised ->autodefer
10# method doesn't croak.
11#
12
13use POSIX 'SEEK_SET';
14
15my $file = "tf31-$$.txt";
16$: = Tie::File::_default_recsep();
17my $data = "rec0$:rec1$:rec2$:";
18my ($o, $n, @a);
19
20print "1..65\n";
21
22my $N = 1;
23use Tie::File;
24print "ok $N\n"; $N++;
25
26open F, '>', $file or die $!;
27binmode F;
28print F $data;
29close F;
30$o = tie @a, 'Tie::File', $file;
31print $o ? "ok $N\n" : "not ok $N\n";
32$N++;
33
34# I am an undocumented feature
35$o->{autodefer_filelen_threshhold} = 0;
36# Normally autodeferring only works on large files.  This disables that.
37
38# (3-22) Deferred storage
39$a[3] = "rec3";
40check_autodeferring('OFF');
41$a[4] = "rec4";
42check_autodeferring('OFF');
43$a[5] = "rec5";
44check_autodeferring('ON');
45check_contents($data . "rec3$:rec4$:"); # only the first two were written
46$a[6] = "rec6";
47check_autodeferring('ON');
48check_contents($data . "rec3$:rec4$:"); # still nothing written
49$a[7] = "rec7";
50check_autodeferring('ON');
51check_contents($data . "rec3$:rec4$:"); # still nothing written
52$a[0] = "recX";
53check_autodeferring('OFF');
54check_contents("recX$:rec1$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
55$a[1] = "recY";
56check_autodeferring('OFF');
57check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
58$a[2] = "recZ";                 # it kicks in here
59check_autodeferring('ON');
60check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
61
62# (23-26) Explicitly enabling deferred writing deactivates autodeferring
63$o->defer;
64check_autodeferring('OFF');
65check_contents("recX$:recY$:recZ$:rec3$:rec4$:rec5$:rec6$:rec7$:");
66$o->discard;
67check_autodeferring('OFF');
68
69# (27-32) Now let's try the CLEAR special case
70@a = ("r0" .. "r4");
71check_autodeferring('ON');
72# The file was extended to the right length, but nothing was actually written.
73check_contents("$:$:$:$:$:");
74$a[2] = "fish";
75check_autodeferring('OFF');
76check_contents("r0$:r1$:fish$:r3$:r4$:");
77
78# (33-47) Now let's try the originally intended application:  a 'for' loop.
79my $it = 0;
80for (@a) {
81  $_ = "##$_";
82  if ($it == 0) {
83    check_autodeferring('OFF');
84    check_contents("##r0$:r1$:fish$:r3$:r4$:");
85  } elsif ($it == 1) {
86    check_autodeferring('OFF');
87    check_contents("##r0$:##r1$:fish$:r3$:r4$:");
88  } else {
89    check_autodeferring('ON');
90    check_contents("##r0$:##r1$:fish$:r3$:r4$:");
91  }
92  $it++;
93}
94
95# (48-56) Autodeferring should not become active during explicit defer mode
96$o->defer();  # This should flush the pending autodeferred records
97              # and deactivate autodeferring
98check_autodeferring('OFF');
99check_contents("##r0$:##r1$:##fish$:##r3$:##r4$:");
100@a = ("s0" .. "s4");
101check_autodeferring('OFF');
102check_contents("");
103$o->flush;
104check_autodeferring('OFF');
105check_contents("s0$:s1$:s2$:s3$:s4$:");
106
107undef $o; untie @a;
108
109# Limit cache+buffer size to 47 bytes
110my $MAX = 47;
111#  -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
112my $BUF = 20;
113#  -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
114# Re-tie the object for more tests
115$o = tie @a, 'Tie::File', $file, autodefer => 0;
116die $! unless $o;
117# I am an undocumented feature
118$o->{autodefer_filelen_threshhold} = 0;
119# Normally autodeferring only works on large files.  This disables that.
120
121# (57-59) Did the autodefer => 0 option work?
122# (If it doesn't, a whole bunch of the other test files will fail.)
123@a = (0..3);
124check_autodeferring('OFF');
125check_contents(join("$:", qw(0 1 2 3), ""));
126
127# (60-62) Does the ->autodefer method work?
128$o->autodefer(1);
129@a = (10..13);
130check_autodeferring('ON');
131check_contents("$:$:$:$:");  # This might be unfortunate.
132
133# (63-65) Does the ->autodefer method work?
134$o->autodefer(0);
135check_autodeferring('OFF');
136check_contents(join("$:", qw(10 11 12 13), ""));
137
138
139sub check_autodeferring {
140  my ($x) = shift;
141  my $a = $o->{autodeferring} ? 'ON' : 'OFF';
142  if ($x eq $a) {
143    print "ok $N\n";
144  } else {
145    print "not ok $N \# Autodeferring was $a, expected it to be $x\n";
146  }
147  $N++;
148}
149
150
151sub check_contents {
152  my $x = shift;
153#  for (values %{$o->{cache}}) {
154#    print "# cache=$_";
155#  }
156
157  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
158  local *FH = $o->{fh};
159  seek FH, 0, SEEK_SET;
160  print $integrity ? "ok $N\n" : "not ok $N\n";
161  $N++;
162  my $a;
163  { local $/; $a = <FH> }
164  $a = "" unless defined $a;
165  if ($a eq $x) {
166    print "ok $N\n";
167  } else {
168    ctrlfix(my $msg = "# expected <$x>, got <$a>");
169    print "not ok $N\n$msg\n";
170  }
171  $N++;
172}
173
174sub ctrlfix {
175  for (@_) {
176    s/\n/\\n/g;
177    s/\r/\\r/g;
178  }
179}
180
181END {
182  undef $o;
183  untie @a;
184  1 while unlink $file;
185}
186
187