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