diff options
Diffstat (limited to 'gnu/usr.bin/perl/cpan/Memoize/t')
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/basic.t | 90 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/cache.t | 148 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/correctness.t | 204 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/expmod.t | 57 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t | 32 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/flush.t | 42 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm | 102 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/normalize.t | 53 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency | 36 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t | 37 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/tie.t | 82 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t | 8 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t | 70 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t | 72 | ||||
-rw-r--r-- | gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t | 8 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t | 77 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t | 84 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t | 73 |
18 files changed, 708 insertions, 567 deletions
diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/basic.t b/gnu/usr.bin/perl/cpan/Memoize/t/basic.t new file mode 100644 index 00000000000..fd4527f539b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/basic.t @@ -0,0 +1,90 @@ +use strict; use warnings; +use Memoize; +use Test::More tests => 27; + +# here we test memoize() itself i.e. whether it sets everything up as requested +# (except for the (LIST|SCALAR)_CACHE options which are tested elsewhere) + +my ( $sub, $wrapped ); + +sub dummy {1} +$sub = \&dummy; +$wrapped = memoize 'dummy'; +isnt \&dummy, $sub, 'memoizing replaces the sub'; +is ref $wrapped, 'CODE', '... and returns a coderef'; +is \&dummy, $wrapped, '... which is the replacement'; + +sub dummy_i {1} +$sub = \&dummy_i; +$wrapped = memoize 'dummy_i', INSTALL => 'another'; +is \&dummy_i, $sub, 'INSTALL does not replace the sub'; +is \&another, $wrapped, '... but installs the memoized version where requested'; + +sub dummy_p {1} +$sub = \&dummy_p; +$wrapped = memoize 'dummy_p', INSTALL => 'another::package::too'; +is \&another::package::too, $wrapped, '... even if that is a whole other package'; + +sub find_sub { + my ( $needle, $symtbl ) = ( @_, *main::{'HASH'} ); + while ( my ( $name, $glob ) = each %$symtbl ) { + if ( $name =~ /::\z/ ) { + find_sub( $needle, *$glob{'HASH'} ) unless *$glob{'HASH'} == $symtbl; + } elsif ( defined( my $sub = eval { *$glob{'CODE'} } ) ) { + return 1 if $needle == $sub; + } + } + return !1; +} + +sub dummy_u {1} +$sub = \&dummy_u; +$wrapped = memoize 'dummy_u', INSTALL => undef; +is \&dummy_u, $sub, '... unless the passed name is undef'; +ok !find_sub( $wrapped ), '... which does not install the memoized version anywhere'; + +$sub = sub {1}; +$wrapped = memoize $sub; +is ref $wrapped, 'CODE', 'memoizing a $coderef wraps it'; +ok !find_sub( $wrapped ), '... without installing the memoized version anywhere'; + +$sub = sub {1}; +$wrapped = memoize $sub, INSTALL => 'another'; +is \&another, $wrapped, '... unless requested using INSTALL'; + +my $num_args; +sub fake_normalize { $num_args = @_ } +$wrapped = memoize sub {1}, NORMALIZER => 'fake_normalize'; +$wrapped->( ('x') x 7 ); +is $num_args, 7, 'NORMALIZER installs the requested normalizer; both by name'; +$wrapped = memoize sub {1}, NORMALIZER => \&fake_normalize; +$wrapped->( ('x') x 23 ); +is $num_args, 23, '... as well as by reference'; + +$wrapped = eval { memoize 'dummy_none' }; +is $wrapped, undef, 'memoizing a non-existent function fails'; +like $@, qr/^Cannot operate on nonexistent function `dummy_none'/, '... with the expected error'; + +for my $nonsub ({}, [], \my $x) { + is eval { memoize $nonsub }, undef, "memoizing ${\ref $nonsub} ref fails"; + like $@, qr/^Usage: memoize 'functionname'\|coderef \{OPTIONS\}/, '... with the expected error'; +} + +sub no_warnings_ok (&$) { + my $w; + local $SIG{'__WARN__'} = sub { push @$w, @_; &diag }; + shift->(); + local $Test::Builder::Level = $Test::Builder::Level + 1; + is( $w, undef, shift ) or diag join '', @$w; +} + +sub q1 ($) { $_[0] + 1 } +sub q2 () { time } +sub q3 { join "--", @_ } + +no_warnings_ok { memoize 'q1' } 'no warnings with $ protype'; +no_warnings_ok { memoize 'q2' } 'no warnings with empty protype'; +no_warnings_ok { memoize 'q3' } 'no warnings without protype'; +is q1(@{['a'..'z']}), 27, '$ prototype is honored'; +is eval('q2("test")'), undef, 'empty prototype is honored'; +like $@, qr/^Too many arguments for main::q2 /, '... with the expected error'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/cache.t b/gnu/usr.bin/perl/cpan/Memoize/t/cache.t new file mode 100644 index 00000000000..75d9dcc7403 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/cache.t @@ -0,0 +1,148 @@ +use strict; use warnings; +use Memoize 0.45 qw(memoize unmemoize); +use Fcntl; +use Test::More tests => 65; + +sub list { wantarray ? @_ : $_[-1] } + +# Test FAULT +sub ns {} +sub na {} +ok eval { memoize 'ns', SCALAR_CACHE => 'FAULT'; 1 }, 'SCALAR_CACHE => FAULT'; +ok eval { memoize 'na', LIST_CACHE => 'FAULT'; 1 }, 'LIST_CACHE => FAULT'; +is eval { scalar(ns()) }, undef, 'exception in scalar context'; +is eval { list(na()) }, undef, 'exception in list context'; + +# Test FAULT/FAULT +sub dummy {1} +for ([qw(FAULT FAULT)], [qw(FAULT MERGE)], [qw(MERGE FAULT)]) { + my ($l_opt, $s_opt) = @$_; + my $memodummy = memoize 'dummy', LIST_CACHE => $l_opt, SCALAR_CACHE => $s_opt, INSTALL => undef; + my ($ret, $e); + { local $@; $ret = eval { scalar $memodummy->() }; $e = $@ } + is $ret, undef, "scalar context fails under $l_opt/$s_opt"; + like $e, qr/^Anonymous function called in forbidden scalar context/, '... with the right error message'; + { local $@; $ret = eval { +($memodummy->())[0] }; $e = $@ } + is $ret, undef, "list context fails under $l_opt/$s_opt"; + like $e, qr/^Anonymous function called in forbidden list context/, '... with the right error message'; + unmemoize $memodummy; +} + +# Test HASH +my (%s, %l); +sub nul {} +ok eval { memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l]; 1 }, '*_CACHE => HASH'; +nul('x'); +nul('y'); +is_deeply [sort keys %s], [qw(x y)], 'scalar context calls populate SCALAR_CACHE'; +is_deeply \%l, {}, '... and does not touch the LIST_CACHE'; +%s = (); +() = nul('p'); +() = nul('q'); +is_deeply [sort keys %l], [qw(p q)], 'list context calls populate LIST_CACHE'; +is_deeply \%s, {}, '... and does not touch the SCALAR_CACHE'; + +# Test MERGE +sub xx { wantarray } +ok !scalar(xx()), 'false in scalar context'; +ok list(xx()), 'true in list context'; +ok eval { memoize 'xx', LIST_CACHE => 'MERGE'; 1 }, 'LIST_CACHE => MERGE'; +ok !scalar(xx()), 'false in scalar context again'; +# Should return cached false value from previous invocation +ok !list(xx()), 'still false in list context'; + +sub reff { [1,2,3] } +sub listf { (1,2,3) } + +memoize 'reff', LIST_CACHE => 'MERGE'; +memoize 'listf'; + +scalar reff(); +is_deeply [reff()], [[1,2,3]], 'reff list context after scalar context'; + +scalar listf(); +is_deeply [listf()], [1,2,3], 'listf list context after scalar context'; + +unmemoize 'reff'; +memoize 'reff', LIST_CACHE => 'MERGE'; +unmemoize 'listf'; +memoize 'listf'; + +is_deeply [reff()], [[1,2,3]], 'reff list context'; + +is_deeply [listf()], [1,2,3], 'listf list context'; + +sub f17 { return 17 } +memoize 'f17', SCALAR_CACHE => 'MERGE'; +is_deeply [f17()], [17], 'f17 first call'; +is_deeply [f17()], [17], 'f17 second call'; +is scalar(f17()), 17, 'f17 scalar context call'; + +my (%cache, $num_cache_misses); +sub cacheit { + ++$num_cache_misses; + "cacheit result"; +} +sub test_cacheit { + is scalar(cacheit()), 'cacheit result', 'scalar context'; + is $num_cache_misses, 1, 'function called once'; + + is +(cacheit())[0], 'cacheit result', 'list context'; + is $num_cache_misses, 1, 'function not called again'; + + is_deeply [values %cache], [['cacheit result']], 'expected cached value'; + + %cache = (); + + is +(cacheit())[0], 'cacheit result', 'list context'; + is $num_cache_misses, 2, 'function again called after clearing the cache'; + + is scalar(cacheit()), 'cacheit result', 'scalar context'; + is $num_cache_misses, 2, 'function not called again'; +} + +memoize 'cacheit', LIST_CACHE => [HASH => \%cache], SCALAR_CACHE => 'MERGE'; +test_cacheit; +unmemoize 'cacheit'; +( $num_cache_misses, %cache ) = (); +memoize 'cacheit', SCALAR_CACHE => [HASH => \%cache], LIST_CACHE => 'MERGE'; +test_cacheit; + +# Test errors +my @w; +my $sub = eval { + local $SIG{'__WARN__'} = sub { push @w, @_ }; + memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga']); +}; +is $sub, undef, 'bad TIE fails'; +like $@, qr/^Can't locate WuggaWugga.pm in \@INC/, '... with the expected error'; +like $w[0], qr/^TIE option to memoize\(\) is deprecated; use HASH instead/, '... and the expected deprecation warning'; +is @w, 1, '... and no other warnings'; + +is eval { memoize sub {}, LIST_CACHE => 'YOB GORGLE' }, undef, 'bad LIST_CACHE fails'; +like $@, qr/^Unrecognized option to `LIST_CACHE': `YOB GORGLE'/, '... with the expected error'; + +is eval { memoize sub {}, SCALAR_CACHE => ['YOB GORGLE'] }, undef, 'bad SCALAR_CACHE fails'; +like $@, qr/^Unrecognized option to `SCALAR_CACHE': `YOB GORGLE'/, '... with the expected error'; + +for my $option (qw(LIST_CACHE SCALAR_CACHE)) { + is eval { memoize sub {}, $option => ['MERGE'] }, undef, "$option=>['MERGE'] fails"; + like $@, qr/^Unrecognized option to `$option': `MERGE'/, '... with the expected error'; +} + +# this test needs a DBM which +# a) Memoize knows is scalar-only +# b) is always available (on all platforms, perl configs etc) +# c) never fails to load +# so we use AnyDBM_File (which fulfills (a) & (b)) +# on top of a fake dummy DBM (ditto (b) & (c)) +sub DummyDBM::TIEHASH { bless {}, shift } +$INC{'DummyDBM.pm'} = 1; +@AnyDBM_File::ISA = 'DummyDBM'; +$sub = eval { + no warnings; + memoize sub {}, SCALAR_CACHE => [ TIE => 'AnyDBM_File' ], LIST_CACHE => 'MERGE'; +}; +is $sub, undef, 'smuggling in a scalar-only LIST_CACHE via MERGE fails'; +like $@, qr/^You can't use AnyDBM_File for LIST_CACHE because it can only store scalars/, + '... with the expected error'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t b/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t index ae567872557..b42cc3ef1dd 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t @@ -1,129 +1,103 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize; +use Test::More tests => 17; -print "1..25\n"; - -print "# Basic\n"; +# here we test whether memoization actually has the desired effect -# A function that should only be called once. -{ my $COUNT = 0; - sub no_args { - $FAIL++ if $COUNT++; - 11; - } +my ($fib, $ns1_calls, $ns2_calls, $total_calls) = ([0,1], 1, 1, 1+1); +while (@$fib < 23) { + push @$fib, $$fib[-1] + $$fib[-2]; + my $n_calls = 1 + $ns1_calls + $ns2_calls; + $total_calls += $n_calls; + ($ns2_calls, $ns1_calls) = ($ns1_calls, $n_calls); } -# -memoize('no_args'); - -$c1 = &no_args(); -print (($c1 == 11) ? "ok 1\n" : "not ok 1\n"); -$c2 = &no_args(); -print (($c2 == 11) ? "ok 2\n" : "not ok 2\n"); -print $FAIL ? "not ok 3\n" : "ok 3\n"; # Was it really memoized? - -$FAIL = 0; -$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } }; -$fm = memoize($f); - -$c1 = &$fm(); -print (($c1 == 12) ? "ok 4\n" : "not ok 4\n"); -$c2 = &$fm(); -print (($c2 == 12) ? "ok 5\n" : "not ok 5\n"); -print $FAIL ? "not ok 6\n" : "ok 6\n"; # Was it really memoized? - -$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } }; -$fm = memoize($f, INSTALL => 'another'); - -$c1 = &another(); # Was it really installed? -print (($c1 == 13) ? "ok 7\n" : "not ok 7\n"); -$c2 = &another(); -print (($c2 == 13) ? "ok 8\n" : "not ok 8\n"); -print $FAIL ? "not ok 9\n" : "ok 9\n"; # Was it really memoized? -$c3 = &$fm(); # Call memoized version through returned ref -print (($c3 == 13) ? "ok 10\n" : "not ok 10\n"); -print $FAIL ? "not ok 11\n" : "ok 11\n"; # Was it really memoized? -$c4 = &$f(); # Call original version again -print (($c4 == 13) ? "ok 12\n" : "not ok 12\n"); -print $FAIL ? "ok 13\n" : "not ok 13\n"; # Did we get the original? - -print "# Fibonacci\n"; - -sub mt1 { # Fibonacci - my $n = shift; - return $n if $n < 2; - mt1($n-1) + mt2($n-2); -} -sub mt2 { - my $n = shift; - return $n if $n < 2; - mt1($n-1) + mt2($n-2); +my $num_calls; +sub fib { + ++$num_calls; + my $n = shift; + return $n if $n < 2; + fib($n-1) + fib($n-2); } -@f1 = map { mt1($_) } (0 .. 15); -@f2 = map { mt2($_) } (0 .. 15); -memoize('mt1'); -@f3 = map { mt1($_) } (0 .. 15); -@f4 = map { mt1($_) } (0 .. 15); -@arrays = (\@f1, \@f2, \@f3, \@f4); -$n = 13; -for ($i=0; $i<3; $i++) { - for ($j=$i+1; $j<3; $j++) { - $n++; - print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n"); - $n++; - for ($k=0; $k < @{$arrays[$i]}; $k++) { - (print "not ok $n\n", next) if $arrays[$i][$k] != $arrays[$j][$k]; - } - print "ok $n\n"; - } -} +my @s1 = map 0+fib($_), 0 .. $#$fib; +is_deeply \@s1, $fib, 'unmemoized Fibonacci works'; +is $num_calls, $total_calls, '... with the expected amount of calls'; +undef $num_calls; +memoize 'fib'; +my @f1 = map 0+fib($_), 0 .. $#$fib; +my @f2 = map 0+fib($_), 0 .. $#$fib; +is_deeply \@f1, $fib, 'memoized Fibonacci works'; +is $num_calls, @$fib, '... with a minimal amount of calls'; -print "# Normalizers\n"; +######################################################################## -sub fake_normalize { - return ''; -} +my $timestamp; +sub timelist { (++$timestamp) x $_[0] } -sub f1 { - return shift; -} -sub f2 { - return shift; -} -sub f3 { - return shift; -} -&memoize('f1'); -&memoize('f2', NORMALIZER => 'fake_normalize'); -&memoize('f3', NORMALIZER => \&fake_normalize); -@f1r = map { f1($_) } (1 .. 10); -@f2r = map { f2($_) } (1 .. 10); -@f3r = map { f3($_) } (1 .. 10); -$n++; -print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n"); -$n++; -print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n"); -$n++; -print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n"); - -print "# INSTALL => undef option.\n"; -{ my $i = 1; - sub u1 { $i++ } +memoize('timelist'); + +my $t1 = [timelist(1)]; +is_deeply [timelist(1)], $t1, 'memoizing a volatile function makes it stable'; +my $t7 = [timelist(7)]; +isnt @$t1, @$t7, '... unless the arguments change'; +is_deeply $t7, [($$t7[0]) x 7], '... which leads to the expected new return value'; +is_deeply [timelist(7)], $t7, '... which then also stays stable'; + +sub con { wantarray ? 'list' : 'scalar' } +memoize('con'); +is scalar(con(1)), 'scalar', 'scalar context propgates properly'; +is_deeply [con(1)], ['list'], 'list context propgates properly'; + +######################################################################## + +my %underlying; +sub ExpireTest::TIEHASH { bless \%underlying, shift } +sub ExpireTest::EXISTS { exists $_[0]{$_[1]} } +sub ExpireTest::FETCH { $_[0]{$_[1]} } +sub ExpireTest::STORE { $_[0]{$_[1]} = $_[2] } + +my %CALLS; +sub id { + my($arg) = @_; + ++$CALLS{$arg}; + $arg; } -my $um = memoize('u1', INSTALL => undef); -@umr = (&$um, &$um, &$um); -@u1r = (&u1, &u1, &u1 ); # Did *not* clobber &u1 -$n++; -print (("@umr" eq "1 1 1") ? "ok $n\n" : "not ok $n\n"); # Increment once -$n++; -print (("@u1r" eq "2 3 4") ? "ok $n\n" : "not ok $n\n"); # Increment thrice -$n++; -print ((defined &{"undef"}) ? "not ok $n\n" : "ok $n\n"); # Just in case - -print "# $n tests in all.\n"; +tie my %cache => 'ExpireTest'; +memoize 'id', + SCALAR_CACHE => [HASH => \%cache], + LIST_CACHE => 'FAULT'; + +my $arg = [1..3, 1, 2, 1]; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>1,2=>1,3=>1}, 'amount of initial calls per arg as expected'; + +delete $underlying{1}; +$arg = [1..3]; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>2,2=>1,3=>1}, 'amount of calls per arg after expiring 1 as expected'; + +delete @underlying{1,2}; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>3,2=>2,3=>1}, 'amount of calls per arg after expiring 1 & 2 as expected'; + +######################################################################## + +my $fail; +$SIG{__WARN__} = sub { if ( $_[0] =~ /^Deep recursion/ ) { $fail = 1 } else { warn $_[0] } }; + +my $limit; +sub deep_probe { deep_probe() if ++$limit < 100_000 and not $fail } +sub deep_test { no warnings "recursion"; deep_test() if $limit-- > 0 } +memoize "deep_test"; + +SKIP: { + deep_probe(); + skip "no warning after $limit recursive calls (maybe PERL_SUB_DEPTH_WARN was raised?)", 1 if not $fail; + undef $fail; + deep_test(); + ok !$fail, 'no recursion warning thrown from Memoize'; +} diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t b/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t new file mode 100644 index 00000000000..4e82b3904b8 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t @@ -0,0 +1,57 @@ +use strict; use warnings; +use Memoize; +use Memoize::Expire; +use Test::More tests => 22; + +tie my %h => 'Memoize::Expire', HASH => \my %backing; + +$h{foo} = 1; +my $num_keys = keys %backing; +my $num_refs = grep ref, values %backing; + +is $h{foo}, 1, 'setting and getting a plain scalar value works'; +cmp_ok $num_keys, '>', 0, 'HASH option is effective'; +is $num_refs, 0, 'backing storage contains only plain scalars'; + +$h{bar} = my $bar = {}; +my $num_keys_step2 = keys %backing; +$num_refs = grep ref, values %backing; + +is ref($h{bar}), ref($bar), 'setting and getting a reference value works'; +cmp_ok $num_keys, '<', $num_keys_step2, 'HASH option is effective'; +is $num_refs, 1, 'backing storage contains only one reference'; + +my $contents = eval { +{ %h } }; + +ok defined $contents, 'dumping the tied hash works'; +is_deeply $contents, { foo => 1, bar => $bar }, ' ... with the expected contents'; + +######################################################################## + +my $RETURN = 1; +my %CALLS; + +tie my %cache => 'Memoize::Expire', NUM_USES => 2; +memoize sub { ++$CALLS{$_[0]}; $RETURN }, + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT', + INSTALL => 'call'; + +is call($_), 1, "$_ gets new val" for 0..3; + +is_deeply \%CALLS, {0=>1,1=>1,2=>1,3=>1}, 'memoized function called once per argument'; + +$RETURN = 2; +is call(1), 1, '1 expires'; +is call(1), 2, '1 gets new val'; +is call(2), 1, '2 expires'; + +is_deeply \%CALLS, {0=>1,1=>2,2=>1,3=>1}, 'memoized function called for expired argument'; + +$RETURN = 3; +is call(0), 1, '0 expires'; +is call(1), 2, '1 expires'; +is call(2), 3, '2 gets new val'; +is call(3), 1, '3 expires'; + +is_deeply \%CALLS, {0=>1,1=>2,2=>2,3=>1}, 'memoized function called for other expired argument'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t b/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t index 3573c216854..1b63b09defe 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t @@ -1,9 +1,6 @@ -#!/usr/bin/perl - -# test caching timeout - -use lib '..'; +use strict; use warnings; use Memoize; +use Memoize::Expire; my $DEBUG = 0; my $LIFETIME = 15; @@ -11,32 +8,21 @@ my $LIFETIME = 15; my $test = 0; $| = 1; -if (-e '.fast') { - print "1..0\n"; +if ($ENV{PERL_MEMOIZE_TESTS_FAST_ONLY}) { + print "1..0 # Skipped: Slow tests disabled\n"; exit 0; } print "# Testing the timed expiration policy.\n"; print "# This will take about thirty seconds.\n"; -print "1..26\n"; - -require Memoize::Expire; -++$test; print "ok $test - Expire loaded\n"; - -sub now { -# print "NOW: @_ ", time(), "\n"; - time; -} +print "1..24\n"; tie my %cache => 'Memoize::Expire', LIFETIME => $LIFETIME; - -memoize 'now', - SCALAR_CACHE => [HASH => \%cache ], - LIST_CACHE => 'FAULT' - ; - -++$test; print "ok $test - function memoized\n"; +memoize sub { time }, + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT', + INSTALL => 'now'; my (@before, @after, @now); diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/flush.t b/gnu/usr.bin/perl/cpan/Memoize/t/flush.t index bf9262ec7ca..33eceac8879 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/flush.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/flush.t @@ -1,42 +1,24 @@ -#!/usr/bin/perl - -use lib '..'; -use Memoize 'flush_cache', 'memoize'; -print "1..8\n"; -print "ok 1\n"; - - +use strict; use warnings; +use Memoize qw(flush_cache memoize); +use Test::More tests => 9; my $V = 100; sub VAL { $V } -memoize 'VAL'; -print "ok 2\n"; - -my $c1 = VAL(); -print (($c1 == 100) ? "ok 3\n" : "not ok 3\n"); +ok eval { memoize('VAL'); 1 }, 'memozing the test function'; +is VAL(), 100, '... with the expected return value'; $V = 200; -$c1 = VAL(); -print (($c1 == 100) ? "ok 4\n" : "not ok 4\n"); +is VAL(), 100, '... which is expectedly sticky'; -flush_cache('VAL'); -$c1 = VAL(); -print (($c1 == 200) ? "ok 5\n" : "not ok 5\n"); +ok eval { flush_cache('VAL'); 1 }, 'flusing the cache by name works'; +is VAL(), 200, '... with the expected new return value'; $V = 300; -$c1 = VAL(); -print (($c1 == 200) ? "ok 6\n" : "not ok 6\n"); +is VAL(), 200, '... which is expectedly sticky'; -flush_cache(\&VAL); -$c1 = VAL(); -print (($c1 == 300) ? "ok 7\n" : "not ok 7\n"); +ok eval { flush_cache(\&VAL); 1 }, 'flusing the cache by name works'; +is VAL(), 300, '... with the expected new return value'; $V = 400; -$c1 = VAL(); -print (($c1 == 300) ? "ok 8\n" : "not ok 8\n"); - - - - - +is VAL(), 300, '... which is expectedly sticky'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm b/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm new file mode 100644 index 00000000000..59c18d5d75a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm @@ -0,0 +1,102 @@ +use strict; use warnings; + +package DBMTest; + +my ($module, $is_scalar_only); + +use Memoize qw(memoize unmemoize); +use Test::More; + +sub errlines { split /\n/, $@ } + +my $ARG = 'Keith Bostic is a pinhead'; + +sub c5 { 5 } +sub c23 { 23 } + +sub test_dbm { SKIP: { + tie my %cache, $module, @_ or die $!; + + my $sub = eval { unmemoize memoize sub {}, LIST_CACHE => [ HASH => \%cache ] }; + my $errx = qr/^You can't use \Q$module\E for LIST_CACHE because it can only store scalars/; + if ($is_scalar_only) { + is $sub, undef, "use as LIST_CACHE fails"; + like $@, $errx, '... with the expected error'; + } else { + ok $sub, "use as LIST_CACHE succeeds"; + } + + $sub = eval { no warnings; unmemoize memoize sub {}, LIST_CACHE => [ TIE => $module, @_ ] }; + if ($is_scalar_only) { + is $sub, undef, '... including under the TIE option'; + like $@, $errx, '... with the expected error'; + } else { + ok $sub, 'use as LIST_CACHE succeeds'; + } + + eval { exists $cache{'dummy'}; 1 } + or skip join("\n", 'exists() unsupported', errlines), 3; + + memoize 'c5', + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT'; + + is c5($ARG), 5, 'store value during first memoization'; + unmemoize 'c5'; + + untie %cache; + + tie %cache, $module, @_ or die $!; + + # Now something tricky---we'll memoize c23 with the wrong table that + # has the 5 already cached. + memoize 'c23', + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT'; + + is c23($ARG), 5, '... and find it still there after second memoization'; + unmemoize 'c23'; + + untie %cache; + + { no warnings; memoize 'c23', + SCALAR_CACHE => [ TIE => $module, @_ ], + LIST_CACHE => 'FAULT'; + } + + is c23($ARG), 5, '... as well as a third memoization via TIE'; + unmemoize 'c23'; +} } + +my @file; + +sub cleanup { 1 while unlink @file } + +sub import { + (undef, $module, my %arg) = (shift, @_); + + $is_scalar_only = $arg{'is_scalar_only'} ? 2 : 0; + eval "require $module" + ? plan tests => 5 + $is_scalar_only + ($arg{extra_tests}||0) + : plan skip_all => join "\n# ", "Could not load $module", errlines; + + my ($basename) = map { s/.*:://; s/_file\z//; 'm_'.$_.$$ } lc $module; + my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; # copypaste from DBD::DBM + @file = map { $_, "$_.db", "$_.pag", $_.$dirfext } $basename; + cleanup; + + my $pkg = caller; + no strict 'refs'; + *{$pkg.'::'.$_} = \&$_ for qw(test_dbm cleanup); + *{$pkg.'::file'} = \$basename; +} + +END { + cleanup; + if (my @failed = grep -e, @file) { + @failed = grep !unlink, @failed; # to set $! + warn "Can't unlink @failed! ($!)\n" if @failed; + } +} + +1; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t b/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t index a920ff4b307..8b9f90f2b7e 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t @@ -1,10 +1,6 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize; - -print "1..7\n"; - +use Test::More tests => 11; sub n_null { '' } @@ -24,34 +20,47 @@ my $a_normal = memoize('a1', INSTALL => undef); my $a_nomemo = memoize('a2', INSTALL => undef, NORMALIZER => 'n_diff'); my $a_allmemo = memoize('a3', INSTALL => undef, NORMALIZER => 'n_null'); +my @ARGS; @ARGS = (1, 2, 3, 2, 1); -@res = map { &$a_normal($_) } @ARGS; -print ((("@res" eq "1-1 2-2 3-3 2-2 1-1") ? '' : 'not '), "ok 1\n"); - -@res = map { &$a_nomemo($_) } @ARGS; -print ((("@res" eq "1-1 2-2 3-3 2-4 1-5") ? '' : 'not '), "ok 2\n"); +is_deeply [map $a_normal->($_), @ARGS], [qw(1-1 2-2 3-3 2-2 1-1)], 'no normalizer'; +is_deeply [map $a_nomemo->($_), @ARGS], [qw(1-1 2-2 3-3 2-4 1-5)], 'n_diff'; +is_deeply [map $a_allmemo->($_), @ARGS], [qw(1-1 1-1 1-1 1-1 1-1)], 'n_null'; -@res = map { &$a_allmemo($_) } @ARGS; -print ((("@res" eq "1-1 1-1 1-1 1-1 1-1") ? '' : 'not '), "ok 3\n"); - - - # Test fully-qualified name and installation +my $COUNT; $COUNT = 0; sub parity { $COUNT++; $_[0] % 2 } sub parnorm { $_[0] % 2 } memoize('parity', NORMALIZER => 'main::parnorm'); -@res = map { &parity($_) } @ARGS; -print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 4\n"); -print (( ($COUNT == 2) ? '' : 'not '), "ok 5\n"); +is_deeply [map parity($_), @ARGS], [qw(1 0 1 0 1)], 'parity normalizer'; +is $COUNT, 2, '... with the expected number of calls'; # Test normalization with reference to normalizer function $COUNT = 0; sub par2 { $COUNT++; $_[0] % 2 } memoize('par2', NORMALIZER => \&parnorm); -@res = map { &par2($_) } @ARGS; -print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 6\n"); -print (( ($COUNT == 2) ? '' : 'not '), "ok 7\n"); +is_deeply [map par2($_), @ARGS], [qw(1 0 1 0 1)], '... also installable by coderef'; +is $COUNT, 2, '... still with the expected number of calls'; + +$COUNT = 0; +sub count_uninitialized { $COUNT += join('', @_) =~ /\AUse of uninitialized value / } +my $war1 = memoize(sub {1}, NORMALIZER => sub {undef}); +{ local $SIG{__WARN__} = \&count_uninitialized; $war1->() } +is $COUNT, 0, 'no warning when normalizer returns undef'; +# Context propagated correctly to normalizer? +sub n { + my $which = wantarray ? 'list' : 'scalar'; + local $Test::Builder::Level = $Test::Builder::Level + 2; + is $_[0], $which, "$which context propagates properly"; +} +sub f { 1 } +memoize('f', NORMALIZER => 'n'); +my $s = f 'scalar'; +my @a = f 'list'; +sub args { scalar @_ } +sub null_args { join chr(28), splice @_ } +memoize('args', NORMALIZER => 'null_args'); +ok args(1), 'original @_ is protected from normalizer'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency b/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency new file mode 100644 index 00000000000..42e53f92411 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency @@ -0,0 +1,36 @@ +#!/bin/sh + +# running this script intermittently yields +# +# Magic number checking on storable file failed at ... +# +# but it is difficult to trigger this error 100% reliably +# as would be needed to turn this script into an actual test + +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +wait && exec rm st_shared + +#!perl +use strict; use warnings; + +use Memoize::Storable; +use Fcntl 'LOCK_EX'; + +sub rand32 () { int rand 1<<32 } + +# the script locks itself to increase the likelihood of the error: +# after releasing the lock, the first process writes to the file +# just as another process acquires the lock and starts to read it +# (but this still does not trigger the error reliably) + +open my $fh, $0 or die $!; +flock $fh, LOCK_EX or die $!; + +tie my %cache => 'Memoize::Storable', $ARGV[0]; +$cache{(rand32)} = rand32; + +close $fh; +# vim: ft=perl diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t b/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t new file mode 100644 index 00000000000..e562aafd0a4 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t @@ -0,0 +1,37 @@ +use strict; use warnings; + +use Memoize qw(memoize unmemoize); +use Test::More + ("$]" < 5.009 || "$]" >= 5.010001) && eval { require threads; 1 } + ? ( tests => 8 ) + : ( skip_all => $@ ); + +my $i; +sub count_up { ++$i } + +memoize('count_up'); +my $cached = count_up(); + +is count_up(), $cached, 'count_up() is memoized'; + +my $got = threads->new(sub { + local $@ = ''; + my $v = eval { count_up() }; + +{ E => $@, V => $v }; +})->join; + +is $got->{E}, '', 'calling count_up() in another thread works'; +is $got->{V}, $cached, '... and returns the same result'; +is count_up(), $cached, '... whereas count_up() on the main thread is unaffected'; + +$got = threads->new(sub { + local $@ = ''; + my $u = eval { unmemoize('count_up') }; + my $v = eval { count_up() }; + +{ E => $@, U => $u, V => $v }; +})->join; + +is $got->{E}, '', 'unmemoizing count_up() in another thread works'; +is ref($got->{U}), 'CODE', '... and returns a coderef as expected'; +is $got->{V}, 1+$cached, '... and does in fact unmemoize the function'; +is count_up(), $cached, '... whereas count_up() on the main thread is unaffected'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie.t index 02c20d6fc79..fbae0e98869 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie.t @@ -1,80 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.52 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -eval {require Memoize::AnyDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - - - -print "1..4\n"; - -sub i { - $_[0]; -} - -$ARG = 'Keith Bostic is a pinhead'; - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -$file = "md$$"; -@files = ($file, "$file.db", "$file.dir", "$file.pag"); -1 while unlink @files; - - -tryout('Memoize::AnyDBM_File', $file, 1); # Test 1..4 -# tryout('DB_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5($ARG); - my $t2 = c5($ARG); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => ['HASH', \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23($ARG); - my $t4 = c23($ARG); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno # Result $t3\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno # Result $t4\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'Memoize::AnyDBM_File', is_scalar_only => 1; -{ - my @present = grep -e, @files; - if (@present && (@failed = grep { not unlink } @present)) { - warn "Can't unlink @failed! ($!)"; - } -} +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t new file mode 100644 index 00000000000..3c72e7fbd34 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t @@ -0,0 +1,8 @@ +use strict; use warnings; +use Fcntl; + +use lib 't/lib'; +use DBMTest 'DB_File', is_scalar_only => 1; + +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t index 8d55647b01d..e738cc454d6 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t @@ -1,68 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require GDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag"; -tryout('GDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; - -sub tryout { - require GDBM_File; - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, &GDBM_File::GDBM_NEWDB, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'GDBM_File', is_scalar_only => 1; +test_dbm $file, &GDBM_File::GDBM_WRCREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t index a328bc01bb7..b261c1cc703 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t @@ -1,70 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -# use Memoize::NDBM_File; -# $Memoize::NDBM_File::Verbose = 0; - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require Memoize::NDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag", "$file.db"; -tryout('Memoize::NDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag", "$file.db"; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'Memoize::NDBM_File', is_scalar_only => 1; +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t new file mode 100644 index 00000000000..611afc3ef58 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t @@ -0,0 +1,8 @@ +use strict; use warnings; +use Fcntl; + +use lib 't/lib'; +use DBMTest 'ODBM_File', is_scalar_only => 1; + +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t index 588efd95612..d0126c2ed7a 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t @@ -1,75 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -# use Memoize::SDBM_File; -# $Memoize::GDBM_File::Verbose = 0; - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require Memoize::SDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag"; -if ( $^O eq 'VMS' ) { - 1 while unlink "$file.sdbm_dir"; -} -tryout('Memoize::SDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; -if ( $^O eq 'VMS' ) { - 1 while unlink "$file.sdbm_dir"; -} - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'SDBM_File', is_scalar_only => 1; +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t index de3b8dc26b8..99e0cfdcd20 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t @@ -1,76 +1,16 @@ -#!/usr/bin/perl -# -*- mode: perl; perl-indent-level: 2 -*- +use strict; use warnings; +use Test::More; -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); -# $Memoize::Storable::Verbose = 0; +use lib 't/lib'; +use DBMTest 'Memoize::Storable', extra_tests => 1; -eval {require Memoize::Storable}; -if ($@) { - print "1..0\n"; - exit 0; -} - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } +test_dbm $file; +cleanup; -sub n { - $_[0]+1; +SKIP: { + skip "skip Storable $Storable::VERSION too old for last_op_in_netorder", 1 + unless eval { Storable->VERSION('0.609') }; + { tie my %cache, 'Memoize::Storable', $file, 'nstore' or die $! } + ok Storable::last_op_in_netorder(), 'nstore option works'; + cleanup; } - -eval {require Storable}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "storable$$"; -1 while unlink $file; -tryout('Memoize::Storable', $file, 1); # Test 1..4 -1 while unlink $file; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - 1; - 1; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} - diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t b/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t index 82b318c6452..f4b9e98991c 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t @@ -1,26 +1,51 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize qw(memoize unmemoize); - -print "1..5\n"; - -eval { unmemoize('f') }; # Should fail -print (($@ ? '' : 'not '), "ok 1\n"); - -{ my $I = 0; - sub u { $I++ } +use Test::More tests => 26; + +is eval { unmemoize('u') }, undef, 'trying to unmemoize without memoizing fails'; +my $errx = qr/^Could not unmemoize function `u', because it was not memoized to begin with/; +like $@, $errx, '... with the expected error'; + +sub u {1} +my $sub = \&u; +my $wrapped = memoize('u'); +is \&u, $wrapped, 'trying to memoize succeeds'; + +is eval { unmemoize('u') }, $sub, 'trying to unmemoize succeeds' or diag $@; + +is \&u, $sub, '... and does in fact unmemoize it'; + +is eval { unmemoize('u') }, undef, 'trying to unmemoize it again fails'; +like $@, $errx, '... with the expected error'; + +# Memoizing a function multiple times separately is not very useful +# but it should not break unmemoize or make memoization lose its mind + +my $ret; +my $dummy = sub { $ret }; +ok memoize $dummy, INSTALL => 'memo1'; +ok memoize $dummy, INSTALL => 'memo2'; +ok defined &memo1, 'memoized once'; +ok defined &memo2, 'memoized twice'; +$@ = ''; +ok eval { unmemoize 'memo1' }, 'unmemoized once'; +is $@, '', '... and no exception'; +$@ = ''; +ok eval { unmemoize 'memo2' }, 'unmemoized twice'; +is $@, '', '... and no exception'; +is \&memo1, $dummy, 'unmemoized installed once'; +is \&memo2, $dummy, 'unmemoized installed twice'; + +my @quux = qw(foo bar baz); +my %memo = map +($_ => memoize $dummy), @quux; +for (@quux) { $ret = $_; is $memo{$_}->(), $_, "\$memo{$_}->() returns $_" } +for (@quux) { undef $ret; is $memo{$_}->(), $_, "\$memo{$_}->() returns $_" } + +my $destroyed = 0; +sub Counted::DESTROY { ++$destroyed } +{ + my $memo = memoize $dummy, map +( "$_\_CACHE" => [ HASH => bless {}, 'Counted' ] ), qw(LIST SCALAR); + ok $memo, 'memoize anon'; + ok eval { unmemoize $memo }, 'unmemoized anon'; } -memoize('u'); -my @ur = (&u, &u, &u); -print (("@ur" eq "0 0 0") ? "ok 2\n" : "not ok 2\n"); - -eval { unmemoize('u') }; # Should succeed -print ($@ ? "not ok 3\n" : "ok 3\n"); - -@ur = (&u, &u, &u); -print (("@ur" eq "1 2 3") ? "ok 4\n" : "not ok 4\n"); - -eval { unmemoize('u') }; # Should fail -print ($@ ? "ok 5\n" : "not ok 5\n"); - +is $destroyed, 2, 'no cyclic references'; |