lib/Tie/File/t/30_defer.t

   1 #!/usr/bin/perl
   2 #
   3 # Check ->defer and ->flush methods
   4 #
   5
   6 use POSIX 'SEEK_SET';
   7 my $file = "tf$$.txt";
   8 $: = Tie::File::_default_recsep();
   9 my $data = "rec0$:rec1$:rec2$:";
  10 my ($o, $n);
  11
  12 print "1..79\n";
  13
  14 my $N = 1;
  15 use Tie::File;
  16 print "ok $N\n"; $N++;
  17
  18 open F, "> $file" or die $!;
  19 binmode F;
  20 print F $data;
  21 close F;
  22 $o = tie @a, 'Tie::File', $file;
  23 print $o ? "ok $N\n" : "not ok $N\n";
  24 $N++;
  25
  26 # (3-6) Deferred storage
  27 $o->defer;
  28 $a[3] = "rec3";
  29 check_contents($data);          # nothing written yet
  30 $a[4] = "rec4";
  31 check_contents($data);          # nothing written yet
  32
  33 # (7-8) Flush
  34 $o->flush;
  35 check_contents($data . "rec3$:rec4$:");          # now it's written
  36
  37 # (9-12) Deferred writing disabled?
  38 $a[3] = "rec9";
  39 check_contents("${data}rec9$:rec4$:");
  40 $a[4] = "rec8";
  41 check_contents("${data}rec9$:rec8$:");
  42
  43 # (13-18) Now let's try two batches of records
  44 $#a = 2;
  45 $o->defer;
  46 $a[0] = "record0";
  47 check_contents($data);          # nothing written yet
  48 $a[2] = "record2";
  49 check_contents($data);          # nothing written yet
  50 $o->flush;
  51 check_contents("record0$:rec1$:record2$:");
  52
  53 # (19-22) Deferred writing past the end of the file
  54 $o->defer;
  55 $a[4] = "record4";
  56 check_contents("record0$:rec1$:record2$:");
  57 $o->flush;
  58 check_contents("record0$:rec1$:record2$:$:record4$:");
  59
  60
  61 # (23-26) Now two long batches
  62 $o->defer;
  63 for (0..2, 4..6) {
  64   $a[$_] = "r$_";
  65 }
  66 check_contents("record0$:rec1$:record2$:$:record4$:");
  67 $o->flush;
  68 check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
  69
  70 # (27-30) Now let's make sure that discarded writes are really discarded
  71 # We have a 2Mib buffer here, so we can be sure that we aren't accidentally
  72 # filling it up
  73 $o->defer;
  74 for (0, 3, 7) {
  75   $a[$_] = "discarded$_";
  76 }
  77 check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
  78 $o->discard;
  79 check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
  80
  81 ################################################################
  82 #
  83 # Now we're going to test the results of a small memory limit
  84 #
  85 #
  86 undef $o;  untie @a;
  87 $data = join "$:", map("record$_", 0..7), "";  # records are 8 or 9 bytes long
  88 open F, "> $file" or die $!;
  89 binmode F;
  90 print F $data;
  91 close F;
  92
  93 # Limit cache+buffer size to 47 bytes
  94 my $MAX = 47;
  95 #  -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
  96 my $BUF = 20;
  97 #  -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
  98 $o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
  99 print $o ? "ok $N\n" : "not ok $N\n";
 100 $N++;
 101
 102 # (31-32) Fill up the read cache
 103 my @z;
 104 @z = @a;
 105 # the cache now contains records 3,4,5,6,7.
 106 check_caches({map(($_ => "record$_$:"), 3..7)},
 107              {});
 108
 109 # (33-44) See if overloading the defer starts by flushing the read cache
 110 # and then flushes out the defer
 111 $o->defer;
 112 $a[0] = "recordA";              # That should flush record 3 from the cache
 113 check_caches({map(($_ => "record$_$:"), 4..7)},
 114              {0 => "recordA$:"});
 115 check_contents($data);
 116
 117 $a[1] = "recordB";              # That should flush record 4 from the cache
 118 check_caches({map(($_ => "record$_$:"), 5..7)},
 119              {0 => "recordA$:",
 120               1 => "recordB$:"});
 121 check_contents($data);
 122
 123 $a[2] = "recordC";              # That should flush the whole darn defer
 124 # Flushing the defer requires looking up the true lengths of records
 125 # 0..2, which flushes out the read cache, leaving only 1..2 there.
 126 # Then the splicer updates the cached versions of 1..2 to contain the
 127 # new data
 128 check_caches({1 => "recordB$:", 2 => "recordC$:"},
 129              {});               # URRRP
 130 check_contents(join("$:", qw(recordA recordB recordC
 131                              record3 record4 record5 record6 record7)) . "$:");
 132
 133 $a[3] = "recordD";         # even though we flushed, deferring is STILL ENABLED
 134 check_caches({1 => "recordB$:", 2 => "recordC$:"},
 135              {3 => "recordD$:"});
 136 check_contents(join("$:", qw(recordA recordB recordC
 137                              record3 record4 record5 record6 record7)) . "$:");
 138
 139 # Check readcache-deferbuffer interactions
 140
 141 # (45-47) This should remove outdated data from the read cache
 142 $a[2] = "recordE";
 143 check_caches({1 => "recordB$:",                 },
 144              {3 => "recordD$:", 2 => "recordE$:"});
 145 check_contents(join("$:", qw(recordA recordB recordC
 146                              record3 record4 record5 record6 record7)) . "$:");
 147
 148 # (48-51) This should read back out of the defer buffer
 149 # without adding anything to the read cache
 150 my $z;
 151 $z = $a[2];
 152 print $z eq "recordE" ? "ok $N\n" : "not ok $N\n";  $N++;
 153 check_caches({1 => "recordB$:",                 },
 154              {3 => "recordD$:", 2 => "recordE$:"});
 155 check_contents(join("$:", qw(recordA recordB recordC
 156                              record3 record4 record5 record6 record7)) . "$:");
 157
 158 # (52-55) This should repopulate the read cache with a new record
 159 $z = $a[0];
 160 print $z eq "recordA" ? "ok $N\n" : "not ok $N\n";  $N++;
 161 check_caches({1 => "recordB$:", 0 => "recordA$:"},
 162              {3 => "recordD$:", 2 => "recordE$:"});
 163 check_contents(join("$:", qw(recordA recordB recordC
 164                              record3 record4 record5 record6 record7)) . "$:");
 165
 166 # (56-59) This should flush the LRU record from the read cache
 167 $z = $a[4];  $z = $a[5];
 168 print $z eq "record5" ? "ok $N\n" : "not ok $N\n";  $N++;
 169 check_caches({5 => "record5$:", 0 => "recordA$:", 4 => "record4$:"},
 170              {3 => "recordD$:", 2 => "recordE$:"});
 171 check_contents(join("$:", qw(recordA recordB recordC
 172                              record3 record4 record5 record6 record7)) . "$:");
 173
 174 # (60-63) This should FLUSH the deferred buffer
 175 # In doing so, it will read in records 2 and 3, flushing 0 and 4
 176 # from the read cache, leaving 2, 3, and 5.
 177 $z = splice @a, 3, 1, "recordZ";
 178 print $z eq "recordD" ? "ok $N\n" : "not ok $N\n";  $N++;
 179 check_caches({5 => "record5$:", 3 => "recordZ$:", 2 => "recordE$:"},
 180              {});
 181 check_contents(join("$:", qw(recordA recordB recordE
 182                              recordZ record4 record5 record6 record7)) . "$:");
 183
 184 # (64-66) We should STILL be in deferred writing mode
 185 $a[5] = "recordX";
 186 check_caches({3 => "recordZ$:", 2 => "recordE$:"},
 187              {5 => "recordX$:"});
 188 check_contents(join("$:", qw(recordA recordB recordE
 189                              recordZ record4 record5 record6 record7)) . "$:");
 190
 191 # Fill up the defer buffer again
 192 $a[4] = "recordP";
 193 # (67-69) This should OVERWRITE the existing deferred record
 194 # and NOT flush the buffer
 195 $a[5] = "recordQ";
 196 check_caches({3 => "recordZ$:", 2 => "recordE$:"},
 197              {5 => "recordQ$:", 4 => "recordP$:"});
 198 check_contents(join("$:", qw(recordA recordB recordE
 199                              recordZ record4 record5 record6 record7)) . "$:");
 200
 201
 202 # (70-72) Discard should just dump the whole deferbuffer
 203 $o->discard;
 204 check_caches({3 => "recordZ$:", 2 => "recordE$:"},
 205              {});
 206 check_contents(join("$:", qw(recordA recordB recordE
 207                              recordZ record4 record5 record6 record7)) . "$:");
 208 # (73-75) NOW we are out of deferred writing mode
 209 $a[0] = "recordF";
 210 check_caches({3 => "recordZ$:", 2 => "recordE$:", 0 => "recordF$:"},
 211              {});
 212 check_contents(join("$:", qw(recordF recordB recordE
 213                              recordZ record4 record5 record6 record7)) . "$:");
 214
 215 # (76-79) Last call--untying the array should flush the deferbuffer
 216 $o->defer;
 217 $a[0] = "flushed";
 218 check_caches({3 => "recordZ$:", 2 => "recordE$:"},
 219              {0 => "flushed$:" });
 220 check_contents(join("$:", qw(recordF recordB recordE
 221                              recordZ record4 record5 record6 record7)) . "$:");
 222 undef $o;
 223 untie @a;
 224 # (79) We can't use check_contents any more, because the object is dead
 225 open F, "< $file" or die;
 226 binmode F;
 227 { local $/ ; $z = <F> }
 228 close F;
 229 my $x = join("$:", qw(flushed recordB recordE
 230                       recordZ record4 record5 record6 record7)) . "$:";
 231 if ($z eq $x) {
 232   print "ok $N\n";
 233 } else {
 234   my $msg = ctrlfix("expected <$x>, got <$z>");
 235   print "not ok $N \# $msg\n";
 236 }
 237 $N++;
 238
 239 ################################################################
 240
 241
 242 sub check_caches {
 243   my ($xcache, $xdefer) = @_;
 244
 245 #  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 246 #  print $integrity ? "ok $N\n" : "not ok $N\n";
 247 #  $N++;
 248
 249   my $good = 1;
 250   $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
 251   $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
 252   print $good ? "ok $N\n" : "not ok $N\n";
 253   $N++;
 254 }
 255
 256 sub hash_equal {
 257   my ($a, $b, $ha, $hb) = @_;
 258   $ha = 'first hash'  unless defined $ha;
 259   $hb = 'second hash' unless defined $hb;
 260
 261   my $good = 1;
 262   my %b_seen;
 263
 264   for my $k (keys %$a) {
 265     if (! exists $b->{$k}) {
 266       print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
 267       $good = 0;
 268     } elsif ($b->{$k} ne $a->{$k}) {
 269       print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
 270       $b_seen{$k} = 1;
 271       $good = 0;
 272     } else {
 273       $b_seen{$k} = 1;
 274     }
 275   }
 276
 277   for my $k (keys %$b) {
 278     unless ($b_seen{$k}) {
 279       print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
 280       $good = 0;
 281     }
 282   }
 283
 284   $good;
 285 }
 286
 287
 288 sub check_contents {
 289   my $x = shift;
 290
 291   my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 292   print $integrity ? "ok $N\n" : "not ok $N\n";
 293   $N++;
 294
 295   local *FH = $o->{fh};
 296   seek FH, 0, SEEK_SET;
 297
 298   my $a;
 299   { local $/; $a = <FH> }
 300   $a = "" unless defined $a;
 301   if ($a eq $x) {
 302     print "ok $N\n";
 303   } else {
 304     my $msg = ctrlfix("# expected <$x>, got <$a>");
 305     print "not ok $N\n$msg\n";
 306   }
 307   $N++;
 308 }
 309
 310 sub ctrlfix {
 311   local $_ = shift;
 312   s/\n/\\n/g;
 313   s/\r/\\r/g;
 314   $_;
 315 }
 316
 317 END {
 318   1 while unlink $file;
 319 }
 320