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