lib/Tie/File/t/31_autodefer.t

   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
   9 use POSIX 'SEEK_SET';
  10
  11 my $file = "tf$$.txt";
  12 $: = Tie::File::_default_recsep();
  13 my $data = "rec0$:rec1$:rec2$:";
  14 my ($o, $n, @a);
  15
  16 print "1..65\n";
  17
  18 my $N = 1;
  19 use Tie::File;
  20 print "ok $N\n"; $N++;
  21
  22 open F, "> $file" or die $!;
  23 binmode F;
  24 print F $data;
  25 close F;
  26 $o = tie @a, 'Tie::File', $file;
  27 print $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";
  36 check_autodeferring('OFF');
  37 $a[4] = "rec4";
  38 check_autodeferring('OFF');
  39 $a[5] = "rec5";
  40 check_autodeferring('ON');
  41 check_contents($data . "rec3$:rec4$:"); # only the first two were written
  42 $a[6] = "rec6";
  43 check_autodeferring('ON');
  44 check_contents($data . "rec3$:rec4$:"); # still nothing written
  45 $a[7] = "rec7";
  46 check_autodeferring('ON');
  47 check_contents($data . "rec3$:rec4$:"); # still nothing written
  48 $a[0] = "recX";
  49 check_autodeferring('OFF');
  50 check_contents("recX$:rec1$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
  51 $a[1] = "recY";
  52 check_autodeferring('OFF');
  53 check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
  54 $a[2] = "recZ";                 # it kicks in here
  55 check_autodeferring('ON');
  56 check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
  57
  58 # (23-26) Explicitly enabling deferred writing deactivates autodeferring
  59 $o->defer;
  60 check_autodeferring('OFF');
  61 check_contents("recX$:recY$:recZ$:rec3$:rec4$:rec5$:rec6$:rec7$:");
  62 $o->discard;
  63 check_autodeferring('OFF');
  64
  65 # (27-32) Now let's try the CLEAR special case
  66 @a = ("r0" .. "r4");
  67 check_autodeferring('ON');
  68 # The file was extended to the right length, but nothing was actually written.
  69 check_contents("$:$:$:$:$:");
  70 $a[2] = "fish";
  71 check_autodeferring('OFF');
  72 check_contents("r0$:r1$:fish$:r3$:r4$:");
  73
  74 # (33-47) Now let's try the originally intended application:  a 'for' loop.
  75 my $it = 0;
  76 for (@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
  94 check_autodeferring('OFF');
  95 check_contents("##r0$:##r1$:##fish$:##r3$:##r4$:");
  96 @a = ("s0" .. "s4");
  97 check_autodeferring('OFF');
  98 check_contents("");
  99 $o->flush;
 100 check_autodeferring('OFF');
 101 check_contents("s0$:s1$:s2$:s3$:s4$:");
 102
 103 undef $o; untie @a;
 104
 105 # Limit cache+buffer size to 47 bytes
 106 my $MAX = 47;
 107 #  -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
 108 my $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;
 112 die $! 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);
 120 check_autodeferring('OFF');
 121 check_contents(join("$:", qw(0 1 2 3), ""));
 122
 123 # (60-62) Does the ->autodefer method work?
 124 $o->autodefer(1);
 125 @a = (10..13);
 126 check_autodeferring('ON');
 127 check_contents("$:$:$:$:");  # This might be unfortunate.
 128
 129 # (63-65) Does the ->autodefer method work?
 130 $o->autodefer(0);
 131 check_autodeferring('OFF');
 132 check_contents(join("$:", qw(10 11 12 13), ""));
 133
 134
 135 sub 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
 147 sub 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
 170 sub ctrlfix {
 171   for (@_) {
 172     s/\n/\\n/g;
 173     s/\r/\\r/g;
 174   }
 175 }
 176
 177 END {
 178   undef $o;
 179   untie @a;
 180   1 while unlink $file;
 181 }
 182