lib/Memoize/t/tie.t

   1 #!/usr/bin/perl
   2
   3 use lib qw(. ..);
   4 use Memoize 0.52 qw(memoize unmemoize);
   5 use Fcntl;
   6 use Memoize::AnyDBM_File;
   7
   8 print "1..4\n";
   9
  10 sub i {
  11   $_[0];
  12 }
  13
  14 $ARG = 'Keith Bostic is a pinhead';
  15
  16 sub c119 { 119 }
  17 sub c7 { 7 }
  18 sub c43 { 43 }
  19 sub c23 { 23 }
  20 sub c5 { 5 }
  21
  22 sub n {
  23   $_[0]+1;
  24 }
  25
  26 if (eval {require File::Spec::Functions}) {
  27   File::Spec::Functions->import('tmpdir');
  28   $tmpdir = tmpdir();
  29 } else {
  30   *catfile = sub { join '/', @_ };
  31   $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
  32 }
  33 $file = catfile($tmpdir, "md$$");
  34 @files = ($file, "$file.db", "$file.dir", "$file.pag");
  35 1 while unlink @files;
  36
  37
  38 tryout('Memoize::AnyDBM_File', $file, 1);  # Test 1..4
  39 # tryout('DB_File', $file, 1);  # Test 1..4
  40 1 while unlink $file, "$file.dir", "$file.pag";
  41
  42 sub tryout {
  43   my ($tiepack, $file, $testno) = @_;
  44
  45   tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
  46     or die $!;
  47
  48   memoize 'c5',
  49     SCALAR_CACHE => [HASH => \%cache],
  50     LIST_CACHE => 'FAULT'
  51     ;
  52
  53   my $t1 = c5($ARG);
  54   my $t2 = c5($ARG);
  55   print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  56   $testno++;
  57   print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  58   unmemoize 'c5';
  59
  60   # Now something tricky---we'll memoize c23 with the wrong table that
  61   # has the 5 already cached.
  62   memoize 'c23',
  63   SCALAR_CACHE => ['HASH', \%cache],
  64   LIST_CACHE => 'FAULT'
  65     ;
  66
  67   my $t3 = c23($ARG);
  68   my $t4 = c23($ARG);
  69   $testno++;
  70   print (($t3 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t3\n");
  71   $testno++;
  72   print (($t4 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t4\n");
  73   unmemoize 'c23';
  74 }
  75
  76 {
  77   my @present = grep -e, @files;
  78   if (@present && (@failed = grep { not unlink } @present)) {
  79     warn "Can't unlink @failed!  ($!)";
  80   }
  81 }