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