lib/Tie/File/t/33_defer_vs.t

   1 #!/usr/bin/perl
   2 #
   3 # Deferred caching of varying size records
   4 #
   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.
   9 #
  10
  11 use POSIX 'SEEK_SET';
  12 my $file = "tf$$.txt";
  13 # print "1..0\n"; exit;
  14 $: = Tie::File::_default_recsep();
  15 my $data = "$:1$:22$:";
  16 my ($o, $n);
  17
  18 print "1..30\n";
  19
  20 my $N = 1;
  21 use Tie::File;
  22 print "ok $N\n"; $N++;
  23
  24 open F, "> $file" or die $!;
  25 binmode F;
  26 print F $data;
  27 close F;
  28 $o = tie @a, 'Tie::File', $file;
  29 print $o ? "ok $N\n" : "not ok $N\n";
  30 $N++;
  31
  32 # (3-6) Deferred storage
  33 $o->defer;
  34 $a[3] = "333";
  35 check_contents($data);          # nothing written yet
  36 $a[4] = "4444";
  37 check_contents($data);          # nothing written yet
  38
  39 # (7-8) Flush
  40 $o->flush;
  41 check_contents($data . "333$:4444$:");          # now it's written
  42
  43 # (9-12) Deferred writing disabled?
  44 $a[3] = "999999999";
  45 check_contents("${data}999999999$:4444$:");
  46 $a[4] = "88888888";
  47 check_contents("${data}999999999$:88888888$:");
  48
  49 # (13-18) Now let's try two batches of records
  50 $#a = 2;
  51 $o->defer;
  52 $a[0] = "55555";
  53 check_contents($data);          # nothing written yet
  54 $a[2] = "aaaaaaaaaa";
  55 check_contents($data);          # nothing written yet
  56 $o->flush;
  57 check_contents("55555$:1$:aaaaaaaaaa$:");
  58
  59 # (19-22) Deferred writing past the end of the file
  60 $o->defer;
  61 $a[4] = "7777777";
  62 check_contents("55555$:1$:aaaaaaaaaa$:");
  63 $o->flush;
  64 check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
  65
  66
  67 # (23-26) Now two long batches
  68 $o->defer;
  69 %l = qw(0 2  1 3  2 4  4 5  5 4  6 3);
  70 for (0..2, 4..6) {
  71   $a[$_] = $_ x $l{$_};
  72 }
  73 check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
  74 $o->flush;
  75 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
  76
  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
  79 # filling it up
  80 $o->defer;
  81 for (0, 3, 7) {
  82   $a[$_] = "discarded" . $_ x $_;
  83 }
  84 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
  85 $o->discard;
  86 check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
  87
  88 ################################################################
  89
  90
  91 sub check_contents {
  92   my $x = shift;
  93
  94   my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
  95   print $integrity ? "ok $N\n" : "not ok $N\n";
  96   $N++;
  97
  98   local *FH = $o->{fh};
  99   seek FH, 0, SEEK_SET;
 100
 101   my $a;
 102   { local $/; $a = <FH> }
 103   $a = "" unless defined $a;
 104   if ($a eq $x) {
 105     print "ok $N\n";
 106   } else {
 107     my $msg = ctrlfix("# expected <$x>, got <$a>");
 108     print "not ok $N\n$msg\n";
 109   }
 110   $N++;
 111 }
 112
 113 sub ctrlfix {
 114   local $_ = shift;
 115   s/\n/\\n/g;
 116   s/\r/\\r/g;
 117   $_;
 118 }
 119
 120 END {
 121   1 while unlink $file;
 122 }
 123