Commit | Line | Data |
0e9b1cbd |
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 |
9aedf6d8 |
14 | or die "Cannot create directory 'DBM_Filter': $!\n" ; |
0e9b1cbd |
15 | } |
16 | } |
17 | |
9aedf6d8 |
18 | END { rmdir 'DBM_Filter' } |
19 | |
0e9b1cbd |
20 | sub writeFile |
21 | { |
22 | my $filename = shift ; |
23 | my $content = shift; |
9aedf6d8 |
24 | open F, ">$filename" or croak "Cannot open $filename: $!" ; |
0e9b1cbd |
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') }; |
e8ebc68a |
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 | }; |
0e9b1cbd |
59 | BEGIN { use_ok('Fcntl') }; |
60 | |
61 | unlink <Op_dbmx*>; |
62 | END { unlink <Op_dbmx*>; } |
63 | |
64 | my %h1 = () ; |
65 | my %h2 = () ; |
e8ebc68a |
66 | $db = tie(%h1, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ; |
0e9b1cbd |
67 | |
e8ebc68a |
68 | ok $db, "tied to $db_file ok"; |
0e9b1cbd |
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 | |