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