1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6#
7# Check ->defer and ->flush methods
8#
9# This is the old version, which you used in the past when
10# there was a defer buffer separate from the read cache.  
11# There isn't any longer.
12#
13
14use POSIX 'SEEK_SET';
15my $file = "tf30-$$.txt";
16$: = Tie::File::_default_recsep();
17my $data = "rec0$:rec1$:rec2$:";
18my ($o, $n);
19
20print "1..79\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
31my @a;
32$o = tie @a, 'Tie::File', $file;
33print $o ? "ok $N\n" : "not ok $N\n";
34$N++;
35
36# (3-6) Deferred storage
37$o->defer;
38$a[3] = "rec3";
39check_contents($data);          # nothing written yet
40$a[4] = "rec4";
41check_contents($data);          # nothing written yet
42
43# (7-8) Flush
44$o->flush;
45check_contents($data . "rec3$:rec4$:");          # now it's written
46
47# (9-12) Deferred writing disabled?
48$a[3] = "rec9";
49check_contents("${data}rec9$:rec4$:");
50$a[4] = "rec8";
51check_contents("${data}rec9$:rec8$:");
52
53# (13-18) Now let's try two batches of records
54$#a = 2;
55$o->defer;
56$a[0] = "record0";
57check_contents($data);          # nothing written yet
58$a[2] = "record2";
59check_contents($data);          # nothing written yet
60$o->flush;
61check_contents("record0$:rec1$:record2$:");
62
63# (19-22) Deferred writing past the end of the file
64$o->defer;
65$a[4] = "record4";
66check_contents("record0$:rec1$:record2$:");
67$o->flush;
68check_contents("record0$:rec1$:record2$:$:record4$:");
69
70
71# (23-26) Now two long batches
72$o->defer;
73for (0..2, 4..6) {
74  $a[$_] = "r$_";
75}
76check_contents("record0$:rec1$:record2$:$:record4$:");
77$o->flush;
78check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
79
80# (27-30) Now let's make sure that discarded writes are really discarded
81# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
82# filling it up
83$o->defer;
84for (0, 3, 7) {
85  $a[$_] = "discarded$_";
86}
87check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
88$o->discard;
89check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
90
91################################################################
92#
93# Now we're going to test the results of a small memory limit
94#
95# 
96undef $o;  untie @a;
97$data = join "$:", map("record$_", 0..7), "";  # records are 8 or 9 bytes long
98open F, '>', $file or die $!;
99binmode F;
100print F $data;
101close F;
102
103# Limit cache+buffer size to 47 bytes 
104my $MAX = 47;
105#  -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
106my $BUF = 20;
107#  -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
108$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
109print $o ? "ok $N\n" : "not ok $N\n";
110$N++;
111
112# (31-32) Fill up the read cache
113my @z;
114@z = @a;                        
115# the cache now contains records 3,4,5,6,7.
116check_caches({map(($_ => "record$_$:"), 3..7)}, 
117             {});
118
119# (33-44) See if overloading the defer starts by flushing the read cache
120# and then flushes out the defer
121$o->defer;
122$a[0] = "recordA";              # That should flush record 3 from the cache
123check_caches({map(($_ => "record$_$:"), 4..7)}, 
124             {0 => "recordA$:"});
125check_contents($data);
126
127$a[1] = "recordB";              # That should flush record 4 from the cache
128check_caches({map(($_ => "record$_$:"), 5..7)}, 
129             {0 => "recordA$:",
130              1 => "recordB$:"});
131check_contents($data);
132
133$a[2] = "recordC";              # That should flush the whole darn defer
134# This shouldn't change the cache contents
135check_caches({map(($_ => "record$_$:"), 5..7)}, 
136             {});               # URRRP
137check_contents(join("$:", qw(recordA recordB recordC 
138                             record3 record4 record5 record6 record7)) . "$:");
139
140$a[3] = "recordD";         # even though we flushed, deferring is STILL ENABLED
141check_caches({map(($_ => "record$_$:"), 5..7)},
142             {3 => "recordD$:"}); 
143check_contents(join("$:", qw(recordA recordB recordC 
144                             record3 record4 record5 record6 record7)) . "$:");
145
146# Check readcache-deferbuffer interactions
147
148# (45-47) This should remove outdated data from the read cache
149$a[5] = "recordE";
150check_caches({6 => "record6$:", 7 => "record7$:"},
151             {3 => "recordD$:", 5 => "recordE$:"}); 
152check_contents(join("$:", qw(recordA recordB recordC 
153                             record3 record4 record5 record6 record7)) . "$:");
154
155# (48-51) This should read back out of the defer buffer
156# without adding anything to the read cache
157my $z;
158$z = $a[5];
159print $z eq "recordE" ? "ok $N\n" : "not ok $N\n";  $N++;
160check_caches({6 => "record6$:", 7 => "record7$:"},
161             {3 => "recordD$:", 5 => "recordE$:"}); 
162check_contents(join("$:", qw(recordA recordB recordC 
163                             record3 record4 record5 record6 record7)) . "$:");
164
165# (52-55) This should repopulate the read cache with a new record
166$z = $a[0];
167print $z eq "recordA" ? "ok $N\n" : "not ok $N\n";  $N++;
168check_caches({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"},
169             {3 => "recordD$:", 5 => "recordE$:"}); 
170check_contents(join("$:", qw(recordA recordB recordC 
171                             record3 record4 record5 record6 record7)) . "$:");
172
173# (56-59) This should flush the LRU record from the read cache
174$z = $a[4];
175print $z eq "record4" ? "ok $N\n" : "not ok $N\n";  $N++;
176check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"},
177             {3 => "recordD$:", 5 => "recordE$:"}); 
178check_contents(join("$:", qw(recordA recordB recordC 
179                             record3 record4 record5 record6 record7)) . "$:");
180
181# (60-63) This should FLUSH the deferred buffer
182$z = splice @a, 3, 1, "recordZ";
183print $z eq "recordD" ? "ok $N\n" : "not ok $N\n";  $N++;
184check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
185             {}); 
186check_contents(join("$:", qw(recordA recordB recordC 
187                             recordZ record4 recordE record6 record7)) . "$:");
188
189# (64-66) We should STILL be in deferred writing mode
190$a[5] = "recordX";
191check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
192             {5 => "recordX$:"}); 
193check_contents(join("$:", qw(recordA recordB recordC 
194                             recordZ record4 recordE record6 record7)) . "$:");
195
196# Fill up the defer buffer again
197$a[4] = "recordP";
198# (67-69) This should OVERWRITE the existing deferred record 
199# and NOT flush the buffer
200$a[5] = "recordQ";   
201check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
202             {5 => "recordQ$:", 4 => "recordP$:"}); 
203check_contents(join("$:", qw(recordA recordB recordC 
204                             recordZ record4 recordE record6 record7)) . "$:");
205
206# (70-72) Discard should just dump the whole deferbuffer
207$o->discard;
208check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
209             {}); 
210check_contents(join("$:", qw(recordA recordB recordC 
211                             recordZ record4 recordE record6 record7)) . "$:");
212
213# (73-75) NOW we are out of deferred writing mode
214$a[0] = "recordF";
215check_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"},
216             {}); 
217check_contents(join("$:", qw(recordF recordB recordC
218                             recordZ record4 recordE record6 record7)) . "$:");
219
220# (76-79) Last call--untying the array should flush the deferbuffer
221$o->defer;
222$a[0] = "flushed";
223check_caches({7 => "record7$:",                   3 => "recordZ$:"},
224             {0 => "flushed$:" }); 
225check_contents(join("$:", qw(recordF recordB recordC
226                             recordZ record4 recordE record6 record7)) . "$:");
227undef $o;
228untie @a;
229# (79) We can't use check_contents any more, because the object is dead
230open F, '<', $file or die;
231binmode F;
232{ local $/ ; $z = <F> }
233close F;
234my $x = join("$:", qw(flushed recordB recordC
235                      recordZ record4 recordE record6 record7)) . "$:";
236if ($z eq $x) {
237  print "ok $N\n";
238} else {
239  my $msg = ctrlfix("expected <$x>, got <$z>");
240  print "not ok $N \# $msg\n";
241}
242$N++;
243
244################################################################
245
246
247sub check_caches {
248  my ($xcache, $xdefer) = @_;
249
250#  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
251#  print $integrity ? "ok $N\n" : "not ok $N\n";
252#  $N++;
253
254  my $good = 1;
255
256  # Copy the contents of the cache into a regular hash
257  my %cache;
258  for my $k ($o->{cache}->ckeys) {
259    $cache{$k} = $o->{cache}->_produce($k);
260  }
261
262  $good &&= hash_equal(\%cache, $xcache, "true cache", "expected cache");
263  $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
264  print $good ? "ok $N\n" : "not ok $N\n";
265  $N++;
266}
267
268sub hash_equal {
269  my ($a, $b, $ha, $hb) = @_;
270  $ha = 'first hash'  unless defined $ha;
271  $hb = 'second hash' unless defined $hb;
272
273  my $good = 1;
274  my %b_seen;
275
276  for my $k (keys %$a) {
277    if (! exists $b->{$k}) {
278      print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
279      $good = 0;
280    } elsif ($b->{$k} ne $a->{$k}) {
281      print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
282      $b_seen{$k} = 1;
283      $good = 0;
284    } else {
285      $b_seen{$k} = 1;
286    }
287  }
288
289  for my $k (keys %$b) {
290    unless ($b_seen{$k}) {
291      print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
292      $good = 0;
293    }
294  }
295
296  $good;
297}
298
299
300sub check_contents {
301  my $x = shift;
302
303  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
304  print $integrity ? "ok $N\n" : "not ok $N\n";
305  $N++;
306
307  local *FH = $o->{fh};
308  seek FH, 0, SEEK_SET;
309
310  my $a;
311  { local $/; $a = <FH> }
312  $a = "" unless defined $a;
313  if ($a eq $x) {
314    print "ok $N\n";
315  } else {
316    my $msg = ctrlfix("# expected <$x>, got <$a>");
317    print "not ok $N\n$msg\n";
318  }
319  $N++;
320}
321
322sub ctrlfix {
323  local $_ = shift;
324  s/\n/\\n/g;
325  s/\r/\\r/g;
326  $_;
327}
328
329END {
330  undef $o;
331  untie @a if tied @a;
332  1 while unlink $file;
333}
334
335