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..26\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 keys 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) 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
  66 # (5) Remove from empty heap
  67 $n = $h->expire;
  68 print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
  69 $N++;
  70
  71 # (6) Interleaved insert and removal
  72 $Q = 0;
  73 @R = ();
  74 for my $i (1..4) {
  75   for my $j (1..$i) {
  76     $h->insert($Q, "b$Q");
  77     $Q++;
  78   }
  79   for my $j (1..$i) {
  80     push @R, $h->expire;
  81   }
  82 }
  83 $iota = iota('b', 9);
  84 print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
  85 $N++;
  86
  87 # (7) It should be empty now
  88 print $h->is_empty ? "ok $N\n" : "not ok $N\n";
  89 $N++;
  90
  91 # (8) Insert and delete
  92 $Q = 1;
  93 for (1..10) {
  94   $h->insert($_, "c$Q");
  95   $Q++;
  96 }
  97 for (2, 4, 6, 8, 10) {
  98   $h->remove($_);
  99 }
 100 @R = ();
 101 push @R, $n while defined ($n = $h->expire);
 102 print "@R" eq "c1 c3 c5 c7 c9" ?
 103   "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n";
 104 $N++;
 105
 106 # (9) Interleaved insert and delete
 107 $Q = 1; my $QQ = 1;
 108 @R = ();
 109 for my $i (1..4) {
 110   for my $j (1..$i) {
 111     $h->insert($Q, "d$Q");
 112     $Q++;
 113   }
 114   for my $j (1..$i) {
 115     $h->remove($QQ) if $QQ % 2 == 0;
 116     $QQ++;
 117   }
 118 }
 119 push @R, $n while defined ($n = $h->expire);
 120 print "@R" eq "d1 d3 d5 d7 d9" ?
 121   "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n";
 122 $N++;
 123
 124 # (10) Promote
 125 $h->empty;
 126 $Q = 1;
 127 for (1..10) {
 128   $h->insert($_, "e$Q");
 129   unless ($h->_check_integrity) {
 130     die "Integrity failed after inserting ($_, e$Q)\n";
 131   }
 132   $Q++;
 133 }
 134 1;
 135 for (2, 4, 6, 8, 10) {
 136   $h->_promote($_);
 137 }
 138 @R = ();
 139 push @R, $n while defined ($n = $h->expire);
 140 print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ?
 141     "ok $N\n" :
 142     "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n";
 143 $N++;
 144
 145 # (11-15) Lookup
 146 $Q = 1;
 147 for (1..10) {
 148   $h->insert($_, "f$Q");
 149   $Q++;
 150 }
 151 1;
 152 for (2, 4, 6, 4, 8) {
 153   my $r = $h->lookup($_);
 154   print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n";
 155   $N++;
 156 }
 157
 158 # (16) It shouldn't be empty
 159 print ! $h->is_empty ? "ok $N\n" : "not ok $N\n";
 160 $N++;
 161
 162 # (17) Lookup should have promoted the looked-up records
 163 @R = ();
 164 push @R, $n while defined ($n = $h->expire);
 165 print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ?
 166   "ok $N\n" :
 167   "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n";
 168 $N++;
 169
 170 # (18-19) Typical 'rekey' operation
 171 $Q = 1;
 172 for (1..10) {
 173   $h->insert($_, "g$Q");
 174   $Q++;
 175 }
 176 $h->rekey([6,7,8,9,10], [8,9,10,11,12]);
 177 my %x = qw(1 g1 2 g2  3 g3  4 g4  5 g5
 178            8 g6 9 g7 10 g8 11 g9 12 g10);
 179 {
 180   my $good = 1;
 181   for my $k (keys %x) {
 182     my $v = $h->lookup($k);
 183     $v = "UNDEF" unless defined $v;
 184     unless ($v eq $x{$k}) {
 185       print "# looked up $k, got $v, expected $x{$k}\n";
 186       $good = 0;
 187     }
 188   }
 189   print $good ? "ok $N\n" : "not ok $N\n";
 190   $N++;
 191 }
 192 {
 193   my $good = 1;
 194   for my $k (6, 7) {
 195     my $v = $h->lookup($k);
 196     if (defined $v) {
 197       print "# looked up $k, got $v, should have been undef\n";
 198       $good = 0;
 199     }
 200   }
 201   print $good ? "ok $N\n" : "not ok $N\n";
 202   $N++;
 203 }
 204
 205 # (20) keys
 206 @R = sort { $a <=> $b } $h->keys;
 207 print "@R" eq "1 2 3 4 5 8 9 10 11 12" ?
 208   "ok $N\n" :
 209   "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n";
 210 $N++;
 211 1;
 212 # (21) update
 213 for (1..5, 8..12) {
 214   $h->update($_, "h$_");
 215 }
 216 @R = ();
 217 for (sort { $a <=> $b } $h->keys) {
 218   push @R, $h->lookup($_);
 219 }
 220 print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ?
 221   "ok $N\n" :
 222   "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n";
 223 $N++;
 224
 225 # (22-23) bytes
 226 my $B;
 227 $B = $h->bytes;
 228 print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n";
 229 $N++;
 230 $h->update('12', "yobgorgle");
 231 $B = $h->bytes;
 232 print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n";
 233 $N++;
 234
 235 # (24-25) empty
 236 $h->empty;
 237 print $h->is_empty ? "ok $N\n" : "not ok $N\n";
 238 $N++;
 239 $n = $h->expire;
 240 print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
 241 $N++;
 242
 243 # (26) very weak testing of DESTROY
 244 undef $h;
 245 # are we still alive?
 246 print "ok $N\n";
 247 $N++;
 248
 249
 250 sub iota {
 251   my ($p, $n) = @_;
 252   my $r;
 253   my $i = 0;
 254   while ($i <= $n) {
 255     $r .= "$p$i ";
 256     $i++;
 257   }
 258   chop $r;
 259   $r;
 260 }