dslinux/user/perl/lib/Memoize/t array.t array_confusion.t correctness.t errors.t expfile.t expire.t expmod_n.t expmod_t.t flush.t normalize.t prototype.t speed.t tie.t tie_gdbm.t tie_ndbm.t tie_sdbm.t tie_storable.t tiefeatures.t unmemoize.t

Tue Dec 5 05:27:15 CET 2006

Update of /cvsroot/dslinux/dslinux/user/perl/lib/Memoize/t
In directory antilope:/tmp/cvs-serv7729/lib/Memoize/t

Added Files:
	array.t array_confusion.t correctness.t errors.t expfile.t 
	expire.t expmod_n.t expmod_t.t flush.t normalize.t prototype.t 
	speed.t tie.t tie_gdbm.t tie_ndbm.t tie_sdbm.t tie_storable.t 
	tiefeatures.t unmemoize.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: normalize.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

print "1..7\n";

sub n_null { '' }

{ my $I = 0;
  sub n_diff { $I++ }
}

{ my $I = 0;
  sub a1 { $I++; "$_[0]-$I"  }
  my $J = 0;
  sub a2 { $J++; "$_[0]-$J"  }
  my $K = 0;
  sub a3 { $K++; "$_[0]-$K"  }
}

my $a_normal =  memoize('a1', INSTALL => undef);
my $a_nomemo =  memoize('a2', INSTALL => undef, NORMALIZER => 'n_diff');
my $a_allmemo = memoize('a3', INSTALL => undef, NORMALIZER => 'n_null');

@ARGS = (1, 2, 3, 2, 1);

@res  = map { &$a_normal($_) } @ARGS;
print ((("@res" eq "1-1 2-2 3-3 2-2 1-1") ? '' : 'not '), "ok 1\n");

@res  = map { &$a_nomemo($_) } @ARGS;
print ((("@res" eq "1-1 2-2 3-3 2-4 1-5") ? '' : 'not '), "ok 2\n");

@res = map { &$a_allmemo($_) } @ARGS;
print ((("@res" eq "1-1 1-1 1-1 1-1 1-1") ? '' : 'not '), "ok 3\n");

# Test fully-qualified name and installation
$COUNT = 0;
sub parity { $COUNT++; $_[0] % 2 }
sub parnorm { $_[0] % 2 }
memoize('parity', NORMALIZER =>  'main::parnorm');
@res = map { &parity($_) } @ARGS;
print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 4\n");
print (( ($COUNT == 2) ? '' : 'not '), "ok 5\n");

# Test normalization with reference to normalizer function
$COUNT = 0;
sub par2 { $COUNT++; $_[0] % 2 }
memoize('par2', NORMALIZER =>  \&parnorm);
@res = map { &par2($_) } @ARGS;
print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 6\n");
print (( ($COUNT == 2) ? '' : 'not '), "ok 7\n");

--- NEW FILE: expire.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;
use Memoize::ExpireTest;

my $n = 0;

print "1..17\n";

$n++; print "ok $n\n";

my %CALLS;
sub id {	
  my($arg) = @_;
  ++$CALLS{$arg};
  $arg;
}

tie my %cache => 'Memoize::ExpireTest';
memoize 'id', 
  SCALAR_CACHE => [HASH => \%cache], 
  LIST_CACHE => 'FAULT';
$n++; print "ok $n\n";

for $i (1, 2, 3, 1, 2, 1) {
  $n++;
  unless ($i == id($i)) {
    print "not ";
  }
  print "ok $n\n";
}

for $i (1, 2, 3) {
  $n++;
  unless ($CALLS{$i} == 1) {
    print "not ";
  }
  print "ok $n\n";
}

Memoize::ExpireTest::expire(1);

for $i (1, 2, 3) {
  my $v = id($i);
}

for $i (1, 2, 3) {
  $n++;
  unless ($CALLS{$i} == 1 + ($i == 1)) {
    print "not ";
  }
  print "ok $n\n";
}

Memoize::ExpireTest::expire(1);
Memoize::ExpireTest::expire(2);

for $i (1, 2, 3) {
  my $v = id($i);
}

for $i (1, 2, 3) {
  $n++;
  unless ($CALLS{$i} == 4 - $i) {
    print "not ";
  }
  print "ok $n\n";
}

exit 0;

--- NEW FILE: flush.t ---
#!/usr/bin/perl

use lib '..';
use Memoize 'flush_cache', 'memoize';
print "1..8\n";
print "ok 1\n";

my $V = 100;
sub VAL { $V }

memoize 'VAL';
print "ok 2\n";

my $c1 = VAL();
print (($c1 == 100) ? "ok 3\n" : "not ok 3\n");

$V = 200;
$c1 = VAL();
print (($c1 == 100) ? "ok 4\n" : "not ok 4\n");

flush_cache('VAL');
$c1 = VAL();
print (($c1 == 200) ? "ok 5\n" : "not ok 5\n");

$V = 300;
$c1 = VAL();
print (($c1 == 200) ? "ok 6\n" : "not ok 6\n");

flush_cache(\&VAL);
$c1 = VAL();
print (($c1 == 300) ? "ok 7\n" : "not ok 7\n");

$V = 400;
$c1 = VAL();
print (($c1 == 300) ? "ok 8\n" : "not ok 8\n");

--- NEW FILE: expmod_t.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;
BEGIN {
  eval {require Time::HiRes};
  if ($@ || $ENV{SLOW}) {
#    $SLOW_TESTS = 1;
  } else {
    'Time::HiRes'->import('time');
  }
}

my $DEBUG = 0;

my $n = 0;
$| = 1;

if (-e '.fast') {
  print "1..0\n";
  exit 0;
}

# 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..15\n";
$| = 1;

# (1)
++$n; print "ok $n\n";

# (2)
require Memoize::Expire;
++$n; print "ok $n\n";

sub close_enough {
#  print "Close enough? @_[0,1]\n";
  abs($_[0] - $_[1]) <= 2;
}

sub very_close {
#  print "Close enough? @_[0,1]\n";
  abs($_[0] - $_[1]) <= 0.01;
}

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 => 15;
memoize 'now',
    SCALAR_CACHE => [HASH => \%cache ],
    LIST_CACHE => 'FAULT'
    ;

# (3)
++$n; print "ok $n\n";

# (4-6)
# T
start_timer();
for (1,2,3) {
  $when{$_} = now($_);
  ++$n;
  print "not " unless close_enough($when{$_}, time());
  print "ok $n\n";
  sleep 6 if $_ < 3;
  $DEBUG and print "# ", time()-$t0, "\n";
}
# values will now expire at T=15, 21, 27
# it is now T=12

# T+12
for (1,2,3) {
  $again{$_} = now($_); # Should be the same as before, because of memoization
}

# (7-9)
# T+12
foreach (1,2,3) {
  ++$n;
  if (very_close($when{$_}, $again{$_})) {
    print "ok $n\n";
  } else {
    print "not ok $n # expected $when{$_}, got $again{$_}\n";
  }
}

# (10)
wait_until(18);  # now(1) expires
print "not " unless close_enough(time, $again{1} = now(1));
++$n; print "ok $n\n";

# (11-12)
# T+18
foreach (2,3) {			# Should not have expired yet.
  ++$n;
  print "not " unless now($_) == $again{$_};
  print "ok $n\n";
}

wait_until(24);  # now(2) expires

# (13)
# T+24
print "not " unless close_enough(time, $again{2} = now(2));
++$n; print "ok $n\n";

# (14-15)
# T+24
foreach (1,3) {  # 1 is good again because it was recomputed after it expired
  ++$n;
  if (very_close(scalar(now($_)), $again{$_})) {
    print "ok $n\n";
  } else {
    print "not ok $n # expected $when{$_}, got $again{$_}\n";
  }
}

--- NEW FILE: tie_storable.t ---
#!/usr/bin/perl
# -*- mode: perl; perl-indent-level: 2 -*-

use lib qw(. ..);
use Memoize 0.45 qw(memoize unmemoize);
# $Memoize::Storable::Verbose = 0;

eval {require Memoize::Storable};
if ($@) {
  print "1..0\n";
  exit 0;
}

sub i {
  $_[0];
}

sub c119 { 119 }
sub c7 { 7 }
sub c43 { 43 }
sub c23 { 23 }
sub c5 { 5 }

sub n {
  $_[0]+1;
}

eval {require Storable};
if ($@) {
  print "1..0\n";
  exit 0;
}

print "1..4\n";

if (eval {require File::Spec::Functions}) {
 File::Spec::Functions->import();
} else {
  *catfile = sub { join '/', @_ };
}
$tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
$file = catfile($tmpdir, "storable$$");
1 while unlink $file;
tryout('Memoize::Storable', $file, 1);  # Test 1..4
1 while unlink $file;

sub tryout {
  my ($tiepack, $file, $testno) = @_;

  tie my %cache => $tiepack, $file
    or die $!;

  memoize 'c5', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t1 = c5();	
  my $t2 = c5();	
  print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c5';
  1;
  1;

  # Now something tricky---we'll memoize c23 with the wrong table that
  # has the 5 already cached.
  memoize 'c23', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t3 = c23();
  my $t4 = c23();
  $testno++;
  print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c23';
}

--- NEW FILE: correctness.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

print "1..25\n";

print "# Basic\n";

# A function that should only be called once.
{ my $COUNT = 0;
  sub no_args {	
    $FAIL++ if $COUNT++;
    11;
  }
}

# 
memoize('no_args');

$c1 = &no_args();
print (($c1 == 11) ? "ok 1\n" : "not ok 1\n");
$c2 = &no_args();
print (($c2 == 11) ? "ok 2\n" : "not ok 2\n");
print $FAIL ? "not ok 3\n" : "ok 3\n";	# Was it really memoized?

$FAIL = 0;
$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } };
$fm = memoize($f);

$c1 = &$fm();
print (($c1 == 12) ? "ok 4\n" : "not ok 4\n");
$c2 = &$fm();
print (($c2 == 12) ? "ok 5\n" : "not ok 5\n");
print $FAIL ? "not ok 6\n" : "ok 6\n";	# Was it really memoized?

$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } };
$fm = memoize($f, INSTALL => 'another');

$c1 = &another();  # Was it really installed?
print (($c1 == 13) ? "ok 7\n" : "not ok 7\n");
$c2 = &another();  
print (($c2 == 13) ? "ok 8\n" : "not ok 8\n");
print $FAIL ? "not ok 9\n" : "ok 9\n";	# Was it really memoized?
$c3 = &$fm();			# Call memoized version through returned ref
print (($c3 == 13) ? "ok 10\n" : "not ok 10\n");
print $FAIL ? "not ok 11\n" : "ok 11\n";	# Was it really memoized?
$c4 = &$f();			# Call original version again
print (($c4 == 13) ? "ok 12\n" : "not ok 12\n");
print $FAIL ? "ok 13\n" : "not ok 13\n";	# Did we get the original?

print "# Fibonacci\n";

sub mt1 {			# Fibonacci
  my $n = shift;
  return $n if $n < 2;
  mt1($n-1) + mt2($n-2);
}
sub mt2 {		
  my $n = shift;
  return $n if $n < 2;
  mt1($n-1) + mt2($n-2);
}

@f1 = map { mt1($_) } (0 .. 15);
@f2 = map { mt2($_) } (0 .. 15);
memoize('mt1');
@f3 = map { mt1($_) } (0 .. 15);
@f4 = map { mt1($_) } (0 .. 15);
@arrays = (\@f1, \@f2, \@f3, \@f4); 
$n = 13;
for ($i=0; $i<3; $i++) {
  for ($j=$i+1; $j<3; $j++) {
    $n++;
    print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n");
    $n++;
    for ($k=0; $k < @{$arrays[$i]}; $k++) {
      (print "not ok $n\n", next)  if $arrays[$i][$k] != $arrays[$j][$k];
    }
    print "ok $n\n";
  }
}

print "# Normalizers\n";

sub fake_normalize {
  return '';
}

sub f1 {
  return shift;
}
sub f2 {
  return shift;
}
sub f3 {
  return shift;
}
&memoize('f1');
&memoize('f2', NORMALIZER => 'fake_normalize');
&memoize('f3', NORMALIZER => \&fake_normalize);
@f1r = map { f1($_) } (1 .. 10);
@f2r = map { f2($_) } (1 .. 10);
@f3r = map { f3($_) } (1 .. 10);
$n++;
print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n");
$n++;
print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");
$n++;
print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n");

print "# INSTALL => undef option.\n";
{ my $i = 1;
  sub u1 { $i++ }
}
my $um = memoize('u1', INSTALL => undef);
@umr = (&$um, &$um, &$um);
@u1r = (&u1,  &u1,  &u1 );	# Did *not* clobber &u1
$n++;
print (("@umr" eq "1 1 1") ? "ok $n\n" : "not ok $n\n"); # Increment once
$n++;
print (("@u1r" eq "2 3 4") ? "ok $n\n" : "not ok $n\n"); # Increment thrice
$n++;
print ((defined &{"undef"}) ? "not ok $n\n" : "ok $n\n"); # Just in case

print "# $n tests in all.\n";

--- NEW FILE: speed.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

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                    ";

my $COARSE_TIME = 1;

sub times_to_time { my ($u) = times; $u; }
if ($^O eq 'riscos') {
  eval {require Time::HiRes; *my_time = \&Time::HiRes::time };
  if ($@) { *my_time = sub { time }; $COARSE_TIME = 1 }
} else {
  *my_time = \&times_to_time;
}

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 least $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++;
  return $n if $n < 2;
  fib($n-1) + fib($n-2);
}

sub max { $_[0] > $_[1] ? 
          $_[0] : $_[1] 
        }

$N = 1;

$ELAPSED = 0;

my $LONG_RUN = 10;

while (1) {
  my $start = time;
  $COUNT=0;
  $RESULT = fib($N);
  $ELAPSED = time - $start;
  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');

$COUNT=0;
$start = time;
$RESULT2 = fib($N);
$ELAPSED2 = time - $start + .001; # prevent division by 0 errors

print (($RESULT == $RESULT2) ? "ok 1\n" : "not ok 1\n");
# If it's not ten times as fast, something is seriously wrong.
print (($ELAPSED/$ELAPSED2 > 10) ? "ok 2\n" : "not ok 2\n");
# If it called the function more than $N times, it wasn't memoized properly
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 == 0 ? "ok 6\n" : "not ok 6\n");

--- NEW FILE: array.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

print "1..11\n";

sub timelist {
  return (time) x $_[0];
}

memoize('timelist');

@t1 = &timelist(1);
sleep 2;
@u1 = &timelist(1);
print ((("@t1" eq "@u1") ? '' : 'not '), "ok 1\n");

@t7 = &timelist(7);
print (((@t7 == 7) ? '' : 'not '), "ok 2\n");
$BAD = 0;
for ($i = 1; $i < 7; $i++) {
  $BAD++ unless $t7[$i-1] == $t7[$i];
}
print (($BAD ? 'not ' : ''), "ok 3\n");

sleep 2;
@u7 = &timelist(7);
print (((@u7 == 7) ? '' : 'not '), "ok 4\n");
$BAD = 0;
for ($i = 1; $i < 7; $i++) {
  $BAD++ unless $u7[$i-1] == $u7[$i];
}
print (($BAD ? 'not ' : ''), "ok 5\n");
# Properly memoized?
print ((("@t7" eq "@u7") ? '' : 'not '), "ok 6\n");

sub con {
  return wantarray()
}

# Same arguments yield different results in different contexts?
memoize('con');
$s = con(1);
@a = con(1);
print ((($s == $a[0]) ? 'not ' : ''), "ok 7\n");

# Context propagated correctly?
print ((($s eq '') ? '' : 'not '), "ok 8\n"); # Scalar context
print ((("@a" eq '1' && @a == 1) ? '' : 'not '), "ok 9\n"); # List context

# Context propagated correctly to normalizer?
sub n {
  my $arg = shift;
  my $test = shift;
  if (wantarray) {
    print ((($arg eq ARRAY) ? '' : 'not '), "ok $test\n"); # List context
  } else {
    print ((($arg eq SCALAR) ? '' : 'not '), "ok $test\n"); # Scalar context
  }
}

sub f { 1 }
memoize('f', NORMALIZER => 'n');
$s = f('SCALAR', 10);		# Test 10
@a = f('ARRAY' , 11);		# Test 11

--- NEW FILE: expmod_n.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

my $n = 0;

print "1..22\n";

++$n; print "ok $n\n";

$RETURN = 1;

%CALLS = ();
sub call {
#  print "CALL $_[0] => $RETURN\n";
  ++$CALLS{$_[0]};
  $RETURN;
}

require Memoize::Expire;
++$n; print "ok $n\n";

tie my %cache => 'Memoize::Expire', NUM_USES => 2;
memoize 'call',
    SCALAR_CACHE => [HASH => \%cache],
    LIST_CACHE => 'FAULT';

# $Memoize::Expire::DEBUG = 1;
++$n; print "ok $n\n";

# 3--6
for (0,1,2,3) {
  print "not " unless call($_) == 1;
  ++$n; print "ok $n\n";
}

# 7--10
for (keys %CALLS) {
  print "not " unless $CALLS{$_} == (1,1,1,1)[$_];
  ++$n; print "ok $n\n";
}

# 11--13
$RETURN = 2;
++$n; print ((call(1) == 1 ? '' : 'not '), "ok $n\n"); # 1 expires
++$n; print ((call(1) == 2 ? '' : 'not '), "ok $n\n"); # 1 gets new val
++$n; print ((call(2) == 1 ? '' : 'not '), "ok $n\n"); # 2 expires

# 14--17
$RETURN = 3;
for (0,1,2,3) {
  # 0 expires, 1 expires, 2 gets new val, 3 expires
  print "not " unless call($_) == (1,2,3,1)[$_];
  ++$n; print "ok $n\n";
}

for (0,1,2,3) {
  print "not " unless $CALLS{$_} == (1,2,2,1)[$_];
  ++$n; print "ok $n\n";
}

--- NEW FILE: array_confusion.t ---
#!/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";

--- NEW FILE: expfile.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;

my $n = 0;
$|=1;

if (-e '.fast') {
  print "1..0\n";
  exit 0;
}

print "1..12\n";
# (1)
++$n; print "ok $n\n";

my $READFILE_CALLS = 0;
my $FILE = './TESTFILE';

sub writefile {
  my $FILE = shift;
  open F, "> $FILE" or die "Couldn't write temporary file $FILE: $!";
  print F scalar(localtime), "\n";
  close F;
}

sub readfile {
  $READFILE_CALLS++;
  my $FILE = shift;
  open F, "< $FILE" or die "Couldn't write temporary file $FILE: $!";
  my $data = <F>;
  close F;
  $data;
}

require Memoize::ExpireFile;
# (2)
++$n; print "ok $n\n";

tie my %cache => 'Memoize::ExpireFile';
memoize 'readfile',
    SCALAR_CACHE => [HASH => \%cache],
    LIST_CACHE => 'FAULT'
    ;

# (3)
++$n; print "ok $n\n";

# (4)
writefile($FILE);
++$n; print "ok $n\n";
sleep 4;

# (5-6)
my $t1 = readfile($FILE);
++$n; print "ok $n\n";
++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");

# (7-9)
my $t2 = readfile($FILE);
++$n; print "ok $n\n";  
++$n; print ((($READFILE_CALLS == 1) ? '' : 'not '), "ok $n\n");
++$n; print ((($t1 eq $t2) ? '' : 'not '), "ok $n\n");

# (10-12)
sleep 4;
writefile($FILE);
my $t3 = readfile($FILE);
++$n; print "ok $n\n";
++$n; print ((($READFILE_CALLS == 2) ? '' : 'not '), "ok $n\n");
++$n; print ((($t1 ne $t3) ? '' : 'not '), "ok $n\n");

END { 1 while unlink $FILE }

--- NEW FILE: tie_sdbm.t ---
#!/usr/bin/perl

use lib qw(. ..);
use Memoize 0.45 qw(memoize unmemoize);
use Fcntl;
# use Memoize::SDBM_File;
# $Memoize::GDBM_File::Verbose = 0;

sub i {
  $_[0];
}

sub c119 { 119 }
sub c7 { 7 }
sub c43 { 43 }
sub c23 { 23 }
sub c5 { 5 }

sub n {
  $_[0]+1;
}

eval {require Memoize::SDBM_File};
if ($@) {
  print "1..0\n";
  exit 0;
}

print "1..4\n";

if (eval {require File::Spec::Functions}) {
 File::Spec::Functions->import('tmpdir', 'catfile');
 $tmpdir = tmpdir();
} else {
 *catfile = sub { join '/', @_ };
  $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
}
$file = catfile($tmpdir, "md$$");
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 => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t1 = c5();	
  my $t2 = c5();	
  print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c5';

  # Now something tricky---we'll memoize c23 with the wrong table that
  # has the 5 already cached.
  memoize 'c23', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t3 = c23();
  my $t4 = c23();
  $testno++;
  print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c23';
}

--- NEW FILE: tie_ndbm.t ---
#!/usr/bin/perl

use lib qw(. ..);
use Memoize 0.45 qw(memoize unmemoize);
use Fcntl;
# use Memoize::NDBM_File;
# $Memoize::NDBM_File::Verbose = 0;

sub i {
  $_[0];
}

sub c119 { 119 }
sub c7 { 7 }
sub c43 { 43 }
sub c23 { 23 }
sub c5 { 5 }

sub n {
  $_[0]+1;
}

eval {require Memoize::NDBM_File};
if ($@) {
  print "1..0\n";
  exit 0;
}

print "1..4\n";

if (eval {require File::Spec::Functions}) {
 File::Spec::Functions->import();
} else {
  *catfile = sub { join '/', @_ };
}
$tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
$file = catfile($tmpdir, "md$$");
1 while unlink $file, "$file.dir", "$file.pag", "$file.db";
tryout('Memoize::NDBM_File', $file, 1);  # Test 1..4
1 while unlink $file, "$file.dir", "$file.pag", "$file.db";

sub tryout {
  my ($tiepack, $file, $testno) = @_;

  tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666
    or die $!;

  memoize 'c5', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t1 = c5();	
  my $t2 = c5();	
  print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c5';

  # Now something tricky---we'll memoize c23 with the wrong table that
  # has the 5 already cached.
  memoize 'c23', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t3 = c23();
  my $t4 = c23();
  $testno++;
  print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c23';
}

--- NEW FILE: tie.t ---
#!/usr/bin/perl

use lib qw(. ..);
use Memoize 0.52 qw(memoize unmemoize);
use Fcntl;
eval {require Memoize::AnyDBM_File};
if ($@) {
  print "1..0\n";
  exit 0;
}

print "1..4\n";

sub i {
  $_[0];
}

$ARG = 'Keith Bostic is a pinhead';

sub c119 { 119 }
sub c7 { 7 }
sub c43 { 43 }
sub c23 { 23 }
sub c5 { 5 }

sub n {
  $_[0]+1;
}

if (eval {require File::Spec::Functions}) {
  File::Spec::Functions->import('tmpdir', 'catfile');
  $tmpdir = tmpdir();
} else {
  *catfile = sub { join '/', @_ };
  $tmpdir = $ENV{TMP} || $ENV{TMPDIR} || '/tmp';
}
$file = catfile($tmpdir, "md$$");
@files = ($file, "$file.db", "$file.dir", "$file.pag");
1 while unlink @files;

tryout('Memoize::AnyDBM_File', $file, 1);  # Test 1..4
# tryout('DB_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 => [HASH => \%cache],
    LIST_CACHE => 'FAULT'
    ;

  my $t1 = c5($ARG);	
  my $t2 = c5($ARG);	
  print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c5';

  # Now something tricky---we'll memoize c23 with the wrong table that
  # has the 5 already cached.
  memoize 'c23', 
  SCALAR_CACHE => ['HASH', \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t3 = c23($ARG);
  my $t4 = c23($ARG);
  $testno++;
  print (($t3 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t3\n");
  $testno++;
  print (($t4 == 5) ? "ok $testno\n" : "not ok $testno  #   Result $t4\n");
  unmemoize 'c23';
}

{ 
  my @present = grep -e, @files;
  if (@present && (@failed = grep { not unlink } @present)) {
    warn "Can't unlink @failed!  ($!)";
  }
}

--- NEW FILE: prototype.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;
$EXPECTED_WARNING = '(no warning expected)';

print "1..4\n";

sub q1 ($) { $_[0] + 1 }
sub q2 ()  { time }
sub q3     { join "--", @_ }

$SIG{__WARN__} = \&handle_warnings;

$RES = 'ok';
memoize 'q1';
print "$RES 1\n";

$RES = 'ok';
memoize 'q2';
print "$RES 2\n";

$RES = 'ok';
memoize 'q3';
print "$RES 3\n";

# Let's see if the prototype is actually honored
@q = (1..5);
$r = q1(@q); 
print (($r == 6) ? '' : 'not ', "ok 4\n");

sub handle_warnings {
  print $_[0];
  $RES = 'not ok' unless $_[0] eq $EXPECTED_WARNING;
}

--- NEW FILE: tie_gdbm.t ---
#!/usr/bin/perl

use lib qw(. ..);
use Memoize 0.45 qw(memoize unmemoize);
use Fcntl;

sub i {
  $_[0];
}

sub c119 { 119 }
sub c7 { 7 }
sub c43 { 43 }
sub c23 { 23 }
sub c5 { 5 }

sub n {
  $_[0]+1;
}

eval {require GDBM_File};
if ($@) {
  print "1..0\n";
  exit 0;
}

print "1..4\n";

if (eval {require File::Spec::Functions}) {
 File::Spec::Functions->import();
} else {
  *catfile = sub { join '/', @_ };
}
$tmpdir = $ENV{TMP} || $ENV{TMPDIR} ||  '/tmp';  
$file = catfile($tmpdir, "md$$");
1 while unlink $file, "$file.dir", "$file.pag";
tryout('GDBM_File', $file, 1);  # Test 1..4
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 => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t1 = c5();	
  my $t2 = c5();	
  print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c5';

  # Now something tricky---we'll memoize c23 with the wrong table that
  # has the 5 already cached.
  memoize 'c23', 
  SCALAR_CACHE => [HASH => \%cache],
  LIST_CACHE => 'FAULT'
    ;

  my $t3 = c23();
  my $t4 = c23();
  $testno++;
  print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n");
  $testno++;
  print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n");
  unmemoize 'c23';
}

--- NEW FILE: tiefeatures.t ---
#!/usr/bin/perl

use lib 'blib/lib';
use Memoize 0.45 qw(memoize unmemoize);
use Fcntl;

# print STDERR $INC{'Memoize.pm'}, "\n";

print "1..10\n";

# Test MERGE
sub xx {
  wantarray();
}

my $s = xx();
print ((!$s) ? "ok 1\n" : "not ok 1\n");
my ($a) = xx();
print (($a) ? "ok 2\n" : "not ok 2\n");
memoize 'xx', LIST_CACHE => MERGE;
$s = xx();
print ((!$s) ? "ok 3\n" : "not ok 3\n");
($a) = xx();  # Should return cached false value from previous invocation
print ((!$a) ? "ok 4\n" : "not ok 4\n");

# Test FAULT
sub ns {}
sub na {}
memoize 'ns', SCALAR_CACHE => FAULT;
memoize 'na', LIST_CACHE => FAULT;
eval { my $s = ns() };  # Should fault
print (($@) ?  "ok 5\n" : "not ok 5\n");
eval { my ($a) = na() };  # Should fault
print (($@) ?  "ok 6\n" : "not ok 6\n");

# Test HASH
my (%s, %l);
sub nul {}
memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l];
nul('x');
nul('y');
print ((join '', sort keys %s) eq 'xy' ? "ok 7\n" : "not ok 7\n");
print ((join '', sort keys %l) eq ''   ? "ok 8\n" : "not ok 8\n");
() = nul('p');
() = nul('q');
print ((join '', sort keys %s) eq 'xy' ? "ok 9\n" : "not ok 9\n");
print ((join '', sort keys %l) eq 'pq' ? "ok 10\n" : "not ok 10\n");

--- NEW FILE: unmemoize.t ---
#!/usr/bin/perl

use lib '..';
use Memoize qw(memoize unmemoize);

print "1..5\n";

eval { unmemoize('f') };	# Should fail
print (($@ ? '' : 'not '), "ok 1\n");

{ my $I = 0;
  sub u { $I++ }
}
memoize('u');
my @ur = (&u, &u, &u);
print (("@ur" eq "0 0 0") ? "ok 2\n" : "not ok 2\n");

eval { unmemoize('u') };	# Should succeed
print ($@ ? "not ok 3\n" : "ok 3\n");

@ur = (&u, &u, &u);
print (("@ur" eq "1 2 3") ? "ok 4\n" : "not ok 4\n");

eval { unmemoize('u') };	# Should fail
print ($@ ? "ok 5\n" : "not ok 5\n");

--- NEW FILE: errors.t ---
#!/usr/bin/perl

use lib '..';
use Memoize;
use Config;

$|=1;
print "1..11\n";

eval { memoize({}) };
print $@ ? "ok 1\n" : "not ok 1 # $@\n";

eval { memoize([]) };
print $@ ? "ok 2\n" : "not ok 2 # $@\n";

eval { my $x; memoize(\$x) };
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 {
    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/
     || $@ =~ /Can't load '.*?' for module/ ? "ok $n\n" : "not ok $n # $@\n";
  1 while unlink $dummyfile, "$dummyfile.dir", "$dummyfile.pag", "$dummyfile.db";
  $n++;
}

# 9
eval { local $^W = 0;
       memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga']) 
     };
print $@ ? "ok 9\n" : "not ok 9 # $@\n";

# 10
eval { memoize(sub {}, LIST_CACHE => 'YOB GORGLE') };
print $@ ? "ok 10\n" : "not ok 10 # $@\n";

# 11
eval { memoize(sub {}, SCALAR_CACHE => ['YOB GORGLE']) };
print $@ ? "ok 11\n" : "not ok 11 # $@\n";