VMS specific cleanup and strictness for tie_sdbm.t

[p5sagit/p5-mst-13.2.git] / lib / Memoize / t / correctness.t

#!/usr/bin/perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../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";