3 # Deferred caching of varying size records
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.
12 my $file = "tf$$.txt";
13 # print "1..0\n"; exit;
14 $: = Tie::File::_default_recsep();
15 my $data = "$:1$:22$:";
22 print "ok $N\n"; $N++;
24 open F, "> $file" or die $!;
28 $o = tie @a, 'Tie::File', $file;
29 print $o ? "ok $N\n" : "not ok $N\n";
32 # (3-6) Deferred storage
35 check_contents($data); # nothing written yet
37 check_contents($data); # nothing written yet
41 check_contents($data . "333$:4444$:"); # now it's written
43 # (9-12) Deferred writing disabled?
45 check_contents("${data}999999999$:4444$:");
47 check_contents("${data}999999999$:88888888$:");
49 # (13-18) Now let's try two batches of records
53 check_contents($data); # nothing written yet
55 check_contents($data); # nothing written yet
57 check_contents("55555$:1$:aaaaaaaaaa$:");
59 # (19-22) Deferred writing past the end of the file
62 check_contents("55555$:1$:aaaaaaaaaa$:");
64 check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
67 # (23-26) Now two long batches
69 %l = qw(0 2 1 3 2 4 4 5 5 4 6 3);
73 check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
75 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
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
82 $a[$_] = "discarded" . $_ x $_;
84 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
86 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
88 ################################################################
94 my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
95 print $integrity ? "ok $N\n" : "not ok $N\n";
102 { local $/; $a = <FH> }
103 $a = "" unless defined $a;
107 my $msg = ctrlfix("# expected <$x>, got <$a>");
108 print "not ok $N\n$msg\n";
121 1 while unlink $file;