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 01error.t #####
26
27our $db;
28my %files = ();
29
30sub writeFile
31{
32    my $filename = shift ;
33    my $content = shift;
34    open F, '>', "DBM_Filter/$filename.pm" or croak "Cannot open $filename: $!" ;
35    print F $content ;
36    close F;
37    $files{"DBM_Filter/$filename.pm"} ++;
38}
39
40use Test::More;
41
42BEGIN { use_ok('DBM_Filter') };
43my $db_file;
44BEGIN {
45    use Config;
46    foreach (qw/SDBM_File ODBM_File NDBM_File GDBM_File DB_File/) {
47        if ($Config{extensions} =~ /\b$_\b/) {
48            $db_file = $_;
49            last;
50        }
51    }
52    use_ok($db_file);
53};
54BEGIN { use_ok('Fcntl') };
55
56unlink <coreOp_dbmx*>;
57END { unlink <coreOp_dbmx*>; }
58
59writeFile('times_ten', <<'EOM');
60    package DBM_Filter::times_ten;
61    sub Store { $_ *= 10 }
62    sub Fetch { $_ /= 10 }
63    1;
64EOM
65
66writeFile('append_A', <<'EOM');
67    package DBM_Filter::append_A;
68    sub Store { $_ .= 'A' }
69    sub Fetch { s/A$//    }
70    1;
71EOM
72
73writeFile('append_B', <<'EOM');
74    package DBM_Filter::append_B;
75    sub Store { $_ .= 'B' }
76    sub Fetch { s/B$//    }
77    1;
78EOM
79
80writeFile('append_C', <<'EOM');
81    package DBM_Filter::append_C;
82    sub Store { $_ .= 'C' }
83    sub Fetch { s/C$//    }
84    1;
85EOM
86
87writeFile('append_D', <<'EOM');
88    package DBM_Filter::append_D;
89    sub Store { $_ .= 'D' }
90    sub Fetch { s/D$//    }
91    1;
92EOM
93
94writeFile('append', <<'EOM');
95    package DBM_Filter::append;
96    sub Filter
97    {
98         my $string = shift ;
99         return {
100                    Store => sub { $_ .= $string   },
101                    Fetch => sub { s/${string}$//  }
102                }
103    }
104    1;
105EOM
106
107writeFile('double', <<'EOM');
108    package DBM_Filter::double;
109    sub Store { $_ *= 2 }
110    sub Fetch { $_ /= 2 }
111    1;
112EOM
113
114writeFile('uc', <<'EOM');
115    package DBM_Filter::uc;
116    sub Store { $_ = uc $_ }
117    sub Fetch { $_ = lc $_ }
118    1;
119EOM
120
121writeFile('reverse', <<'EOM');
122    package DBM_Filter::reverse;
123    sub Store { $_ = reverse $_ }
124    sub Fetch { $_ = reverse $_ }
125    1;
126EOM
127
128
129my %PreData = (
130	'abc'	=> 'def',
131	'123'	=> '456',
132	);
133
134my %PostData = (
135	'alpha'	=> 'beta',
136	'green'	=> 'blue',
137	);
138
139sub doPreData
140{
141    my $h = shift ;
142
143    $$h{"abc"} = "def";
144    $$h{"123"} = "456";
145    ok $$h{"abc"} eq "def", "read eq written" ;
146    ok $$h{"123"} eq "456", "read eq written" ;
147
148}
149
150sub doPostData
151{
152    my $h = shift ;
153
154    no warnings 'uninitialized';
155    $$h{undef()} = undef();
156    $$h{"alpha"} = "beta";
157    $$h{"green"} = "blue";
158    ok $$h{""} eq "", "read eq written" ;
159    ok $$h{"green"} eq "blue", "read eq written" ;
160    ok $$h{"green"} eq "blue", "read eq written" ;
161
162}
163
164sub checkRaw
165{
166    my $filename = shift ;
167    my %expected = @_ ;
168    my %h;
169
170    # read the dbm file without the filter
171    ok tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640), "tied to $db_file";
172
173    my %bad = ();
174    while (my ($k, $v) = each %h) {
175        if ( defined $expected{$k} &&  $expected{$k} eq $v ) {
176            delete $expected{$k} ;
177        }
178        else
179          { $bad{$k} = $v }
180    }
181
182    ok keys(%expected) + keys(%bad) == 0, "Raw hash is ok"; 
183
184    if ( keys(%expected) + keys(%bad) ) {
185        my $bad = "Expected does not match actual\nExpected:\n" ;
186        while (my ($k, $v) = each %expected) {
187            $bad .= "\t'$k' =>\t'$v'\n";
188        }
189        $bad .= "\nGot:\n" ;
190        while (my ($k, $v) = each %bad) {
191            $bad .= "\t'$k' =>\t'$v'\n";
192        }
193        diag $bad ;
194    }
195    
196    {
197        use warnings FATAL => 'untie';
198        eval { untie %h };
199        is $@, '', "untie without inner references" ;
200    }
201    unlink <coreOp_dbmx*>;
202}
203
204{
205    #diag "Test Set: Key and Value Filter, no stacking, no closure";
206
207    my %h = () ;
208    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
209    ok $db, "tied to $db_file";
210    
211    doPreData(\%h);
212
213    eval { $db->Filter_Push('append_A') };
214    is $@, '', "push 'append_A' filter" ;
215    
216    doPostData(\%h);
217    
218    undef $db;
219    {
220        use warnings FATAL => 'untie';
221        eval { untie %h };
222        is $@, '', "untie without inner references" ;
223    }
224
225    checkRaw 'coreOp_dbmx',
226	    'abc'	=> 'def',
227	    '123'	=> '456',
228	    'A'	=> 'A',
229	    'alphaA'	=> 'betaA',
230	    'greenA'	=> 'blueA';
231
232}
233
234{
235    #diag "Test Set: Key Only Filter, no stacking, no closure";
236
237    my %h = () ;
238    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
239    ok $db, "tied to $db_file";
240    
241    doPreData(\%h);
242
243    eval { $db->Filter_Key_Push('append_A') };
244    is $@, '', "push 'append_A' filter" ;
245    
246    doPostData(\%h);
247    
248    undef $db;
249    {
250        use warnings FATAL => 'untie';
251        eval { untie %h };
252        is $@, '', "untie without inner references" ;
253    }
254
255    checkRaw 'coreOp_dbmx',
256	    'abc'	=> 'def',
257	    '123'	=> '456',
258	    'A'	=> '',
259	    'alphaA'	=> 'beta',
260	    'greenA'	=> 'blue';
261
262}
263
264{
265    #diag "Test Set: Value Only Filter, no stacking, no closure";
266
267    my %h = () ;
268    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
269    ok $db, "tied to $db_file";
270    
271    doPreData(\%h);
272
273    eval { $db->Filter_Value_Push('append_A') };
274    is $@, '', "push 'append_A' filter" ;
275    
276    doPostData(\%h);
277    
278    undef $db;
279    {
280        use warnings FATAL => 'untie';
281        eval { untie %h };
282        is $@, '', "untie without inner references" ;
283    }
284
285    checkRaw 'coreOp_dbmx',
286	    'abc'	=> 'def',
287	    '123'	=> '456',
288	    ''	=> 'A',
289	    'alpha'	=> 'betaA',
290	    'green'	=> 'blueA';
291
292}
293
294{
295    #diag "Test Set: Key and Value Filter, with stacking, no closure";
296
297    my %h = () ;
298    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
299    ok $db, "tied to $db_file";
300    
301    doPreData(\%h);
302
303    eval { $db->Filter_Push('append_A') };
304    is $@, '', "push 'append_A' filter" ;
305    
306    eval { $db->Filter_Push('append_B') };
307    is $@, '', "push 'append_B' filter" ;
308    
309    doPostData(\%h);
310    
311    undef $db;
312    {
313        use warnings FATAL => 'untie';
314        eval { untie %h };
315        is $@, '', "untie without inner references" ;
316    }
317
318    checkRaw 'coreOp_dbmx',
319	    'abc'	=> 'def',
320	    '123'	=> '456',
321	    'AB'	=> 'AB',
322	    'alphaAB'	=> 'betaAB',
323	    'greenAB'	=> 'blueAB';
324
325}
326
327{
328    #diag "Test Set: Key Filter != Value Filter, with stacking, no closure";
329
330    my %h = () ;
331    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
332    ok $db, "tied to $db_file";
333    
334    doPreData(\%h);
335
336    eval { $db->Filter_Value_Push('append_A') };
337    is $@, '', "push 'append_A' filter" ;
338    
339    eval { $db->Filter_Key_Push('append_B') };
340    is $@, '', "push 'append_B' filter" ;
341    
342    eval { $db->Filter_Value_Push('append_C') };
343    is $@, '', "push 'append_C' filter" ;
344    
345    eval { $db->Filter_Key_Push('append_D') };
346    is $@, '', "push 'append_D' filter" ;
347    
348    doPostData(\%h);
349    
350    undef $db;
351    {
352        use warnings FATAL => 'untie';
353        eval { untie %h };
354        is $@, '', "untie without inner references" ;
355    }
356
357    checkRaw 'coreOp_dbmx',
358	    'abc'	=> 'def',
359	    '123'	=> '456',
360	    'BD'	=> 'AC',
361	    'alphaBD'	=> 'betaAC',
362	    'greenBD'	=> 'blueAC';
363
364}
365
366{
367    #diag "Test Set: Key only Filter, with stacking, no closure";
368
369    my %h = () ;
370    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
371    ok $db, "tied to $db_file";
372    
373    doPreData(\%h);
374
375    eval { $db->Filter_Key_Push('append_B') };
376    is $@, '', "push 'append_B' filter" ;
377    
378    eval { $db->Filter_Key_Push('append_D') };
379    is $@, '', "push 'append_D' filter" ;
380    
381    doPostData(\%h);
382    
383    undef $db;
384    {
385        use warnings FATAL => 'untie';
386        eval { untie %h };
387        is $@, '', "untie without inner references" ;
388    }
389
390    checkRaw 'coreOp_dbmx',
391	    'abc'	=> 'def',
392	    '123'	=> '456',
393	    'BD'	=> '',
394	    'alphaBD'	=> 'beta',
395	    'greenBD'	=> 'blue';
396
397}
398
399{
400    #diag "Test Set: Value only Filter, with stacking, no closure";
401
402    my %h = () ;
403    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
404    ok $db, "tied to $db_file";
405    
406    doPreData(\%h);
407
408    eval { $db->Filter_Value_Push('append_A') };
409    is $@, '', "push 'append_A' filter" ;
410    
411    eval { $db->Filter_Value_Push('append_C') };
412    is $@, '', "push 'append_C' filter" ;
413    
414    doPostData(\%h);
415    
416    undef $db;
417    {
418        use warnings FATAL => 'untie';
419        eval { untie %h };
420        is $@, '', "untie without inner references" ;
421    }
422
423    checkRaw 'coreOp_dbmx',
424	    'abc'	=> 'def',
425	    '123'	=> '456',
426	    ''	=> 'AC',
427	    'alpha'	=> 'betaAC',
428	    'green'	=> 'blueAC';
429
430}
431
432{
433    #diag "Test Set: Combination Key/Value + Key Filter != Value Filter, with stacking, no closure";
434
435    my %h = () ;
436    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
437    ok $db, "tied to $db_file";
438    
439    doPreData(\%h);
440
441    eval { $db->Filter_Push('append_A') };
442    is $@, '', "push 'append_A' filter" ;
443    
444    eval { $db->Filter_Value_Push('append_C') };
445    is $@, '', "push 'append_C' filter" ;
446    
447    eval { $db->Filter_Key_Push('append_D') };
448    is $@, '', "push 'append_D' filter" ;
449    
450    doPostData(\%h);
451    
452    undef $db;
453    {
454        use warnings FATAL => 'untie';
455        eval { untie %h };
456        is $@, '', "untie without inner references" ;
457    }
458
459    checkRaw 'coreOp_dbmx',
460	    'abc'	=> 'def',
461	    '123'	=> '456',
462	    'AD'	=> 'AC',
463	    'alphaAD'	=> 'betaAC',
464	    'greenAD'	=> 'blueAC';
465
466}
467
468{
469    #diag "Test Set: Combination Key/Value + Key + Key/Value, no closure";
470
471    my %h = () ;
472    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
473    ok $db, "tied to $db_file";
474    
475    doPreData(\%h);
476
477    eval { $db->Filter_Push('append_A') };
478    is $@, '', "push 'append_A' filter" ;
479    
480    eval { $db->Filter_Key_Push('append_B') };
481    is $@, '', "push 'append_B' filter" ;
482    
483    eval { $db->Filter_Push('append_C') };
484    is $@, '', "push 'append_C' filter" ;
485    
486    doPostData(\%h);
487    
488    undef $db;
489    {
490        use warnings FATAL => 'untie';
491        eval { untie %h };
492        is $@, '', "untie without inner references" ;
493    }
494
495    checkRaw 'coreOp_dbmx',
496	    'abc'	=> 'def',
497	    '123'	=> '456',
498	    'ABC'	=> 'AC',
499	    'alphaABC'	=> 'betaAC',
500	    'greenABC'	=> 'blueAC';
501
502}
503
504{
505    #diag "Test Set: Combination Key/Value + Key + Key/Value, with closure";
506
507    my %h = () ;
508    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
509    ok $db, "tied to $db_file";
510    
511    doPreData(\%h);
512
513    eval { $db->Filter_Push('append' => 'A') };
514    is $@, '', "push 'append_A' filter" ;
515    
516    eval { $db->Filter_Key_Push('append' => 'B') };
517    is $@, '', "push 'append_B' filter" ;
518    
519    eval { $db->Filter_Push('append' => 'C') };
520    is $@, '', "push 'append_C' filter" ;
521    
522    doPostData(\%h);
523    
524    undef $db;
525    {
526        use warnings FATAL => 'untie';
527        eval { untie %h };
528        is $@, '', "untie without inner references" ;
529    }
530
531    checkRaw 'coreOp_dbmx',
532	    'abc'	=> 'def',
533	    '123'	=> '456',
534	    'ABC'	=> 'AC',
535	    'alphaABC'	=> 'betaAC',
536	    'greenABC'	=> 'blueAC';
537
538}
539
540{
541    #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate";
542
543    my %h = () ;
544    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
545    ok $db, "tied to $db_file";
546    
547    doPreData(\%h);
548
549    eval { 
550        $db->Filter_Push(
551                Store => sub { $_ .= 'A' },
552                Fetch => sub { s/A$//    }) };
553    is $@, '', "push 'append_A' filter" ;
554    
555    eval { 
556        $db->Filter_Key_Push(
557                Store => sub { $_ .= 'B' },
558                Fetch => sub { s/B$//    }) };
559    is $@, '', "push 'append_B' filter" ;
560    
561    eval { 
562        $db->Filter_Push(
563                Store => sub { $_ .= 'C' },
564                Fetch => sub { s/C$//    }) };
565    is $@, '', "push 'append_C' filter" ;
566    
567    doPostData(\%h);
568    
569    undef $db;
570    {
571        use warnings FATAL => 'untie';
572        eval { untie %h };
573        is $@, '', "untie without inner references" ;
574    }
575
576    checkRaw 'coreOp_dbmx',
577	    'abc'	=> 'def',
578	    '123'	=> '456',
579	    'ABC'	=> 'AC',
580	    'alphaABC'	=> 'betaAC',
581	    'greenABC'	=> 'blueAC';
582
583}
584
585{
586    #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate, closure";
587
588    my %h = () ;
589    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
590    ok $db, "tied to $db_file";
591    
592    doPreData(\%h);
593
594    eval { 
595        $db->Filter_Push(
596                Store => sub { $_ .= 'A' },
597                Fetch => sub { s/A$//    }) };
598    is $@, '', "push 'append_A' filter" ;
599    
600    eval { $db->Filter_Key_Push('append_B') };
601    is $@, '', "push 'append_B' filter" ;
602    
603    eval { $db->Filter_Push('append' => 'C') };
604    is $@, '', "push 'append_C' filter" ;
605    
606    doPostData(\%h);
607    
608    undef $db;
609    {
610        use warnings FATAL => 'untie';
611        eval { untie %h };
612        is $@, '', "untie without inner references" ;
613    }
614
615    checkRaw 'coreOp_dbmx',
616	    'abc'	=> 'def',
617	    '123'	=> '456',
618	    'ABC'	=> 'AC',
619	    'alphaABC'	=> 'betaAC',
620	    'greenABC'	=> 'blueAC';
621
622}
623
624{
625    #diag "Test Set: Filtered & Filter_Pop";
626
627    my %h = () ;
628    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
629    ok $db, "tied to $db_file";
630    
631    doPreData(\%h);
632
633    ok ! $db->Filtered, "not filtered" ;
634
635    eval { 
636        $db->Filter_Push(
637                Store => sub { $_ .= 'A' },
638                Fetch => sub { s/A$//    }) };
639    is $@, '', "push 'append_A' filter" ;
640    
641    ok $db->Filtered, "is filtered" ;
642
643    eval { $db->Filter_Key_Push('append_B') };
644    is $@, '', "push 'append_B' filter" ;
645    
646    ok $db->Filtered, "is filtered" ;
647    
648    eval { $db->Filter_Push('append' => 'C') };
649    is $@, '', "push 'append_C' filter" ;
650    
651    ok $db->Filtered, "is filtered" ;
652    
653    doPostData(\%h);
654    
655    eval { $db->Filter_Pop() };
656    is $@, '', "Filter_Pop";
657    
658    ok $db->Filtered, "is filtered" ;
659
660    $h{'after'} = 'noon';
661    is $h{'after'}, 'noon', "read eq written";
662
663    eval { $db->Filter_Pop() };
664    is $@, '', "Filter_Pop";
665    
666    ok $db->Filtered, "is filtered" ;
667
668    $h{'morning'} = 'after';
669    is $h{'morning'}, 'after', "read eq written";
670
671    eval { $db->Filter_Pop() };
672    is $@, '', "Filter_Pop";
673    
674    ok ! $db->Filtered, "not filtered" ;
675
676    $h{'and'} = 'finally';
677    is $h{'and'}, 'finally', "read eq written";
678
679    eval { $db->Filter_Pop() };
680    is $@, '', "Filter_Pop";
681    
682    undef $db;
683    {
684        use warnings FATAL => 'untie';
685        eval { untie %h };
686        is $@, '', "untie without inner references" ;
687    }
688
689    checkRaw 'coreOp_dbmx',
690	    'abc'	=> 'def',
691	    '123'	=> '456',
692	    'ABC'	=> 'AC',
693	    'alphaABC'	=> 'betaAC',
694	    'greenABC'	=> 'blueAC',
695	    'afterAB'	=> 'noonA',
696	    'morningA'	=> 'afterA',
697	    'and'	=> 'finally';
698
699}
700
701{
702    #diag "Test Set: define the filter package in-line";
703
704    {
705        package DBM_Filter::append_X;
706
707        sub Store { $_ .= 'X' }
708        sub Fetch { s/X$//    }
709    }
710    
711    my %h = () ;
712    my $db = tie(%h, $db_file,'coreOp_dbmx', O_RDWR|O_CREAT, 0640) ;
713    ok $db, "tied to $db_file";
714    
715    doPreData(\%h);
716
717    eval { $db->Filter_Push('append_X') };
718    is $@, '', "push 'append_X' filter" ;
719    
720    doPostData(\%h);
721    
722    undef $db;
723    {
724        use warnings FATAL => 'untie';
725        eval { untie %h };
726        is $@, '', "untie without inner references" ;
727    }
728
729    checkRaw 'coreOp_dbmx',
730	    'abc'	=> 'def',
731	    '123'	=> '456',
732	    'X'  	=> 'X',
733	    'alphaX'	=> 'betaX',
734	    'greenX'	=> 'blueX';
735
736}
737
738done_testing();
739