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