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