lib/Tie/File/t/40_abs_cache.t

   1 #!/usr/bin/perl
   2 #
   3 # Unit tests for abstract cache implementation
   4 #
   5 # Test the following methods:
   6 # * new()
   7 # * is_empty()
   8 # * empty()
   9 # * lookup(key)
  10 # * remove(key)
  11 # * insert(key,val)
  12 # * update(key,val)
  13 # * rekey(okeys,nkeys)
  14 # * expire()
  15 # * keys()
  16 # * bytes()
  17 # DESTROY()
  18 #
  19 # 20020327 You somehow managed to miss:
  20 # * reduce_size_to(bytes)
  21 #
  22
  23 # print "1..0\n"; exit;
  24 print "1..42\n";
  25
  26 my ($N, @R, $Q, $ar) = (1);
  27
  28 use Tie::File;
  29 print "ok $N\n";
  30 $N++;
  31
  32 my $h = Tie::File::Cache->new(10000) or die;
  33 print "ok $N\n";
  34 $N++;
  35
  36 # (3) Are all the methods there?
  37 {
  38   my $good = 1;
  39   for my $meth (qw(new is_empty empty lookup remove
  40                  insert update rekey expire ckeys bytes
  41                    set_limit adj_limit flush  reduce_size_to
  42                    _produce _produce_lru )) {
  43     unless ($h->can($meth)) {
  44       print STDERR "# Method '$meth' is missing.\n";
  45       $good = 0;
  46     }
  47   }
  48   print $good ? "ok $N\n" : "not ok $N\n";
  49   $N++;
  50 }
  51
  52 # (4-5) Straight insert and removal FIFO test
  53 $ar = 'a0';
  54 for (1..10) {
  55   $h->insert($_, $ar++);
  56 }
  57 1;
  58 for (1..10) {
  59   push @R, $h->expire;
  60 }
  61 $iota = iota('a',9);
  62 print "@R" eq $iota
  63   ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
  64 $N++;
  65 check($h);
  66
  67 # (6-7) Remove from empty heap
  68 $n = $h->expire;
  69 print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
  70 $N++;
  71 check($h);
  72
  73 # (8-9) Interleaved insert and removal
  74 $Q = 0;
  75 @R = ();
  76 for my $i (1..4) {
  77   for my $j (1..$i) {
  78     $h->insert($Q, "b$Q");
  79     $Q++;
  80   }
  81   for my $j (1..$i) {
  82     push @R, $h->expire;
  83   }
  84 }
  85 $iota = iota('b', 9);
  86 print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
  87 $N++;
  88 check($h);
  89
  90 # (10) It should be empty now
  91 print $h->is_empty ? "ok $N\n" : "not ok $N\n";
  92 $N++;
  93
  94 # (11-12) Insert and delete
  95 $Q = 1;
  96 for (1..10) {
  97   $h->insert($_, "c$Q");
  98   $Q++;
  99 }
 100 for (2, 4, 6, 8, 10) {
 101   $h->remove($_);
 102 }
 103 @R = ();
 104 push @R, $n while defined ($n = $h->expire);
 105 print "@R" eq "c1 c3 c5 c7 c9" ?
 106   "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n";
 107 $N++;
 108 check($h);
 109
 110 # (13-14) Interleaved insert and delete
 111 $Q = 1; my $QQ = 1;
 112 @R = ();
 113 for my $i (1..4) {
 114   for my $j (1..$i) {
 115     $h->insert($Q, "d$Q");
 116     $Q++;
 117   }
 118   for my $j (1..$i) {
 119     $h->remove($QQ) if $QQ % 2 == 0;
 120     $QQ++;
 121   }
 122 }
 123 push @R, $n while defined ($n = $h->expire);
 124 print "@R" eq "d1 d3 d5 d7 d9" ?
 125   "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n";
 126 $N++;
 127 check($h);
 128
 129 # (15-16) Promote
 130 $h->empty;
 131 $Q = 1;
 132 for (1..10) {
 133   $h->insert($_, "e$Q");
 134   unless ($h->_check_integrity) {
 135     die "Integrity failed after inserting ($_, e$Q)\n";
 136   }
 137   $Q++;
 138 }
 139 1;
 140 for (2, 4, 6, 8, 10) {
 141   $h->_promote($_);
 142 }
 143 @R = ();
 144 push @R, $n while defined ($n = $h->expire);
 145 print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ?
 146     "ok $N\n" :
 147     "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n";
 148 $N++;
 149 check($h);
 150
 151 # (17-22) Lookup
 152 $Q = 1;
 153 for (1..10) {
 154   $h->insert($_, "f$Q");
 155   $Q++;
 156 }
 157 1;
 158 for (2, 4, 6, 4, 8) {
 159   my $r = $h->lookup($_);
 160   print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n";
 161   $N++;
 162 }
 163 check($h);
 164
 165 # (23) It shouldn't be empty
 166 print ! $h->is_empty ? "ok $N\n" : "not ok $N\n";
 167 $N++;
 168
 169 # (24-25) Lookup should have promoted the looked-up records
 170 @R = ();
 171 push @R, $n while defined ($n = $h->expire);
 172 print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ?
 173   "ok $N\n" :
 174   "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n";
 175 $N++;
 176 check($h);
 177
 178 # (26-29) Typical 'rekey' operation
 179 $Q = 1;
 180 for (1..10) {
 181   $h->insert($_, "g$Q");
 182   $Q++;
 183 }
 184 $h->rekey([6,7,8,9,10], [8,9,10,11,12]);
 185 my %x = qw(1 g1 2 g2  3 g3  4 g4  5 g5
 186            8 g6 9 g7 10 g8 11 g9 12 g10);
 187 {
 188   my $good = 1;
 189   for my $k (keys %x) {
 190     my $v = $h->lookup($k);
 191     $v = "UNDEF" unless defined $v;
 192     unless ($v eq $x{$k}) {
 193       print "# looked up $k, got $v, expected $x{$k}\n";
 194       $good = 0;
 195     }
 196   }
 197   print $good ? "ok $N\n" : "not ok $N\n";
 198   $N++;
 199 }
 200 check($h);
 201 {
 202   my $good = 1;
 203   for my $k (6, 7) {
 204     my $v = $h->lookup($k);
 205     if (defined $v) {
 206       print "# looked up $k, got $v, should have been undef\n";
 207       $good = 0;
 208     }
 209   }
 210   print $good ? "ok $N\n" : "not ok $N\n";
 211   $N++;
 212 }
 213 check($h);
 214
 215 # (30-31) ckeys
 216 @R = sort { $a <=> $b } $h->ckeys;
 217 print "@R" eq "1 2 3 4 5 8 9 10 11 12" ?
 218   "ok $N\n" :
 219   "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n";
 220 $N++;
 221 check($h);
 222 1;
 223 # (32-33) update
 224 for (1..5, 8..12) {
 225   $h->update($_, "h$_");
 226 }
 227 @R = ();
 228 for (sort { $a <=> $b } $h->ckeys) {
 229   push @R, $h->lookup($_);
 230 }
 231 print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ?
 232   "ok $N\n" :
 233   "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n";
 234 $N++;
 235 check($h);
 236
 237 # (34-37) bytes
 238 my $B;
 239 $B = $h->bytes;
 240 print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n";
 241 $N++;
 242 check($h);
 243 $h->update('12', "yobgorgle");
 244 $B = $h->bytes;
 245 print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n";
 246 $N++;
 247 check($h);
 248
 249 # (38-41) empty
 250 $h->empty;
 251 print $h->is_empty ? "ok $N\n" : "not ok $N\n";
 252 $N++;
 253 check($h);
 254 $n = $h->expire;
 255 print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
 256 $N++;
 257 check($h);
 258
 259 # (42) very weak testing of DESTROY
 260 undef $h;
 261 # are we still alive?
 262 print "ok $N\n";
 263 $N++;
 264
 265 sub check {
 266   my $h = shift;
 267   print $h->_check_integrity ? "ok $N\n" : "not ok $N\n";
 268   $N++;
 269 }
 270
 271 sub iota {
 272   my ($p, $n) = @_;
 273   my $r;
 274   my $i = 0;
 275   while ($i <= $n) {
 276     $r .= "$p$i ";
 277     $i++;
 278   }
 279   chop $r;
 280   $r;
 281 }