1use strict; use warnings; 2use Memoize 0.45 qw(memoize unmemoize); 3use Fcntl; 4use Test::More tests => 65; 5 6sub list { wantarray ? @_ : $_[-1] } 7 8# Test FAULT 9sub ns {} 10sub na {} 11ok eval { memoize 'ns', SCALAR_CACHE => 'FAULT'; 1 }, 'SCALAR_CACHE => FAULT'; 12ok eval { memoize 'na', LIST_CACHE => 'FAULT'; 1 }, 'LIST_CACHE => FAULT'; 13is eval { scalar(ns()) }, undef, 'exception in scalar context'; 14is eval { list(na()) }, undef, 'exception in list context'; 15 16# Test FAULT/FAULT 17sub dummy {1} 18for ([qw(FAULT FAULT)], [qw(FAULT MERGE)], [qw(MERGE FAULT)]) { 19 my ($l_opt, $s_opt) = @$_; 20 my $memodummy = memoize 'dummy', LIST_CACHE => $l_opt, SCALAR_CACHE => $s_opt, INSTALL => undef; 21 my ($ret, $e); 22 { local $@; $ret = eval { scalar $memodummy->() }; $e = $@ } 23 is $ret, undef, "scalar context fails under $l_opt/$s_opt"; 24 like $e, qr/^Anonymous function called in forbidden scalar context/, '... with the right error message'; 25 { local $@; $ret = eval { +($memodummy->())[0] }; $e = $@ } 26 is $ret, undef, "list context fails under $l_opt/$s_opt"; 27 like $e, qr/^Anonymous function called in forbidden list context/, '... with the right error message'; 28 unmemoize $memodummy; 29} 30 31# Test HASH 32my (%s, %l); 33sub nul {} 34ok eval { memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l]; 1 }, '*_CACHE => HASH'; 35nul('x'); 36nul('y'); 37is_deeply [sort keys %s], [qw(x y)], 'scalar context calls populate SCALAR_CACHE'; 38is_deeply \%l, {}, '... and does not touch the LIST_CACHE'; 39%s = (); 40() = nul('p'); 41() = nul('q'); 42is_deeply [sort keys %l], [qw(p q)], 'list context calls populate LIST_CACHE'; 43is_deeply \%s, {}, '... and does not touch the SCALAR_CACHE'; 44 45# Test MERGE 46sub xx { wantarray } 47ok !scalar(xx()), 'false in scalar context'; 48ok list(xx()), 'true in list context'; 49ok eval { memoize 'xx', LIST_CACHE => 'MERGE'; 1 }, 'LIST_CACHE => MERGE'; 50ok !scalar(xx()), 'false in scalar context again'; 51# Should return cached false value from previous invocation 52ok !list(xx()), 'still false in list context'; 53 54sub reff { [1,2,3] } 55sub listf { (1,2,3) } 56 57memoize 'reff', LIST_CACHE => 'MERGE'; 58memoize 'listf'; 59 60scalar reff(); 61is_deeply [reff()], [[1,2,3]], 'reff list context after scalar context'; 62 63scalar listf(); 64is_deeply [listf()], [1,2,3], 'listf list context after scalar context'; 65 66unmemoize 'reff'; 67memoize 'reff', LIST_CACHE => 'MERGE'; 68unmemoize 'listf'; 69memoize 'listf'; 70 71is_deeply [reff()], [[1,2,3]], 'reff list context'; 72 73is_deeply [listf()], [1,2,3], 'listf list context'; 74 75sub f17 { return 17 } 76memoize 'f17', SCALAR_CACHE => 'MERGE'; 77is_deeply [f17()], [17], 'f17 first call'; 78is_deeply [f17()], [17], 'f17 second call'; 79is scalar(f17()), 17, 'f17 scalar context call'; 80 81my (%cache, $num_cache_misses); 82sub cacheit { 83 ++$num_cache_misses; 84 "cacheit result"; 85} 86sub test_cacheit { 87 is scalar(cacheit()), 'cacheit result', 'scalar context'; 88 is $num_cache_misses, 1, 'function called once'; 89 90 is +(cacheit())[0], 'cacheit result', 'list context'; 91 is $num_cache_misses, 1, 'function not called again'; 92 93 is_deeply [values %cache], [['cacheit result']], 'expected cached value'; 94 95 %cache = (); 96 97 is +(cacheit())[0], 'cacheit result', 'list context'; 98 is $num_cache_misses, 2, 'function again called after clearing the cache'; 99 100 is scalar(cacheit()), 'cacheit result', 'scalar context'; 101 is $num_cache_misses, 2, 'function not called again'; 102} 103 104memoize 'cacheit', LIST_CACHE => [HASH => \%cache], SCALAR_CACHE => 'MERGE'; 105test_cacheit; 106unmemoize 'cacheit'; 107( $num_cache_misses, %cache ) = (); 108memoize 'cacheit', SCALAR_CACHE => [HASH => \%cache], LIST_CACHE => 'MERGE'; 109test_cacheit; 110 111# Test errors 112my @w; 113my $sub = eval { 114 local $SIG{'__WARN__'} = sub { push @w, @_ }; 115 memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga']); 116}; 117is $sub, undef, 'bad TIE fails'; 118like $@, qr/^Can't locate WuggaWugga.pm in \@INC/, '... with the expected error'; 119like $w[0], qr/^TIE option to memoize\(\) is deprecated; use HASH instead/, '... and the expected deprecation warning'; 120is @w, 1, '... and no other warnings'; 121 122is eval { memoize sub {}, LIST_CACHE => 'YOB GORGLE' }, undef, 'bad LIST_CACHE fails'; 123like $@, qr/^Unrecognized option to `LIST_CACHE': `YOB GORGLE'/, '... with the expected error'; 124 125is eval { memoize sub {}, SCALAR_CACHE => ['YOB GORGLE'] }, undef, 'bad SCALAR_CACHE fails'; 126like $@, qr/^Unrecognized option to `SCALAR_CACHE': `YOB GORGLE'/, '... with the expected error'; 127 128for my $option (qw(LIST_CACHE SCALAR_CACHE)) { 129 is eval { memoize sub {}, $option => ['MERGE'] }, undef, "$option=>['MERGE'] fails"; 130 like $@, qr/^Unrecognized option to `$option': `MERGE'/, '... with the expected error'; 131} 132 133# this test needs a DBM which 134# a) Memoize knows is scalar-only 135# b) is always available (on all platforms, perl configs etc) 136# c) never fails to load 137# so we use AnyDBM_File (which fulfills (a) & (b)) 138# on top of a fake dummy DBM (ditto (b) & (c)) 139sub DummyDBM::TIEHASH { bless {}, shift } 140$INC{'DummyDBM.pm'} = 1; 141@AnyDBM_File::ISA = 'DummyDBM'; 142$sub = eval { 143 no warnings; 144 memoize sub {}, SCALAR_CACHE => [ TIE => 'AnyDBM_File' ], LIST_CACHE => 'MERGE'; 145}; 146is $sub, undef, 'smuggling in a scalar-only LIST_CACHE via MERGE fails'; 147like $@, qr/^You can't use AnyDBM_File for LIST_CACHE because it can only store scalars/, 148 '... with the expected error'; 149