1#!/usr/bin/perl
2#
3# Deferred caching of varying size records
4#
5# 30_defer.t always uses records that are 8 bytes long
6# (9 on \r\n machines.)  We might miss some sort of
7# length-calculation bug as a result.  This file will run some of the same
8# tests, but with with varying-length records.
9#
10
11use POSIX 'SEEK_SET';
12my $file = "tf$$.txt";
13# print "1..0\n"; exit;
14$: = Tie::File::_default_recsep();
15my $data = "$:1$:22$:";
16my ($o, $n);
17
18print "1..30\n";
19
20my $N = 1;
21use Tie::File;
22print "ok $N\n"; $N++;
23
24open F, '>', $file or die $!;
25binmode F;
26print F $data;
27close F;
28$o = tie @a, 'Tie::File', $file;
29print $o ? "ok $N\n" : "not ok $N\n";
30$N++;
31
32# (3-6) Deferred storage
33$o->defer;
34$a[3] = "333";
35check_contents($data);          # nothing written yet
36$a[4] = "4444";
37check_contents($data);          # nothing written yet
38
39# (7-8) Flush
40$o->flush;
41check_contents($data . "333$:4444$:");          # now it's written
42
43# (9-12) Deferred writing disabled?
44$a[3] = "999999999";
45check_contents("${data}999999999$:4444$:");
46$a[4] = "88888888";
47check_contents("${data}999999999$:88888888$:");
48
49# (13-18) Now let's try two batches of records
50$#a = 2;
51$o->defer;
52$a[0] = "55555";
53check_contents($data);          # nothing written yet
54$a[2] = "aaaaaaaaaa";
55check_contents($data);          # nothing written yet
56$o->flush;
57check_contents("55555$:1$:aaaaaaaaaa$:");
58
59# (19-22) Deferred writing past the end of the file
60$o->defer;
61$a[4] = "7777777";
62check_contents("55555$:1$:aaaaaaaaaa$:");
63$o->flush;
64check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
65
66
67# (23-26) Now two long batches
68$o->defer;
69%l = qw(0 2  1 3  2 4  4 5  5 4  6 3);
70for (0..2, 4..6) {
71  $a[$_] = $_ x $l{$_};
72}
73check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
74$o->flush;
75check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
76
77# (27-30) Now let's make sure that discarded writes are really discarded
78# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
79# filling it up
80$o->defer;
81for (0, 3, 7) {
82  $a[$_] = "discarded" . $_ x $_;
83}
84check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
85$o->discard;
86check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
87
88################################################################
89
90
91sub check_contents {
92  my $x = shift;
93
94  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
95  print $integrity ? "ok $N\n" : "not ok $N\n";
96  $N++;
97
98  local *FH = $o->{fh};
99  seek FH, 0, SEEK_SET;
100
101  my $a;
102  { local $/; $a = <FH> }
103  $a = "" unless defined $a;
104  if ($a eq $x) {
105    print "ok $N\n";
106  } else {
107    my $msg = ctrlfix("# expected <$x>, got <$a>");
108    print "not ok $N\n$msg\n";
109  }
110  $N++;
111}
112
113sub ctrlfix {
114  local $_ = shift;
115  s/\n/\\n/g;
116  s/\r/\\r/g;
117  $_;
118}
119
120END {
121  undef $o;
122  untie @a;
123  1 while unlink $file;
124}
125
126