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