1*f2a19305Safresh1use strict; use warnings; 2b39c5158Smillertuse Memoize; 3*f2a19305Safresh1use Test::More tests => 17; 4b39c5158Smillert 5*f2a19305Safresh1# here we test whether memoization actually has the desired effect 6b39c5158Smillert 7*f2a19305Safresh1my ($fib, $ns1_calls, $ns2_calls, $total_calls) = ([0,1], 1, 1, 1+1); 8*f2a19305Safresh1while (@$fib < 23) { 9*f2a19305Safresh1 push @$fib, $$fib[-1] + $$fib[-2]; 10*f2a19305Safresh1 my $n_calls = 1 + $ns1_calls + $ns2_calls; 11*f2a19305Safresh1 $total_calls += $n_calls; 12*f2a19305Safresh1 ($ns2_calls, $ns1_calls) = ($ns1_calls, $n_calls); 13b39c5158Smillert} 14b39c5158Smillert 15*f2a19305Safresh1my $num_calls; 16*f2a19305Safresh1sub fib { 17*f2a19305Safresh1 ++$num_calls; 18b39c5158Smillert my $n = shift; 19b39c5158Smillert return $n if $n < 2; 20*f2a19305Safresh1 fib($n-1) + fib($n-2); 21b39c5158Smillert} 22b39c5158Smillert 23*f2a19305Safresh1my @s1 = map 0+fib($_), 0 .. $#$fib; 24*f2a19305Safresh1is_deeply \@s1, $fib, 'unmemoized Fibonacci works'; 25*f2a19305Safresh1is $num_calls, $total_calls, '... with the expected amount of calls'; 26*f2a19305Safresh1 27*f2a19305Safresh1undef $num_calls; 28*f2a19305Safresh1memoize 'fib'; 29*f2a19305Safresh1 30*f2a19305Safresh1my @f1 = map 0+fib($_), 0 .. $#$fib; 31*f2a19305Safresh1my @f2 = map 0+fib($_), 0 .. $#$fib; 32*f2a19305Safresh1is_deeply \@f1, $fib, 'memoized Fibonacci works'; 33*f2a19305Safresh1is $num_calls, @$fib, '... with a minimal amount of calls'; 34*f2a19305Safresh1 35*f2a19305Safresh1######################################################################## 36*f2a19305Safresh1 37*f2a19305Safresh1my $timestamp; 38*f2a19305Safresh1sub timelist { (++$timestamp) x $_[0] } 39*f2a19305Safresh1 40*f2a19305Safresh1memoize('timelist'); 41*f2a19305Safresh1 42*f2a19305Safresh1my $t1 = [timelist(1)]; 43*f2a19305Safresh1is_deeply [timelist(1)], $t1, 'memoizing a volatile function makes it stable'; 44*f2a19305Safresh1my $t7 = [timelist(7)]; 45*f2a19305Safresh1isnt @$t1, @$t7, '... unless the arguments change'; 46*f2a19305Safresh1is_deeply $t7, [($$t7[0]) x 7], '... which leads to the expected new return value'; 47*f2a19305Safresh1is_deeply [timelist(7)], $t7, '... which then also stays stable'; 48*f2a19305Safresh1 49*f2a19305Safresh1sub con { wantarray ? 'list' : 'scalar' } 50*f2a19305Safresh1memoize('con'); 51*f2a19305Safresh1is scalar(con(1)), 'scalar', 'scalar context propgates properly'; 52*f2a19305Safresh1is_deeply [con(1)], ['list'], 'list context propgates properly'; 53*f2a19305Safresh1 54*f2a19305Safresh1######################################################################## 55*f2a19305Safresh1 56*f2a19305Safresh1my %underlying; 57*f2a19305Safresh1sub ExpireTest::TIEHASH { bless \%underlying, shift } 58*f2a19305Safresh1sub ExpireTest::EXISTS { exists $_[0]{$_[1]} } 59*f2a19305Safresh1sub ExpireTest::FETCH { $_[0]{$_[1]} } 60*f2a19305Safresh1sub ExpireTest::STORE { $_[0]{$_[1]} = $_[2] } 61*f2a19305Safresh1 62*f2a19305Safresh1my %CALLS; 63*f2a19305Safresh1sub id { 64*f2a19305Safresh1 my($arg) = @_; 65*f2a19305Safresh1 ++$CALLS{$arg}; 66*f2a19305Safresh1 $arg; 67b39c5158Smillert} 68b39c5158Smillert 69*f2a19305Safresh1tie my %cache => 'ExpireTest'; 70*f2a19305Safresh1memoize 'id', 71*f2a19305Safresh1 SCALAR_CACHE => [HASH => \%cache], 72*f2a19305Safresh1 LIST_CACHE => 'FAULT'; 73b39c5158Smillert 74*f2a19305Safresh1my $arg = [1..3, 1, 2, 1]; 75*f2a19305Safresh1is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; 76*f2a19305Safresh1is_deeply \%CALLS, {1=>1,2=>1,3=>1}, 'amount of initial calls per arg as expected'; 77b39c5158Smillert 78*f2a19305Safresh1delete $underlying{1}; 79*f2a19305Safresh1$arg = [1..3]; 80*f2a19305Safresh1is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; 81*f2a19305Safresh1is_deeply \%CALLS, {1=>2,2=>1,3=>1}, 'amount of calls per arg after expiring 1 as expected'; 82b39c5158Smillert 83*f2a19305Safresh1delete @underlying{1,2}; 84*f2a19305Safresh1is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; 85*f2a19305Safresh1is_deeply \%CALLS, {1=>3,2=>2,3=>1}, 'amount of calls per arg after expiring 1 & 2 as expected'; 86*f2a19305Safresh1 87*f2a19305Safresh1######################################################################## 88*f2a19305Safresh1 89*f2a19305Safresh1my $fail; 90*f2a19305Safresh1$SIG{__WARN__} = sub { if ( $_[0] =~ /^Deep recursion/ ) { $fail = 1 } else { warn $_[0] } }; 91*f2a19305Safresh1 92*f2a19305Safresh1my $limit; 93*f2a19305Safresh1sub deep_probe { deep_probe() if ++$limit < 100_000 and not $fail } 94*f2a19305Safresh1sub deep_test { no warnings "recursion"; deep_test() if $limit-- > 0 } 95*f2a19305Safresh1memoize "deep_test"; 96*f2a19305Safresh1 97*f2a19305Safresh1SKIP: { 98*f2a19305Safresh1 deep_probe(); 99*f2a19305Safresh1 skip "no warning after $limit recursive calls (maybe PERL_SUB_DEPTH_WARN was raised?)", 1 if not $fail; 100*f2a19305Safresh1 undef $fail; 101*f2a19305Safresh1 deep_test(); 102*f2a19305Safresh1 ok !$fail, 'no recursion warning thrown from Memoize'; 103b39c5158Smillert} 104