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