ext/Tie-File/t/20_cache_full.t

   1 #!/usr/bin/perl
   2 #
   3 # Tests for various caching errors
   4 #
   5
   6 my $file = "tf$$.txt";
   7 $: = Tie::File::_default_recsep();
   8 my $data = join $:, "record0" .. "record9", "";
   9 my $V = $ENV{INTEGRITY};        # Verbose integrity checking?
  10
  11 print "1..111\n";
  12
  13 my $N = 1;
  14 use Tie::File;
  15 print "ok $N\n"; $N++;
  16
  17 open F, "> $file" or die $!;
  18 binmode F;
  19 print F $data;
  20 close F;
  21
  22 # Limit cache size to 30 bytes
  23 my $MAX = 30;
  24 #  -- that's enough space for 3 records, but not 4, on both \n and \r\n systems
  25 my $o = tie @a, 'Tie::File', $file, memory => $MAX, autodefer => 0;
  26 print $o ? "ok $N\n" : "not ok $N\n";
  27 $N++;
  28
  29 # (3-5) Let's see if data was properly expired from the cache
  30 my @z = @a;                     # force cache to contain all ten records
  31 # It should now contain only the *last* three records, 7, 8, and 9
  32 {
  33   my $x = "7 8 9";
  34   my $a = join " ", sort $o->{cache}->ckeys;
  35   if ($a eq $x) { print "ok $N\n" }
  36   else { print "not ok $N # cache keys were <$a>; expected <$x>\n" }
  37   $N++;
  38 }
  39 check();
  40
  41 # Here we redo *all* the splice tests, with populate()
  42 # calls before each one, to make sure that splice() does not botch the cache.
  43
  44 # (6-25) splicing at the beginning
  45 splice(@a, 0, 0, "rec4");
  46 check();
  47 splice(@a, 0, 1, "rec5");       # same length
  48 check();
  49 splice(@a, 0, 1, "record5");    # longer
  50 check();
  51 splice(@a, 0, 1, "r5");         # shorter
  52 check();
  53 splice(@a, 0, 1);               # removal
  54 check();
  55 splice(@a, 0, 0);               # no-op
  56 check();
  57
  58 splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
  59 check();
  60 splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
  61 check();
  62 splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
  63 check();
  64 splice(@a, 0, 2);               # delete more than one
  65 check();
  66
  67
  68 # (26-45) splicing in the middle
  69 splice(@a, 1, 0, "rec4");
  70 check();
  71 splice(@a, 1, 1, "rec5");       # same length
  72 check();
  73 splice(@a, 1, 1, "record5");    # longer
  74 check();
  75 splice(@a, 1, 1, "r5");         # shorter
  76 check();
  77 splice(@a, 1, 1);               # removal
  78 check();
  79 splice(@a, 1, 0);               # no-op
  80 check();
  81
  82 splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
  83 check();
  84 splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
  85 check();
  86 splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
  87 check();
  88 splice(@a, 1, 2);               # delete more than one
  89 check();
  90
  91 # (46-65) splicing at the end
  92 splice(@a, 3, 0, "rec4");
  93 check();
  94 splice(@a, 3, 1, "rec5");       # same length
  95 check();
  96 splice(@a, 3, 1, "record5");    # longer
  97 check();
  98 splice(@a, 3, 1, "r5");         # shorter
  99 check();
 100 splice(@a, 3, 1);               # removal
 101 check();
 102 splice(@a, 3, 0);               # no-op
 103 check();
 104
 105 splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
 106 check();
 107 splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
 108 check();
 109 splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
 110 check();
 111 splice(@a, 3, 2);               # delete more than one
 112 check();
 113
 114 # (66-85) splicing with negative subscript
 115 splice(@a, -1, 0, "rec4");
 116 check();
 117 splice(@a, -1, 1, "rec5");       # same length
 118 check();
 119 splice(@a, -1, 1, "record5");    # longer
 120 check();
 121 splice(@a, -1, 1, "r5");         # shorter
 122 check();
 123 splice(@a, -1, 1);               # removal
 124 check();
 125 splice(@a, -1, 0);               # no-op
 126 check();
 127
 128 splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
 129 check();
 130 splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
 131 check();
 132 splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
 133 check();
 134 splice(@a, -4, 3);               # delete more than one
 135 check();
 136
 137 # (86-87) scrub it all out
 138 splice(@a, 0, 3);
 139 check();
 140
 141 # (88-89) put some back in
 142 splice(@a, 0, 0, "rec0", "rec1");
 143 check();
 144
 145 # (90-91) what if we remove too many records?
 146 splice(@a, 0, 17);
 147 check();
 148
 149 # (92-95) In the past, splicing past the end was not correctly detected
 150 # (1.14)
 151 splice(@a, 89, 3);
 152 check();
 153 splice(@a, @a, 3);
 154 check();
 155
 156 # (96-99) Also we did not emulate splice's freaky behavior when inserting
 157 # past the end of the array (1.14)
 158 splice(@a, 89, 0, "I", "like", "pie");
 159 check();
 160 splice(@a, 89, 0, "pie pie pie");
 161 check();
 162
 163 # (100-105) Test default arguments
 164 splice @a, 0, 0, (0..11);
 165 check();
 166 splice @a, 4;
 167 check();
 168 splice @a;
 169 check();
 170
 171 # (106-111) One last set of tests.  I don't know what state the cache
 172 # is in now.  But if I read any three records, those three records are
 173 # what should be in the cache, and nothing else.
 174 @a = "record0" .. "record9";
 175 check(); # In 0.18 #107 fails here--STORE was not flushing the cache when
 176          # replacing an old cached record with a longer one
 177 for (5, 6, 1) { my $z = $a[$_] }
 178 {
 179   my $x = "5 6 1";
 180   my $a = join " ", $o->{cache}->_produce_lru;
 181   if ($a eq $x) { print "ok $N\n" }
 182   else { print "not ok $N # LRU was <$a>; expected <$x>\n" }
 183   $N++;
 184   $x = "1 5 6";
 185   $a = join " ", sort $o->{cache}->ckeys;
 186   if ($a eq $x) { print "ok $N\n" }
 187   else { print "not ok $N # cache keys were <$a>; expected <$x>\n" }
 188   $N++;
 189 }
 190 check();
 191
 192
 193 sub init_file {
 194   my $data = shift;
 195   open F, "> $file" or die $!;
 196   binmode F;
 197   print F $data;
 198   close F;
 199 }
 200
 201 sub check {
 202   my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
 203   print $integrity ? "ok $N\n" : "not ok $N\n";
 204   $N++;
 205
 206   my $b = $o->{cache}->bytes;
 207   print $b <= $MAX
 208     ? "ok $N\n"
 209     : "not ok $N # $b bytes cached, should be <= $MAX\n";
 210   $N++;
 211 }
 212
 213
 214 sub ctrlfix {
 215   for (@_) {
 216     s/\n/\\n/g;
 217     s/\r/\\r/g;
 218   }
 219 }
 220
 221 END {
 222   undef $o;
 223   untie @a;
 224   1 while unlink $file;
 225 }
 226
 227
 228