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