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