This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DBM_Filter test: use std test preamble
[perl5.git] / lib / DBM_Filter / t / 01error.t
CommitLineData
0e9b1cbd
PM
1use strict;
2use warnings;
3use Carp;
4
c3296b12
JH
5BEGIN {
6 chdir 't' if -d 't';
7 @INC = qw(. ../lib);
8}
9
0e9b1cbd
PM
10our $db ;
11
12{
13 chdir 't' if -d 't';
14 if ( ! -d 'DBM_Filter')
15 {
16 mkdir 'DBM_Filter', 0777
9aedf6d8 17 or die "Cannot create directory 'DBM_Filter': $!\n" ;
0e9b1cbd
PM
18 }
19}
20
9aedf6d8
RGS
21END { rmdir 'DBM_Filter' }
22
0e9b1cbd
PM
23sub writeFile
24{
25 my $filename = shift ;
26 my $content = shift;
9aedf6d8 27 open F, ">$filename" or croak "Cannot open $filename: $!" ;
0e9b1cbd
PM
28 print F $content ;
29 close F;
30}
31
32sub runFilter
33{
34 my $name = shift ;
35 my $filter = shift ;
36
37print "# runFilter $name\n" ;
38 my $filename = "DBM_Filter/$name.pm";
39 $filter = "package DBM_Filter::$name ;\n$filter"
40 unless $filter =~ /^\s*package/ ;
41
42 writeFile($filename, $filter);
43 eval { $db->Filter_Push($name) };
44 unlink $filename;
45 return $@;
46}
47
48use Test::More tests => 21;
49
50BEGIN { use_ok('DBM_Filter') };
e8ebc68a
JH
51my $db_file;
52BEGIN {
53 use Config;
54 foreach (qw/ODBM_File SDBM_File NDBM_File GDBM_File DB_File/) {
55 if ($Config{extensions} =~ /\b$_\b/) {
56 $db_file = $_;
57 last;
58 }
59 }
60 use_ok($db_file);
61};
0e9b1cbd
PM
62BEGIN { use_ok('Fcntl') };
63
64unlink <Op_dbmx*>;
65END { unlink <Op_dbmx*>; }
66
67my %h1 = () ;
68my %h2 = () ;
e8ebc68a 69$db = tie(%h1, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
0e9b1cbd 70
e8ebc68a 71ok $db, "tied to $db_file ok";
0e9b1cbd
PM
72
73
74# Error cases
75
76eval { $db->Filter_Push() ; };
77like $@, qr/^Filter_Push: no parameters present/,
78 "croak if not parameters passed to Filter_Push";
79
80eval { $db->Filter_Push("unknown_class") ; };
81like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/,
82 "croak on unknown class" ;
83
84eval { $db->Filter_Push("Some::unknown_class") ; };
85like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/,
86 "croak on unknown fully qualified class" ;
87
88eval { $db->Filter_Push('Store') ; };
89like $@, qr/^Filter_Push: not even params/,
90 "croak if not passing even number or params to Filter_Push";
91
92runFilter('bad1', <<'EOM');
93 package DBM_Filter::bad1 ;
94 1;
95EOM
96
97like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
98 "croak if none of Filter/Fetch/Store in filter" ;
99
100
101runFilter('bad2', <<'EOM');
102 package DBM_Filter::bad2 ;
103
104 sub Filter
105 {
106 return 2;
107 }
108
109 1;
110EOM
111
112like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
113 "croak if Filter doesn't return hash reference" ;
114
115runFilter('bad3', <<'EOM');
116 package DBM_Filter::bad3 ;
117
118 sub Filter
119 {
120 return { BadKey => sub { } } ;
121
122 }
123
124 1;
125EOM
126
127like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
128 "croak if bad keyword returned from Filter";
129
130runFilter('bad4', <<'EOM');
131 package DBM_Filter::bad4 ;
132
133 sub Filter
134 {
135 return { Store => "abc" } ;
136 }
137
138 1;
139EOM
140
141like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
142 "croak if not a code reference";
143
144runFilter('bad5', <<'EOM');
145 package DBM_Filter::bad5 ;
146
147 sub Filter
148 {
149 return { } ;
150 }
151
152 1;
153EOM
154
155like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
156 "croak if neither fetch or store is present";
157
158runFilter('bad6', <<'EOM');
159 package DBM_Filter::bad6 ;
160
161 sub Filter
162 {
163 return { Store => sub {} } ;
164 }
165
166 1;
167EOM
168
169like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
170 "croak if store is present but fetch isn't";
171
172runFilter('bad7', <<'EOM');
173 package DBM_Filter::bad7 ;
174
175 sub Filter
176 {
177 return { Fetch => sub {} } ;
178 }
179
180 1;
181EOM
182
183like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
184 "croak if fetch is present but store isn't";
185
186runFilter('bad8', <<'EOM');
187 package DBM_Filter::bad8 ;
188
189 sub Filter {}
190 sub Store {}
191 sub Fetch {}
192
193 1;
194EOM
195
196like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
197 "croak if Fetch, Store and Filter";
198
199runFilter('bad9', <<'EOM');
200 package DBM_Filter::bad9 ;
201
202 sub Filter {}
203 sub Store {}
204
205 1;
206EOM
207
208like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
209 "croak if Store and Filter";
210
211runFilter('bad10', <<'EOM');
212 package DBM_Filter::bad10 ;
213
214 sub Filter {}
215 sub Fetch {}
216
217 1;
218EOM
219
220like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
221 "croak if Fetch and Filter";
222
223runFilter('bad11', <<'EOM');
224 package DBM_Filter::bad11 ;
225
226 sub Fetch {}
227
228 1;
229EOM
230
231like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
232 "croak if Fetch but no Store";
233
234runFilter('bad12', <<'EOM');
235 package DBM_Filter::bad12 ;
236
237 sub Store {}
238
239 1;
240EOM
241
242like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
243 "croak if Store but no Fetch";
244
245undef $db;
246{
247 use warnings FATAL => 'untie';
248 eval { untie %h1 };
249 is $@, '', "untie without inner references" ;
250}
251