11 if ( ! -d 'DBM_Filter')
13 mkdir 'DBM_Filter', 0777
14 or die "Cannot create directory 'DBM_Filter': $!\n" ;
18 END { rmdir 'DBM_Filter' }
22 my $filename = shift ;
24 open F, ">$filename" or croak "Cannot open $filename: $!" ;
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/ ;
39 writeFile($filename, $filter);
40 eval { $db->Filter_Push($name) };
45 use Test::More tests => 21;
47 BEGIN { use_ok('DBM_Filter') };
48 BEGIN { use_ok('SDBM_File') };
49 BEGIN { use_ok('Fcntl') };
52 END { unlink <Op_dbmx*>; }
56 $db = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
58 ok $db, "tied to SDBM_File ok";
63 eval { $db->Filter_Push() ; };
64 like $@, qr/^Filter_Push: no parameters present/,
65 "croak if not parameters passed to Filter_Push";
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" ;
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" ;
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";
79 runFilter('bad1', <<'EOM');
80 package DBM_Filter::bad1 ;
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" ;
88 runFilter('bad2', <<'EOM');
89 package DBM_Filter::bad2 ;
99 like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
100 "croak if Filter doesn't return hash reference" ;
102 runFilter('bad3', <<'EOM');
103 package DBM_Filter::bad3 ;
107 return { BadKey => sub { } } ;
114 like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
115 "croak if bad keyword returned from Filter";
117 runFilter('bad4', <<'EOM');
118 package DBM_Filter::bad4 ;
122 return { Store => "abc" } ;
128 like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
129 "croak if not a code reference";
131 runFilter('bad5', <<'EOM');
132 package DBM_Filter::bad5 ;
142 like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
143 "croak if neither fetch or store is present";
145 runFilter('bad6', <<'EOM');
146 package DBM_Filter::bad6 ;
150 return { Store => sub {} } ;
156 like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
157 "croak if store is present but fetch isn't";
159 runFilter('bad7', <<'EOM');
160 package DBM_Filter::bad7 ;
164 return { Fetch => sub {} } ;
170 like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
171 "croak if fetch is present but store isn't";
173 runFilter('bad8', <<'EOM');
174 package DBM_Filter::bad8 ;
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";
186 runFilter('bad9', <<'EOM');
187 package DBM_Filter::bad9 ;
195 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
196 "croak if Store and Filter";
198 runFilter('bad10', <<'EOM');
199 package DBM_Filter::bad10 ;
207 like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
208 "croak if Fetch and Filter";
210 runFilter('bad11', <<'EOM');
211 package DBM_Filter::bad11 ;
218 like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
219 "croak if Fetch but no Store";
221 runFilter('bad12', <<'EOM');
222 package DBM_Filter::bad12 ;
229 like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
230 "croak if Store but no Fetch";
234 use warnings FATAL => 'untie';
236 is $@, '', "untie without inner references" ;