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