cpan/Tie-File/t/30_defer.t

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