lib/Memoize/t/tie.t

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