1use strict; use warnings; 2use Memoize; 3use Test::More tests => 27; 4 5# here we test memoize() itself i.e. whether it sets everything up as requested 6# (except for the (LIST|SCALAR)_CACHE options which are tested elsewhere) 7 8my ( $sub, $wrapped ); 9 10sub dummy {1} 11$sub = \&dummy; 12$wrapped = memoize 'dummy'; 13isnt \&dummy, $sub, 'memoizing replaces the sub'; 14is ref $wrapped, 'CODE', '... and returns a coderef'; 15is \&dummy, $wrapped, '... which is the replacement'; 16 17sub dummy_i {1} 18$sub = \&dummy_i; 19$wrapped = memoize 'dummy_i', INSTALL => 'another'; 20is \&dummy_i, $sub, 'INSTALL does not replace the sub'; 21is \&another, $wrapped, '... but installs the memoized version where requested'; 22 23sub dummy_p {1} 24$sub = \&dummy_p; 25$wrapped = memoize 'dummy_p', INSTALL => 'another::package::too'; 26is \&another::package::too, $wrapped, '... even if that is a whole other package'; 27 28sub find_sub { 29 my ( $needle, $symtbl ) = ( @_, *main::{'HASH'} ); 30 while ( my ( $name, $glob ) = each %$symtbl ) { 31 if ( $name =~ /::\z/ ) { 32 find_sub( $needle, *$glob{'HASH'} ) unless *$glob{'HASH'} == $symtbl; 33 } elsif ( defined( my $sub = eval { *$glob{'CODE'} } ) ) { 34 return 1 if $needle == $sub; 35 } 36 } 37 return !1; 38} 39 40sub dummy_u {1} 41$sub = \&dummy_u; 42$wrapped = memoize 'dummy_u', INSTALL => undef; 43is \&dummy_u, $sub, '... unless the passed name is undef'; 44ok !find_sub( $wrapped ), '... which does not install the memoized version anywhere'; 45 46$sub = sub {1}; 47$wrapped = memoize $sub; 48is ref $wrapped, 'CODE', 'memoizing a $coderef wraps it'; 49ok !find_sub( $wrapped ), '... without installing the memoized version anywhere'; 50 51$sub = sub {1}; 52$wrapped = memoize $sub, INSTALL => 'another'; 53is \&another, $wrapped, '... unless requested using INSTALL'; 54 55my $num_args; 56sub fake_normalize { $num_args = @_ } 57$wrapped = memoize sub {1}, NORMALIZER => 'fake_normalize'; 58$wrapped->( ('x') x 7 ); 59is $num_args, 7, 'NORMALIZER installs the requested normalizer; both by name'; 60$wrapped = memoize sub {1}, NORMALIZER => \&fake_normalize; 61$wrapped->( ('x') x 23 ); 62is $num_args, 23, '... as well as by reference'; 63 64$wrapped = eval { memoize 'dummy_none' }; 65is $wrapped, undef, 'memoizing a non-existent function fails'; 66like $@, qr/^Cannot operate on nonexistent function `dummy_none'/, '... with the expected error'; 67 68for my $nonsub ({}, [], \my $x) { 69 is eval { memoize $nonsub }, undef, "memoizing ${\ref $nonsub} ref fails"; 70 like $@, qr/^Usage: memoize 'functionname'\|coderef \{OPTIONS\}/, '... with the expected error'; 71} 72 73sub no_warnings_ok (&$) { 74 my $w; 75 local $SIG{'__WARN__'} = sub { push @$w, @_; &diag }; 76 shift->(); 77 local $Test::Builder::Level = $Test::Builder::Level + 1; 78 is( $w, undef, shift ) or diag join '', @$w; 79} 80 81sub q1 ($) { $_[0] + 1 } 82sub q2 () { time } 83sub q3 { join "--", @_ } 84 85no_warnings_ok { memoize 'q1' } 'no warnings with $ protype'; 86no_warnings_ok { memoize 'q2' } 'no warnings with empty protype'; 87no_warnings_ok { memoize 'q3' } 'no warnings without protype'; 88is q1(@{['a'..'z']}), 27, '$ prototype is honored'; 89is eval('q2("test")'), undef, 'empty prototype is honored'; 90like $@, qr/^Too many arguments for main::q2 /, '... with the expected error'; 91