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