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