1*f2a19305Safresh1use strict; use warnings; 2*f2a19305Safresh1 3*f2a19305Safresh1package DBMTest; 4*f2a19305Safresh1 5*f2a19305Safresh1my ($module, $is_scalar_only); 6*f2a19305Safresh1 7*f2a19305Safresh1use Memoize qw(memoize unmemoize); 8*f2a19305Safresh1use Test::More; 9*f2a19305Safresh1 10*f2a19305Safresh1sub errlines { split /\n/, $@ } 11*f2a19305Safresh1 12*f2a19305Safresh1my $ARG = 'Keith Bostic is a pinhead'; 13*f2a19305Safresh1 14*f2a19305Safresh1sub c5 { 5 } 15*f2a19305Safresh1sub c23 { 23 } 16*f2a19305Safresh1 17*f2a19305Safresh1sub test_dbm { SKIP: { 18*f2a19305Safresh1 tie my %cache, $module, @_ or die $!; 19*f2a19305Safresh1 20*f2a19305Safresh1 my $sub = eval { unmemoize memoize sub {}, LIST_CACHE => [ HASH => \%cache ] }; 21*f2a19305Safresh1 my $errx = qr/^You can't use \Q$module\E for LIST_CACHE because it can only store scalars/; 22*f2a19305Safresh1 if ($is_scalar_only) { 23*f2a19305Safresh1 is $sub, undef, "use as LIST_CACHE fails"; 24*f2a19305Safresh1 like $@, $errx, '... with the expected error'; 25*f2a19305Safresh1 } else { 26*f2a19305Safresh1 ok $sub, "use as LIST_CACHE succeeds"; 27*f2a19305Safresh1 } 28*f2a19305Safresh1 29*f2a19305Safresh1 $sub = eval { no warnings; unmemoize memoize sub {}, LIST_CACHE => [ TIE => $module, @_ ] }; 30*f2a19305Safresh1 if ($is_scalar_only) { 31*f2a19305Safresh1 is $sub, undef, '... including under the TIE option'; 32*f2a19305Safresh1 like $@, $errx, '... with the expected error'; 33*f2a19305Safresh1 } else { 34*f2a19305Safresh1 ok $sub, 'use as LIST_CACHE succeeds'; 35*f2a19305Safresh1 } 36*f2a19305Safresh1 37*f2a19305Safresh1 eval { exists $cache{'dummy'}; 1 } 38*f2a19305Safresh1 or skip join("\n", 'exists() unsupported', errlines), 3; 39*f2a19305Safresh1 40*f2a19305Safresh1 memoize 'c5', 41*f2a19305Safresh1 SCALAR_CACHE => [ HASH => \%cache ], 42*f2a19305Safresh1 LIST_CACHE => 'FAULT'; 43*f2a19305Safresh1 44*f2a19305Safresh1 is c5($ARG), 5, 'store value during first memoization'; 45*f2a19305Safresh1 unmemoize 'c5'; 46*f2a19305Safresh1 47*f2a19305Safresh1 untie %cache; 48*f2a19305Safresh1 49*f2a19305Safresh1 tie %cache, $module, @_ or die $!; 50*f2a19305Safresh1 51*f2a19305Safresh1 # Now something tricky---we'll memoize c23 with the wrong table that 52*f2a19305Safresh1 # has the 5 already cached. 53*f2a19305Safresh1 memoize 'c23', 54*f2a19305Safresh1 SCALAR_CACHE => [ HASH => \%cache ], 55*f2a19305Safresh1 LIST_CACHE => 'FAULT'; 56*f2a19305Safresh1 57*f2a19305Safresh1 is c23($ARG), 5, '... and find it still there after second memoization'; 58*f2a19305Safresh1 unmemoize 'c23'; 59*f2a19305Safresh1 60*f2a19305Safresh1 untie %cache; 61*f2a19305Safresh1 62*f2a19305Safresh1 { no warnings; memoize 'c23', 63*f2a19305Safresh1 SCALAR_CACHE => [ TIE => $module, @_ ], 64*f2a19305Safresh1 LIST_CACHE => 'FAULT'; 65*f2a19305Safresh1 } 66*f2a19305Safresh1 67*f2a19305Safresh1 is c23($ARG), 5, '... as well as a third memoization via TIE'; 68*f2a19305Safresh1 unmemoize 'c23'; 69*f2a19305Safresh1} } 70*f2a19305Safresh1 71*f2a19305Safresh1my @file; 72*f2a19305Safresh1 73*f2a19305Safresh1sub cleanup { 1 while unlink @file } 74*f2a19305Safresh1 75*f2a19305Safresh1sub import { 76*f2a19305Safresh1 (undef, $module, my %arg) = (shift, @_); 77*f2a19305Safresh1 78*f2a19305Safresh1 $is_scalar_only = $arg{'is_scalar_only'} ? 2 : 0; 79*f2a19305Safresh1 eval "require $module" 80*f2a19305Safresh1 ? plan tests => 5 + $is_scalar_only + ($arg{extra_tests}||0) 81*f2a19305Safresh1 : plan skip_all => join "\n# ", "Could not load $module", errlines; 82*f2a19305Safresh1 83*f2a19305Safresh1 my ($basename) = map { s/.*:://; s/_file\z//; 'm_'.$_.$$ } lc $module; 84*f2a19305Safresh1 my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; # copypaste from DBD::DBM 85*f2a19305Safresh1 @file = map { $_, "$_.db", "$_.pag", $_.$dirfext } $basename; 86*f2a19305Safresh1 cleanup; 87*f2a19305Safresh1 88*f2a19305Safresh1 my $pkg = caller; 89*f2a19305Safresh1 no strict 'refs'; 90*f2a19305Safresh1 *{$pkg.'::'.$_} = \&$_ for qw(test_dbm cleanup); 91*f2a19305Safresh1 *{$pkg.'::file'} = \$basename; 92*f2a19305Safresh1} 93*f2a19305Safresh1 94*f2a19305Safresh1END { 95*f2a19305Safresh1 cleanup; 96*f2a19305Safresh1 if (my @failed = grep -e, @file) { 97*f2a19305Safresh1 @failed = grep !unlink, @failed; # to set $! 98*f2a19305Safresh1 warn "Can't unlink @failed! ($!)\n" if @failed; 99*f2a19305Safresh1 } 100*f2a19305Safresh1} 101*f2a19305Safresh1 102*f2a19305Safresh11; 103