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 $tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';
  27 if (eval {require File::Spec::Functions}) {
  28  File::Spec::Functions->import();
  29 } else {
  30   *catfile = sub { join '/', @_ };
  31 }
  32 $file = catfile($tmpdir, "md$$");
  33 @files = ($file, "$file.db", "$file.dir", "$file.pag");
  34 {
  35   my @present = grep -e, @files;
  36   if (@present && (@failed = grep { not unlink } @present)) {
  37     warn "Can't unlink @failed!  ($!)";
  38   }
  39 }
  40
  41
  42 tryout('Memoize::AnyDBM_File', $file, 1);  # Test 1..4
  43 # tryout('DB_File', $file, 1);  # Test 1..4
  44 unlink $file, "$file.dir", "$file.pag";
  45
  46 sub tryout {
  47   my ($tiepack, $file, $testno) = @_;
  48
  49
  50   memoize 'c5',
  51   SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR | O_CREAT, 0666],
  52   LIST_CACHE => 'FAULT'
  53     ;
  54
  55   my $t1 = c5($ARG);
  56   my $t2 = c5($ARG);
  57   print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  58   $testno++;
  59   print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  60   unmemoize 'c5';
  61
  62   # Now something tricky---we'll memoize c23 with the wrong table that
  63   # has the 5 already cached.
  64   memoize 'c23',
  65   SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR, 0666],
  66   LIST_CACHE => 'FAULT'
  67     ;
  68
  69   my $t3 = c23($ARG);
  70   my $t4 = c23($ARG);
  71   $testno++;
  72   print (($t3 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t3\n");
  73   $testno++;
  74   print (($t4 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t4\n");
  75   unmemoize 'c23';
  76 }
  77
  78 {
  79   my @present = grep -e, @files;
  80   if (@present && (@failed = grep { not unlink } @present)) {
  81     warn "Can't unlink @failed!  ($!)";
  82   }
  83 }