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