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 15 or die "Cannot create directory 'DBM_Filter': $!\n" ; 16 } 17} 18 19END { rmdir 'DBM_Filter' } 20 21sub 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 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 721