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