1use strict;
2use warnings;
3
4BEGIN {
5    chdir 't' if -d 't';
6    @INC = qw(. ../lib);
7}
8
9use Carp;
10use File::Temp qw(tempdir);
11
12my $tempdir;
13{
14    $tempdir = tempdir( "./DBMFXXXXXXXX", CLEANUP => 1);
15    push @INC, $tempdir;
16    chdir $tempdir or die "Failed to chdir to '$tempdir': $!";
17    @INC[-1] = "../../lib";
18    if ( ! -d 'DBM_Filter')
19    {
20        mkdir 'DBM_Filter', 0777 
21	    or die "Cannot create directory 'DBM_Filter': $!\n" ;
22    }
23}
24
25##### Keep above code identical to 02core.t #####
26
27our $db;
28
29sub writeFile
30{
31    my $filename = shift ;
32    my $content = shift;
33    open F, '>', $filename or croak "Cannot open $filename: $!" ;
34    print F $content ;
35    close F;
36}
37
38sub runFilter
39{
40    my $name = shift ;
41    my $filter = shift ;
42
43    #print "# runFilter $name\n" ;
44    my $filename = "DBM_Filter/$name.pm";
45    $filter = "package DBM_Filter::$name ;\n$filter"
46        unless $filter =~ /^\s*package/ ;
47
48    writeFile($filename, $filter);
49    eval { $db->Filter_Push($name) };
50    unlink $filename;
51    return $@;
52}
53
54use Test::More;
55
56BEGIN { use_ok('DBM_Filter') };
57my $db_file;
58BEGIN {
59    use Config;
60    foreach (qw/ODBM_File SDBM_File NDBM_File GDBM_File DB_File/) {
61        if ($Config{extensions} =~ /\b$_\b/) {
62            $db_file = $_;
63            last;
64        }
65    }
66    use_ok($db_file);
67};
68BEGIN { use_ok('Fcntl') };
69
70unlink <errOp_dbmx*>;
71END { unlink <errOp_dbmx*>; }
72
73my %h1 = () ;
74my %h2 = () ;
75$db = tie(%h1, $db_file,'errOp_dbmx', O_RDWR|O_CREAT, 0640) ;
76
77ok $db, "tied to $db_file ok";
78
79
80# Error cases
81
82eval { $db->Filter_Push() ; };
83like $@, qr/^Filter_Push: no parameters present/,
84        "croak if not parameters passed to Filter_Push";
85
86eval { $db->Filter_Push("unknown_class") ; };
87like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/, 
88        "croak on unknown class" ;
89
90eval { $db->Filter_Push("Some::unknown_class") ; };
91like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/, 
92        "croak on unknown fully qualified class" ;
93
94eval { $db->Filter_Push('Store') ; };
95like $@, qr/^Filter_Push: not even params/,
96        "croak if not passing even number or params to Filter_Push";
97
98runFilter('bad1', <<'EOM');
99    package DBM_Filter::bad1 ;
100    1;
101EOM
102
103like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
104        "croak if none of Filter/Fetch/Store in filter" ;
105
106
107runFilter('bad2', <<'EOM');
108    package DBM_Filter::bad2 ;
109
110    sub Filter
111    {
112        return 2;
113    }
114
115    1;
116EOM
117
118like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
119        "croak if Filter doesn't return hash reference" ;
120
121runFilter('bad3', <<'EOM');
122    package DBM_Filter::bad3 ;
123
124    sub Filter
125    {
126        return { BadKey => sub { } } ;
127
128    }
129
130    1;
131EOM
132
133like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
134        "croak if bad keyword returned from Filter";
135
136runFilter('bad4', <<'EOM');
137    package DBM_Filter::bad4 ;
138
139    sub Filter
140    {
141        return { Store => "abc" } ;
142    }
143
144    1;
145EOM
146
147like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
148        "croak if not a code reference";
149
150runFilter('bad5', <<'EOM');
151    package DBM_Filter::bad5 ;
152
153    sub Filter
154    {
155        return { } ;
156    }
157
158    1;
159EOM
160
161like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
162        "croak if neither fetch or store is present";
163
164runFilter('bad6', <<'EOM');
165    package DBM_Filter::bad6 ;
166
167    sub Filter
168    {
169        return { Store => sub {} } ;
170    }
171
172    1;
173EOM
174
175like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
176        "croak if store is present but fetch isn't";
177
178runFilter('bad7', <<'EOM');
179    package DBM_Filter::bad7 ;
180
181    sub Filter
182    {
183        return { Fetch => sub {} } ;
184    }
185
186    1;
187EOM
188
189like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
190        "croak if fetch is present but store isn't";
191
192runFilter('bad8', <<'EOM');
193    package DBM_Filter::bad8 ;
194
195    sub Filter {}
196    sub Store {}
197    sub Fetch {}
198
199    1;
200EOM
201
202like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
203        "croak if Fetch, Store and Filter";
204
205runFilter('bad9', <<'EOM');
206    package DBM_Filter::bad9 ;
207
208    sub Filter {}
209    sub Store {}
210
211    1;
212EOM
213
214like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
215        "croak if Store and Filter";
216
217runFilter('bad10', <<'EOM');
218    package DBM_Filter::bad10 ;
219
220    sub Filter {}
221    sub Fetch {}
222
223    1;
224EOM
225
226like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
227        "croak if Fetch and Filter";
228
229runFilter('bad11', <<'EOM');
230    package DBM_Filter::bad11 ;
231
232    sub Fetch {}
233
234    1;
235EOM
236
237like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
238        "croak if Fetch but no Store";
239
240runFilter('bad12', <<'EOM');
241    package DBM_Filter::bad12 ;
242
243    sub Store {}
244
245    1;
246EOM
247
248like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
249        "croak if Store but no Fetch";
250
251undef $db;
252{
253    use warnings FATAL => 'untie';
254    eval { untie %h1 };
255    is $@, '', "untie without inner references" ;
256}
257
258done_testing();
259