Commit | Line | Data |
---|---|---|
0e9b1cbd PM |
1 | use strict; |
2 | use warnings; | |
3 | use Carp; | |
4 | ||
c3296b12 JH |
5 | BEGIN { |
6 | chdir 't' if -d 't'; | |
7 | @INC = qw(. ../lib); | |
8 | } | |
9 | ||
0e9b1cbd PM |
10 | our $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 |
21 | END { rmdir 'DBM_Filter' } |
22 | ||
0e9b1cbd PM |
23 | sub 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 | ||
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') }; | |
e8ebc68a JH |
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 | }; | |
0e9b1cbd PM |
62 | BEGIN { use_ok('Fcntl') }; |
63 | ||
64 | unlink <Op_dbmx*>; | |
65 | END { unlink <Op_dbmx*>; } | |
66 | ||
67 | my %h1 = () ; | |
68 | my %h2 = () ; | |
e8ebc68a | 69 | $db = tie(%h1, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
0e9b1cbd | 70 | |
e8ebc68a | 71 | ok $db, "tied to $db_file ok"; |
0e9b1cbd PM |
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 |