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
CommitLineData
0e9b1cbd
PM
1
2use strict;
3use warnings;
4use Carp;
5
6my %files = ();
7
8use lib '.';
9
10{
11 chdir 't' if -d 't';
12 if ( ! -d 'DBM_Filter')
13 {
14 mkdir 'DBM_Filter', 0777
9aedf6d8 15 or die "Cannot create directory 'DBM_Filter': $!\n" ;
0e9b1cbd
PM
16 }
17}
18
9aedf6d8 19END { rmdir 'DBM_Filter' }
0e9b1cbd
PM
20
21sub writeFile
22{
23 my $filename = shift ;
24 my $content = shift;
9aedf6d8 25 open F, ">DBM_Filter/$filename.pm" or croak "Cannot open $filename: $!" ;
0e9b1cbd
PM
26 print F $content ;
27 close F;
28 $files{"DBM_Filter/$filename.pm"} ++;
29}
30
31END { unlink keys %files if keys %files }
32
33use Test::More tests => 189;
34
35BEGIN { use_ok('DBM_Filter') };
36BEGIN { use_ok('SDBM_File') };
37BEGIN { use_ok('Fcntl') };
38
39unlink <Op_dbmx*>;
40END { unlink <Op_dbmx*>; }
41
42writeFile('times_ten', <<'EOM');
43 package DBM_Filter::times_ten;
44 sub Store { $_ *= 10 }
45 sub Fetch { $_ /= 10 }
46 1;
47EOM
48
49writeFile('append_A', <<'EOM');
50 package DBM_Filter::append_A;
51 sub Store { $_ .= 'A' }
52 sub Fetch { s/A$// }
53 1;
54EOM
55
56writeFile('append_B', <<'EOM');
57 package DBM_Filter::append_B;
58 sub Store { $_ .= 'B' }
59 sub Fetch { s/B$// }
60 1;
61EOM
62
63writeFile('append_C', <<'EOM');
64 package DBM_Filter::append_C;
65 sub Store { $_ .= 'C' }
66 sub Fetch { s/C$// }
67 1;
68EOM
69
70writeFile('append_D', <<'EOM');
71 package DBM_Filter::append_D;
72 sub Store { $_ .= 'D' }
73 sub Fetch { s/D$// }
74 1;
75EOM
76
77writeFile('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;
88EOM
89
90writeFile('double', <<'EOM');
91 package DBM_Filter::double;
92 sub Store { $_ *= 2 }
93 sub Fetch { $_ /= 2 }
94 1;
95EOM
96
97writeFile('uc', <<'EOM');
98 package DBM_Filter::uc;
99 sub Store { $_ = uc $_ }
100 sub Fetch { $_ = lc $_ }
101 1;
102EOM
103
104writeFile('reverse', <<'EOM');
105 package DBM_Filter::reverse;
106 sub Store { $_ = reverse $_ }
107 sub Fetch { $_ = reverse $_ }
108 1;
109EOM
110
111
112my %PreData = (
113 'abc' => 'def',
114 '123' => '456',
115 );
116
117my %PostData = (
118 'alpha' => 'beta',
119 'green' => 'blue',
120 );
121
122sub 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
133sub 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
147sub 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