Upgrade to Memoize 0.65.

p4raw-id: //depot/perl@10894

12 files changed, 210 insertions, 70 deletions

diff --git a/lib/Memoize/t/array_confusion.t b/lib/Memoize/t/array_confusion.t
new file mode 100644
index 0000000000..44847c36b7
--- /dev/null
+++ b/lib/Memoize/t/array_confusion.t
@@ -0,0 +1,43 @@
+#!/usr/bin/perl
+
+use lib '..';
+use Memoize 'memoize', 'unmemoize';
+
+sub reff {
+  return [1,2,3];
+
+}
+
+sub listf {
+  return (1,2,3);
+}
+
+print "1..6\n";
+
+memoize 'reff', LIST_CACHE => 'MERGE';
+print "ok 1\n";
+memoize 'listf';
+print "ok 2\n";
+
+$s = reff();
+@a = reff();
+print @a == 1 ? "ok 3\n" : "not ok 3\n";
+
+$s = listf();
+@a = listf();
+print @a == 3 ? "ok 4\n" : "not ok 4\n";
+
+unmemoize 'reff';
+memoize 'reff', LIST_CACHE => 'MERGE';
+unmemoize 'listf';
+memoize 'listf';
+
+@a = reff();
+$s = reff();
+print @a == 1 ? "ok 5\n" : "not ok 5\n";
+
+@a = listf();
+$s = listf();
+print @a == 3 ? "ok 6\n" : "not ok 6\n";
+
+
diff --git a/lib/Memoize/t/errors.t b/lib/Memoize/t/errors.t
index 4c74954855..27daa92b8f 100755
--- a/lib/Memoize/t/errors.t
+++ b/lib/Memoize/t/errors.t
@@ -17,14 +17,30 @@ print $@ ? "ok 3\n" : "not ok 3 # $@\n";
 
 # 4--8
 $n = 4;
+my $dummyfile = './dummydb';
+use Fcntl;
+my %args = ( DB_File => [],
+             GDBM_File => [$dummyfile, 2, 0666],
+             ODBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+             NDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+             SDBM_File => [$dummyfile, O_RDWR|O_CREAT, 0666],
+           );
 for $mod (qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File)) {
-  eval { memoize(sub {}, LIST_CACHE => ['TIE', $mod]) };
-  print $@ ? "ok $n\n" : "not ok $n # $@\n";
+  eval {
+    require "$mod.pm";
+    tie my %cache => $mod, @{$args{$mod}};
+    memoize(sub {}, LIST_CACHE => [HASH => \%cache ]);
+  };
+  print $@ =~ /can only store scalars/
+     || $@ =~ /Can't locate.*in \@INC/ ? "ok $n\n" : "not ok $n # $@\n";
+  1 while unlink $dummyfile;
   $n++;
 }
 
 # 9
-eval { memoize(sub {}, LIST_CACHE => ['TIE', WuggaWugga]) };
+eval { local $^W = 0;
+       memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga']) 
+     };
 print $@ ? "ok 9\n" : "not ok 9 # $@\n";
 
 # 10
diff --git a/lib/Memoize/t/expire.t b/lib/Memoize/t/expire.t
index 28cf559391..497e7a9fdd 100644
--- a/lib/Memoize/t/expire.t
+++ b/lib/Memoize/t/expire.t
@@ -17,7 +17,9 @@ sub id {
   $arg;
 }
 
-memoize 'id', SCALAR_CACHE => ['TIE', 'Memoize::ExpireTest'], 
+tie my %cache => 'Memoize::ExpireTest';
+memoize 'id', 
+  SCALAR_CACHE => [HASH => \%cache], 
   LIST_CACHE => 'FAULT';
 $n++; print "ok $n\n";
 
diff --git a/lib/Memoize/t/expire_file.t b/lib/Memoize/t/expire_file.t
index c6abb507ea..9959d00313 100644
--- a/lib/Memoize/t/expire_file.t
+++ b/lib/Memoize/t/expire_file.t
@@ -11,7 +11,7 @@ if (-e '.fast') {
   exit 0;
 }
 
-print "1..11\n";
+print "1..12\n";
 
 ++$n; print "ok $n\n";
 
@@ -34,8 +34,12 @@ sub readfile {
   $data;
 }
 
+require Memoize::ExpireFile;
+++$n; print "ok $n\n";
+
+tie my %cache => 'Memoize::ExpireFile';
 memoize 'readfile',
-    SCALAR_CACHE => ['TIE', 'Memoize::ExpireFile', ],
+    SCALAR_CACHE => [HASH => \%cache],
     LIST_CACHE => 'FAULT'
     ;
 
@@ -61,4 +65,4 @@ my $t3 = readfile($FILE);
 ++$n; print ((($READFILE_CALLS == 2) ? '' : 'not '), "ok $n\n");
 ++$n; print ((($t1 ne $t3) ? '' : 'not '), "ok $n\n");
 
-END { 1 while unlink 'TESTFILE' }
+END { 1 while unlink $FILE }
diff --git a/lib/Memoize/t/expire_module_n.t b/lib/Memoize/t/expire_module_n.t
index b6b4521f7b..7e5505a871 100644
--- a/lib/Memoize/t/expire_module_n.t
+++ b/lib/Memoize/t/expire_module_n.t
@@ -6,7 +6,7 @@ use Memoize;
 my $n = 0;
 
 
-print "1..21\n";
+print "1..22\n";
 
 ++$n; print "ok $n\n";
 
@@ -19,8 +19,12 @@ sub call {
   $RETURN;
 }
 
+require Memoize::Expire;
+++$n; print "ok $n\n";
+
+tie my %cache => 'Memoize::Expire', NUM_USES => 2;
 memoize 'call',
-    SCALAR_CACHE => ['TIE', 'Memoize::Expire', NUM_USES => 2],
+    SCALAR_CACHE => [HASH => \%cache],
     LIST_CACHE => 'FAULT';
 
 # $Memoize::Expire::DEBUG = 1;
@@ -56,5 +60,3 @@ for (0,1,2,3) {
   print "not " unless $CALLS{$_} == (1,2,2,1)[$_];
   ++$n; print "ok $n\n";
 }
-
-
diff --git a/lib/Memoize/t/expire_module_t.t b/lib/Memoize/t/expire_module_t.t
index 84ad4ed3d2..7032f65212 100644
--- a/lib/Memoize/t/expire_module_t.t
+++ b/lib/Memoize/t/expire_module_t.t
@@ -2,32 +2,55 @@
 
 use lib '..';
 use Memoize;
+use Time::HiRes 'time';
+my $DEBUG = 0;
 
 my $n = 0;
+$| = 1;
 
 if (-e '.fast') {
   print "1..0\n";
   exit 0;
 }
 
-print "# Warning: I'm testing the timed expiration policy.\n# This will take about thirty seconds.\n";
+# Perhaps nobody will notice if we don't say anything
+# print "# Warning: I'm testing the timed expiration policy.\n# This will take about thirty seconds.\n";
 
-print "1..14\n";
+print "1..15\n";
+$| = 1;
 
 ++$n; print "ok $n\n";
 
+require Memoize::Expire;
+++$n; print "ok $n\n";
+
 sub close_enough {
 #  print "Close enough? @_[0,1]\n";
   abs($_[0] - $_[1]) <= 1;
 }
 
+my $t0;
+sub start_timer {
+  $t0 = time;
+  $DEBUG and print "# $t0\n";
+}
+
+sub wait_until {
+  my $until = shift();
+  my $diff = $until - (time() - $t0);
+  $DEBUG and print "# until $until; diff = $diff\n";
+  return if $diff <= 0;
+  select undef, undef, undef, $diff;
+}
+
 sub now {
 #  print "NOW: @_ ", time(), "\n";
   time;
 }
 
+tie my %cache => 'Memoize::Expire', LIFETIME => 8;
 memoize 'now',
-    SCALAR_CACHE => ['TIE', 'Memoize::Expire', LIFETIME => 15],
+    SCALAR_CACHE => [HASH => \%cache ],
     LIST_CACHE => 'FAULT'
     ;
 
@@ -35,50 +58,51 @@ memoize 'now',
 
 
 # T
+start_timer();
 for (1,2,3) {
   $when{$_} = now($_);
   ++$n;
-  print "not " unless $when{$_} == time;
+  print "not " unless close_enough($when{$_}, time());
   print "ok $n\n";
-  sleep 5 if $_ < 3;
+  sleep 3 if $_ < 3;
+  $DEBUG and print "# ", time()-$t0, "\n";
 }
+# values will now expire at T=8, 11, 14
+# it is now T=6
 
-# T+10
+# T+6
 for (1,2,3) {
-  $again{$_} = now($_); # Should be the sameas before, because of memoization
+  $again{$_} = now($_); # Should be the same as before, because of memoization
 }
 
-# T+10
+# T+6
 foreach (1,2,3) {
   ++$n;
-  print "not " unless $when{$_} == $again{$_};
+  print "not " unless close_enough($when{$_}, $again{$_});
   print "ok $n\n";
 }
 
-sleep 6;  # now(1) expires
-
-# T+16 
+wait_until(9.5);  # now(1) expires
 print "not " unless close_enough(time, $again{1} = now(1));
 ++$n; print "ok $n\n";
 
-# T+16 
-foreach (2,3) {			# Have not expired yet.
+# T+9.5
+foreach (2,3) {			# Should not have expired yet.
   ++$n;
-  print "not " unless now($_) == $again{$_};
+  print "not " unless close_enough(scalar(now($_)), $again{$_});
   print "ok $n\n";
 }
 
-sleep 6;  # now(2) expires
+wait_until(12.5);  # now(2) expires
 
-# T+22
+# T+12.5
 print "not " unless close_enough(time, $again{2} = now(2));
 ++$n; print "ok $n\n";
 
-# T+22
-foreach (1,3) {
+# T+12.5
+foreach (1,3) {  # 1 is good again because it was recomputed after it expired
   ++$n;
-  print "not " unless now($_) == $again{$_};
+  print "not " unless close_enough(scalar(now($_)), $again{$_});
   print "ok $n\n";
 }
 
-
diff --git a/lib/Memoize/t/speed.t b/lib/Memoize/t/speed.t
index d887aae60c..ef30a8138d 100755
--- a/lib/Memoize/t/speed.t
+++ b/lib/Memoize/t/speed.t
@@ -7,11 +7,28 @@ if (-e '.fast') {
   print "1..0\n";
   exit 0;
 }
+$| = 1;
+
+# If we don't say anything, maybe nobody will notice.
+# print STDERR "\nWarning: I'm testing the speedup.  This might take up to thirty seconds.\n                    ";
 
-print  "# Warning: I'm testing the speedup.  This might take up to sixty seconds.\n";
 
 print "1..6\n";
 
+# This next test finds an example that takes a long time to run, then
+# checks to make sure that the run is actually speeded up by memoization.
+# In some sense, this is the most essential correctness test in the package.  
+#
+# We do this by running the fib() function with successfily larger
+# arguments until we find one that tales at leasrtt $LONG_RUN seconds
+# to execute.  Then we memoize fib() and run the same call cagain.  If
+# it doesn't produce the same test in less than one-tenth the time,
+# something is seriously wrong.
+#
+# $LONG_RUN is the number of seconds that the function call must last
+# in order for the call to be considered sufficiently long.
+
+
 sub fib {
   my $n = shift;
   $COUNT++;
@@ -19,20 +36,39 @@ sub fib {
   fib($n-1) + fib($n-2);
 }
 
-$N = 0;
+sub max { $_[0] > $_[1] ? 
+          $_[0] : $_[1] 
+        }
+
+$N = 1;
 
 $ELAPSED = 0;
-until ($ELAPSED > 10) {
-  $N++;
+
+my $LONG_RUN = 10;
+
+while (1) {
   my $start = time;
   $COUNT=0;
   $RESULT = fib($N);
   $ELAPSED = time - $start;
-  print "# fib($N) took $ELAPSED seconds.\n" if $N % 1 == 0;
+  last if $ELAPSED >= $LONG_RUN;
+  if ($ELAPSED > 1) {
+      print "# fib($N) took $ELAPSED seconds.\n" if $N % 1 == 0;
+      # we'd expect that fib(n+1) takes about 1.618 times as long as fib(n)
+      # so now that we have a longish run, let's estimate the value of $N
+      # that will get us a sufficiently long run.
+      $N += 1 + int(log($LONG_RUN/$ELAPSED)/log(1.618));
+      print "# OK, N=$N ought to do it.\n";
+      # It's important not to overshoot here because the running time
+      # is exponential in $N.  If we increase $N too aggressively,
+      # the user will be forced to wait a very long time.
+  } else {
+      $N++; 
+  }
 }
 
 print "# OK, fib($N) was slow enough; it took $ELAPSED seconds.\n";
-
+print "# Total calls: $COUNT.\n";
 
 &memoize('fib');
 
@@ -48,12 +84,12 @@ print (($ELAPSED/$ELAPSED2 > 10) ? "ok 2\n" : "not ok 2\n");
 print (($COUNT > $N) ? "ok 3\n" : "not ok 3\n");
 
 # Do it again. Should be even faster this time.
+$COUNT = 0;
 $start = time;
 $RESULT2 = fib($N);
 $ELAPSED2 = time - $start + .001; # prevent division by 0 errors
 
-
 print (($RESULT == $RESULT2) ? "ok 4\n" : "not ok 4\n");
 print (($ELAPSED/$ELAPSED2 > 10) ? "ok 5\n" : "not ok 5\n");
 # This time it shouldn't have called the function at all.
-print ($COUNT ? "ok 6\n" : "not ok 6\n");
+print ($COUNT == 0 ? "ok 6\n" : "not ok 6\n");
diff --git a/lib/Memoize/t/tie.t b/lib/Memoize/t/tie.t
index 098fb050b5..c006aacca6 100755
--- a/lib/Memoize/t/tie.t
+++ b/lib/Memoize/t/tie.t
@@ -31,25 +31,22 @@ if (eval {require File::Spec::Functions}) {
 }
 $file = catfile($tmpdir, "md$$");
 @files = ($file, "$file.db", "$file.dir", "$file.pag");
-{ 
-  my @present = grep -e, @files;
-  if (@present && (@failed = grep { not unlink } @present)) {
-    warn "Can't unlink @failed!  ($!)";
-  }
-}
+1 while unlink @files;
 
 
 tryout('Memoize::AnyDBM_File', $file, 1);  # Test 1..4
 # tryout('DB_File', $file, 1);  # Test 1..4
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
 
 sub tryout {
   my ($tiepack, $file, $testno) = @_;
 
+  tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+    or die $!;
 
   memoize 'c5', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR | O_CREAT, 0666], 
-  LIST_CACHE => 'FAULT'
+    SCALAR_CACHE => [HASH => \%cache],
+    LIST_CACHE => 'FAULT'
     ;
 
   my $t1 = c5($ARG);	
@@ -62,7 +59,7 @@ sub tryout {
   # Now something tricky---we'll memoize c23 with the wrong table that
   # has the 5 already cached.
   memoize 'c23', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR, 0666], 
+  SCALAR_CACHE => ['HASH', \%cache],
   LIST_CACHE => 'FAULT'
     ;
   
diff --git a/lib/Memoize/t/tie_gdbm.t b/lib/Memoize/t/tie_gdbm.t
index cd3915459c..e9f20a071e 100755
--- a/lib/Memoize/t/tie_gdbm.t
+++ b/lib/Memoize/t/tie_gdbm.t
@@ -33,16 +33,19 @@ if (eval {require File::Spec::Functions}) {
 }
 $tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
 $file = catfile($tmpdir, "md$$");
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
 tryout('GDBM_File', $file, 1);  # Test 1..4
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
 
 sub tryout {
+  require GDBM_File;
   my ($tiepack, $file, $testno) = @_;
 
+  tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+    or die $!;
 
   memoize 'c5', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR | O_CREAT, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
 
@@ -56,7 +59,7 @@ sub tryout {
   # Now something tricky---we'll memoize c23 with the wrong table that
   # has the 5 already cached.
   memoize 'c23', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
   
diff --git a/lib/Memoize/t/tie_ndbm.t b/lib/Memoize/t/tie_ndbm.t
index dfbd0f5858..0551446940 100644
--- a/lib/Memoize/t/tie_ndbm.t
+++ b/lib/Memoize/t/tie_ndbm.t
@@ -36,16 +36,19 @@ if (eval {require File::Spec::Functions}) {
 }
 $tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
 $file = catfile($tmpdir, "md$$");
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
 tryout('Memoize::NDBM_File', $file, 1);  # Test 1..4
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
 
 sub tryout {
   my ($tiepack, $file, $testno) = @_;
 
 
+  tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+    or die $!;
+
   memoize 'c5', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR | O_CREAT, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
 
@@ -59,7 +62,7 @@ sub tryout {
   # Now something tricky---we'll memoize c23 with the wrong table that
   # has the 5 already cached.
   memoize 'c23', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
   
diff --git a/lib/Memoize/t/tie_sdbm.t b/lib/Memoize/t/tie_sdbm.t
index c628d98c97..1a5a392240 100644
--- a/lib/Memoize/t/tie_sdbm.t
+++ b/lib/Memoize/t/tie_sdbm.t
@@ -3,7 +3,7 @@
 use lib qw(. ..);
 use Memoize 0.45 qw(memoize unmemoize);
 use Fcntl;
-# use Memoize::GDBM_File;
+use Memoize::SDBM_File;
 # $Memoize::GDBM_File::Verbose = 0;
 
 sub i {
@@ -20,7 +20,7 @@ sub n {
   $_[0]+1;
 }
 
-eval {require GDBM_File};
+eval {require SDBM_File};
 if ($@) {
   print "1..0\n";
   exit 0;
@@ -35,16 +35,18 @@ if (eval {require File::Spec::Functions}) {
 }
 $tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
 $file = catfile($tmpdir, "md$$");
-unlink $file, "$file.dir", "$file.pag";
-tryout('GDBM_File', $file, 1);  # Test 1..4
-unlink $file, "$file.dir", "$file.pag";
+1 while unlink $file, "$file.dir", "$file.pag";
+tryout('Memoize::SDBM_File', $file, 1);  # Test 1..4
+1 while unlink $file, "$file.dir", "$file.pag";
 
 sub tryout {
   my ($tiepack, $file, $testno) = @_;
 
+  tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
+    or die $!;
 
   memoize 'c5', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR | O_CREAT, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
 
@@ -58,7 +60,7 @@ sub tryout {
   # Now something tricky---we'll memoize c23 with the wrong table that
   # has the 5 already cached.
   memoize 'c23', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file, O_RDWR, 0666], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
   
diff --git a/lib/Memoize/t/tie_storable.t b/lib/Memoize/t/tie_storable.t
index 2dd77d0b4f..a1abafc424 100644
--- a/lib/Memoize/t/tie_storable.t
+++ b/lib/Memoize/t/tie_storable.t
@@ -3,9 +3,15 @@
 
 use lib qw(. ..);
 use Memoize 0.45 qw(memoize unmemoize);
-# use Memoize::Storable;
+use Memoize::Storable;
 # $Memoize::Storable::Verbose = 0;
 
+eval {require GDBM_File};
+if ($@) {
+  print "1..0\n";
+  exit 0;
+}
+
 sub i {
   $_[0];
 }
@@ -36,16 +42,18 @@ if (eval {require File::Spec::Functions}) {
 }
 $tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
 $file = catfile($tmpdir, "storable$$");
-unlink $file;
+1 while unlink $file;
 tryout('Memoize::Storable', $file, 1);  # Test 1..4
-unlink $file;
+1 while unlink $file;
 
 sub tryout {
   my ($tiepack, $file, $testno) = @_;
 
+  tie my %cache => $tiepack, $file
+    or die $!;
 
   memoize 'c5', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;
 
@@ -61,7 +69,7 @@ sub tryout {
   # Now something tricky---we'll memoize c23 with the wrong table that
   # has the 5 already cached.
   memoize 'c23', 
-  SCALAR_CACHE => ['TIE', $tiepack, $file], 
+  SCALAR_CACHE => [HASH => \%cache],
   LIST_CACHE => 'FAULT'
     ;