summaryrefslogtreecommitdiff
path: root/gnu/usr.bin/perl/cpan/Memoize/t
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/usr.bin/perl/cpan/Memoize/t')
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/basic.t90
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/cache.t148
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/correctness.t204
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/expmod.t57
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t32
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/flush.t42
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm102
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/normalize.t53
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency36
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t37
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/tie.t82
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t8
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t70
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t72
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t8
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t77
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t84
-rwxr-xr-xgnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t73
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';