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 |
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 | |