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