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 my $db_file;
  37 BEGIN {
  38     use Config;
  39     foreach (qw/SDBM_File ODBM_File NDBM_File GDBM_File DB_File/) {
  40         if ($Config{extensions} =~ /\b$_\b/) {
  41             $db_file = $_;
  42             last;
  43         }
  44     }
  45     use_ok($db_file);
  46 };
  47 BEGIN { use_ok('Fcntl') };
  48
  49 unlink <Op_dbmx*>;
  50 END { unlink <Op_dbmx*>; }
  51
  52 writeFile('times_ten', <<'EOM');
  53     package DBM_Filter::times_ten;
  54     sub Store { $_ *= 10 }
  55     sub Fetch { $_ /= 10 }
  56     1;
  57 EOM
  58
  59 writeFile('append_A', <<'EOM');
  60     package DBM_Filter::append_A;
  61     sub Store { $_ .= 'A' }
  62     sub Fetch { s/A$//    }
  63     1;
  64 EOM
  65
  66 writeFile('append_B', <<'EOM');
  67     package DBM_Filter::append_B;
  68     sub Store { $_ .= 'B' }
  69     sub Fetch { s/B$//    }
  70     1;
  71 EOM
  72
  73 writeFile('append_C', <<'EOM');
  74     package DBM_Filter::append_C;
  75     sub Store { $_ .= 'C' }
  76     sub Fetch { s/C$//    }
  77     1;
  78 EOM
  79
  80 writeFile('append_D', <<'EOM');
  81     package DBM_Filter::append_D;
  82     sub Store { $_ .= 'D' }
  83     sub Fetch { s/D$//    }
  84     1;
  85 EOM
  86
  87 writeFile('append', <<'EOM');
  88     package DBM_Filter::append;
  89     sub Filter
  90     {
  91          my $string = shift ;
  92          return {
  93                     Store => sub { $_ .= $string   },
  94                     Fetch => sub { s/${string}$//  }
  95                 }
  96     }
  97     1;
  98 EOM
  99
 100 writeFile('double', <<'EOM');
 101     package DBM_Filter::double;
 102     sub Store { $_ *= 2 }
 103     sub Fetch { $_ /= 2 }
 104     1;
 105 EOM
 106
 107 writeFile('uc', <<'EOM');
 108     package DBM_Filter::uc;
 109     sub Store { $_ = uc $_ }
 110     sub Fetch { $_ = lc $_ }
 111     1;
 112 EOM
 113
 114 writeFile('reverse', <<'EOM');
 115     package DBM_Filter::reverse;
 116     sub Store { $_ = reverse $_ }
 117     sub Fetch { $_ = reverse $_ }
 118     1;
 119 EOM
 120
 121
 122 my %PreData = (
 123         'abc'   => 'def',
 124         '123'   => '456',
 125         );
 126
 127 my %PostData = (
 128         'alpha' => 'beta',
 129         'green' => 'blue',
 130         );
 131
 132 sub doPreData
 133 {
 134     my $h = shift ;
 135
 136     $$h{"abc"} = "def";
 137     $$h{"123"} = "456";
 138     ok $$h{"abc"} eq "def", "read eq written" ;
 139     ok $$h{"123"} eq "456", "read eq written" ;
 140
 141 }
 142
 143 sub doPostData
 144 {
 145     my $h = shift ;
 146
 147     no warnings 'uninitialized';
 148     $$h{undef()} = undef();
 149     $$h{"alpha"} = "beta";
 150     $$h{"green"} = "blue";
 151     ok $$h{""} eq "", "read eq written" ;
 152     ok $$h{"green"} eq "blue", "read eq written" ;
 153     ok $$h{"green"} eq "blue", "read eq written" ;
 154
 155 }
 156
 157 sub checkRaw
 158 {
 159     my $filename = shift ;
 160     my %expected = @_ ;
 161     my %h;
 162
 163     # read the dbm file without the filter
 164     ok tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640), "tied to $db_file";
 165
 166     my %bad = ();
 167     while (my ($k, $v) = each %h) {
 168         if ( defined $expected{$k} &&  $expected{$k} eq $v ) {
 169             delete $expected{$k} ;
 170         }
 171         else
 172           { $bad{$k} = $v }
 173     }
 174
 175     ok keys(%expected) + keys(%bad) == 0, "Raw hash is ok";
 176
 177     if ( keys(%expected) + keys(%bad) ) {
 178         my $bad = "Expected does not match actual\nExpected:\n" ;
 179         while (my ($k, $v) = each %expected) {
 180             $bad .= "\t'$k' =>\t'$v'\n";
 181         }
 182         $bad .= "\nGot:\n" ;
 183         while (my ($k, $v) = each %bad) {
 184             $bad .= "\t'$k' =>\t'$v'\n";
 185         }
 186         diag $bad ;
 187     }
 188
 189     {
 190         use warnings FATAL => 'untie';
 191         eval { untie %h };
 192         is $@, '', "untie without inner references" ;
 193     }
 194     unlink <Op_dbmx*>;
 195 }
 196
 197 {
 198     #diag "Test Set: Key and Value Filter, no stacking, no closure";
 199
 200     my %h = () ;
 201     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 202     ok $db, "tied to $db_file";
 203
 204     doPreData(\%h);
 205
 206     eval { $db->Filter_Push('append_A') };
 207     is $@, '', "push 'append_A' filter" ;
 208
 209     doPostData(\%h);
 210
 211     undef $db;
 212     {
 213         use warnings FATAL => 'untie';
 214         eval { untie %h };
 215         is $@, '', "untie without inner references" ;
 216     }
 217
 218     checkRaw 'Op_dbmx',
 219             'abc'       => 'def',
 220             '123'       => '456',
 221             'A' => 'A',
 222             'alphaA'    => 'betaA',
 223             'greenA'    => 'blueA';
 224
 225 }
 226
 227 {
 228     #diag "Test Set: Key Only Filter, no stacking, no closure";
 229
 230     my %h = () ;
 231     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 232     ok $db, "tied to $db_file";
 233
 234     doPreData(\%h);
 235
 236     eval { $db->Filter_Key_Push('append_A') };
 237     is $@, '', "push 'append_A' filter" ;
 238
 239     doPostData(\%h);
 240
 241     undef $db;
 242     {
 243         use warnings FATAL => 'untie';
 244         eval { untie %h };
 245         is $@, '', "untie without inner references" ;
 246     }
 247
 248     checkRaw 'Op_dbmx',
 249             'abc'       => 'def',
 250             '123'       => '456',
 251             'A' => '',
 252             'alphaA'    => 'beta',
 253             'greenA'    => 'blue';
 254
 255 }
 256
 257 {
 258     #diag "Test Set: Value Only Filter, no stacking, no closure";
 259
 260     my %h = () ;
 261     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 262     ok $db, "tied to $db_file";
 263
 264     doPreData(\%h);
 265
 266     eval { $db->Filter_Value_Push('append_A') };
 267     is $@, '', "push 'append_A' filter" ;
 268
 269     doPostData(\%h);
 270
 271     undef $db;
 272     {
 273         use warnings FATAL => 'untie';
 274         eval { untie %h };
 275         is $@, '', "untie without inner references" ;
 276     }
 277
 278     checkRaw 'Op_dbmx',
 279             'abc'       => 'def',
 280             '123'       => '456',
 281             ''  => 'A',
 282             'alpha'     => 'betaA',
 283             'green'     => 'blueA';
 284
 285 }
 286
 287 {
 288     #diag "Test Set: Key and Value Filter, with stacking, no closure";
 289
 290     my %h = () ;
 291     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 292     ok $db, "tied to $db_file";
 293
 294     doPreData(\%h);
 295
 296     eval { $db->Filter_Push('append_A') };
 297     is $@, '', "push 'append_A' filter" ;
 298
 299     eval { $db->Filter_Push('append_B') };
 300     is $@, '', "push 'append_B' filter" ;
 301
 302     doPostData(\%h);
 303
 304     undef $db;
 305     {
 306         use warnings FATAL => 'untie';
 307         eval { untie %h };
 308         is $@, '', "untie without inner references" ;
 309     }
 310
 311     checkRaw 'Op_dbmx',
 312             'abc'       => 'def',
 313             '123'       => '456',
 314             'AB'        => 'AB',
 315             'alphaAB'   => 'betaAB',
 316             'greenAB'   => 'blueAB';
 317
 318 }
 319
 320 {
 321     #diag "Test Set: Key Filter != Value Filter, with stacking, no closure";
 322
 323     my %h = () ;
 324     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 325     ok $db, "tied to $db_file";
 326
 327     doPreData(\%h);
 328
 329     eval { $db->Filter_Value_Push('append_A') };
 330     is $@, '', "push 'append_A' filter" ;
 331
 332     eval { $db->Filter_Key_Push('append_B') };
 333     is $@, '', "push 'append_B' filter" ;
 334
 335     eval { $db->Filter_Value_Push('append_C') };
 336     is $@, '', "push 'append_C' filter" ;
 337
 338     eval { $db->Filter_Key_Push('append_D') };
 339     is $@, '', "push 'append_D' filter" ;
 340
 341     doPostData(\%h);
 342
 343     undef $db;
 344     {
 345         use warnings FATAL => 'untie';
 346         eval { untie %h };
 347         is $@, '', "untie without inner references" ;
 348     }
 349
 350     checkRaw 'Op_dbmx',
 351             'abc'       => 'def',
 352             '123'       => '456',
 353             'BD'        => 'AC',
 354             'alphaBD'   => 'betaAC',
 355             'greenBD'   => 'blueAC';
 356
 357 }
 358
 359 {
 360     #diag "Test Set: Key only Filter, with stacking, no closure";
 361
 362     my %h = () ;
 363     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 364     ok $db, "tied to $db_file";
 365
 366     doPreData(\%h);
 367
 368     eval { $db->Filter_Key_Push('append_B') };
 369     is $@, '', "push 'append_B' filter" ;
 370
 371     eval { $db->Filter_Key_Push('append_D') };
 372     is $@, '', "push 'append_D' filter" ;
 373
 374     doPostData(\%h);
 375
 376     undef $db;
 377     {
 378         use warnings FATAL => 'untie';
 379         eval { untie %h };
 380         is $@, '', "untie without inner references" ;
 381     }
 382
 383     checkRaw 'Op_dbmx',
 384             'abc'       => 'def',
 385             '123'       => '456',
 386             'BD'        => '',
 387             'alphaBD'   => 'beta',
 388             'greenBD'   => 'blue';
 389
 390 }
 391
 392 {
 393     #diag "Test Set: Value only Filter, with stacking, no closure";
 394
 395     my %h = () ;
 396     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 397     ok $db, "tied to $db_file";
 398
 399     doPreData(\%h);
 400
 401     eval { $db->Filter_Value_Push('append_A') };
 402     is $@, '', "push 'append_A' filter" ;
 403
 404     eval { $db->Filter_Value_Push('append_C') };
 405     is $@, '', "push 'append_C' filter" ;
 406
 407     doPostData(\%h);
 408
 409     undef $db;
 410     {
 411         use warnings FATAL => 'untie';
 412         eval { untie %h };
 413         is $@, '', "untie without inner references" ;
 414     }
 415
 416     checkRaw 'Op_dbmx',
 417             'abc'       => 'def',
 418             '123'       => '456',
 419             ''  => 'AC',
 420             'alpha'     => 'betaAC',
 421             'green'     => 'blueAC';
 422
 423 }
 424
 425 {
 426     #diag "Test Set: Combination Key/Value + Key Filter != Value Filter, with stacking, no closure";
 427
 428     my %h = () ;
 429     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 430     ok $db, "tied to $db_file";
 431
 432     doPreData(\%h);
 433
 434     eval { $db->Filter_Push('append_A') };
 435     is $@, '', "push 'append_A' filter" ;
 436
 437     eval { $db->Filter_Value_Push('append_C') };
 438     is $@, '', "push 'append_C' filter" ;
 439
 440     eval { $db->Filter_Key_Push('append_D') };
 441     is $@, '', "push 'append_D' filter" ;
 442
 443     doPostData(\%h);
 444
 445     undef $db;
 446     {
 447         use warnings FATAL => 'untie';
 448         eval { untie %h };
 449         is $@, '', "untie without inner references" ;
 450     }
 451
 452     checkRaw 'Op_dbmx',
 453             'abc'       => 'def',
 454             '123'       => '456',
 455             'AD'        => 'AC',
 456             'alphaAD'   => 'betaAC',
 457             'greenAD'   => 'blueAC';
 458
 459 }
 460
 461 {
 462     #diag "Test Set: Combination Key/Value + Key + Key/Value, no closure";
 463
 464     my %h = () ;
 465     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 466     ok $db, "tied to $db_file";
 467
 468     doPreData(\%h);
 469
 470     eval { $db->Filter_Push('append_A') };
 471     is $@, '', "push 'append_A' filter" ;
 472
 473     eval { $db->Filter_Key_Push('append_B') };
 474     is $@, '', "push 'append_B' filter" ;
 475
 476     eval { $db->Filter_Push('append_C') };
 477     is $@, '', "push 'append_C' filter" ;
 478
 479     doPostData(\%h);
 480
 481     undef $db;
 482     {
 483         use warnings FATAL => 'untie';
 484         eval { untie %h };
 485         is $@, '', "untie without inner references" ;
 486     }
 487
 488     checkRaw 'Op_dbmx',
 489             'abc'       => 'def',
 490             '123'       => '456',
 491             'ABC'       => 'AC',
 492             'alphaABC'  => 'betaAC',
 493             'greenABC'  => 'blueAC';
 494
 495 }
 496
 497 {
 498     #diag "Test Set: Combination Key/Value + Key + Key/Value, with closure";
 499
 500     my %h = () ;
 501     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 502     ok $db, "tied to $db_file";
 503
 504     doPreData(\%h);
 505
 506     eval { $db->Filter_Push('append' => 'A') };
 507     is $@, '', "push 'append_A' filter" ;
 508
 509     eval { $db->Filter_Key_Push('append' => 'B') };
 510     is $@, '', "push 'append_B' filter" ;
 511
 512     eval { $db->Filter_Push('append' => 'C') };
 513     is $@, '', "push 'append_C' filter" ;
 514
 515     doPostData(\%h);
 516
 517     undef $db;
 518     {
 519         use warnings FATAL => 'untie';
 520         eval { untie %h };
 521         is $@, '', "untie without inner references" ;
 522     }
 523
 524     checkRaw 'Op_dbmx',
 525             'abc'       => 'def',
 526             '123'       => '456',
 527             'ABC'       => 'AC',
 528             'alphaABC'  => 'betaAC',
 529             'greenABC'  => 'blueAC';
 530
 531 }
 532
 533 {
 534     #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate";
 535
 536     my %h = () ;
 537     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 538     ok $db, "tied to $db_file";
 539
 540     doPreData(\%h);
 541
 542     eval {
 543         $db->Filter_Push(
 544                 Store => sub { $_ .= 'A' },
 545                 Fetch => sub { s/A$//    }) };
 546     is $@, '', "push 'append_A' filter" ;
 547
 548     eval {
 549         $db->Filter_Key_Push(
 550                 Store => sub { $_ .= 'B' },
 551                 Fetch => sub { s/B$//    }) };
 552     is $@, '', "push 'append_B' filter" ;
 553
 554     eval {
 555         $db->Filter_Push(
 556                 Store => sub { $_ .= 'C' },
 557                 Fetch => sub { s/C$//    }) };
 558     is $@, '', "push 'append_C' filter" ;
 559
 560     doPostData(\%h);
 561
 562     undef $db;
 563     {
 564         use warnings FATAL => 'untie';
 565         eval { untie %h };
 566         is $@, '', "untie without inner references" ;
 567     }
 568
 569     checkRaw 'Op_dbmx',
 570             'abc'       => 'def',
 571             '123'       => '456',
 572             'ABC'       => 'AC',
 573             'alphaABC'  => 'betaAC',
 574             'greenABC'  => 'blueAC';
 575
 576 }
 577
 578 {
 579     #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate, closure";
 580
 581     my %h = () ;
 582     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 583     ok $db, "tied to $db_file";
 584
 585     doPreData(\%h);
 586
 587     eval {
 588         $db->Filter_Push(
 589                 Store => sub { $_ .= 'A' },
 590                 Fetch => sub { s/A$//    }) };
 591     is $@, '', "push 'append_A' filter" ;
 592
 593     eval { $db->Filter_Key_Push('append_B') };
 594     is $@, '', "push 'append_B' filter" ;
 595
 596     eval { $db->Filter_Push('append' => 'C') };
 597     is $@, '', "push 'append_C' filter" ;
 598
 599     doPostData(\%h);
 600
 601     undef $db;
 602     {
 603         use warnings FATAL => 'untie';
 604         eval { untie %h };
 605         is $@, '', "untie without inner references" ;
 606     }
 607
 608     checkRaw 'Op_dbmx',
 609             'abc'       => 'def',
 610             '123'       => '456',
 611             'ABC'       => 'AC',
 612             'alphaABC'  => 'betaAC',
 613             'greenABC'  => 'blueAC';
 614
 615 }
 616
 617 {
 618     #diag "Test Set: Filtered & Filter_Pop";
 619
 620     my %h = () ;
 621     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 622     ok $db, "tied to $db_file";
 623
 624     doPreData(\%h);
 625
 626     ok ! $db->Filtered, "not filtered" ;
 627
 628     eval {
 629         $db->Filter_Push(
 630                 Store => sub { $_ .= 'A' },
 631                 Fetch => sub { s/A$//    }) };
 632     is $@, '', "push 'append_A' filter" ;
 633
 634     ok $db->Filtered, "is filtered" ;
 635
 636     eval { $db->Filter_Key_Push('append_B') };
 637     is $@, '', "push 'append_B' filter" ;
 638
 639     ok $db->Filtered, "is filtered" ;
 640
 641     eval { $db->Filter_Push('append' => 'C') };
 642     is $@, '', "push 'append_C' filter" ;
 643
 644     ok $db->Filtered, "is filtered" ;
 645
 646     doPostData(\%h);
 647
 648     eval { $db->Filter_Pop() };
 649     is $@, '', "Filter_Pop";
 650
 651     ok $db->Filtered, "is filtered" ;
 652
 653     $h{'after'} = 'noon';
 654     is $h{'after'}, 'noon', "read eq written";
 655
 656     eval { $db->Filter_Pop() };
 657     is $@, '', "Filter_Pop";
 658
 659     ok $db->Filtered, "is filtered" ;
 660
 661     $h{'morning'} = 'after';
 662     is $h{'morning'}, 'after', "read eq written";
 663
 664     eval { $db->Filter_Pop() };
 665     is $@, '', "Filter_Pop";
 666
 667     ok ! $db->Filtered, "not filtered" ;
 668
 669     $h{'and'} = 'finally';
 670     is $h{'and'}, 'finally', "read eq written";
 671
 672     eval { $db->Filter_Pop() };
 673     is $@, '', "Filter_Pop";
 674
 675     undef $db;
 676     {
 677         use warnings FATAL => 'untie';
 678         eval { untie %h };
 679         is $@, '', "untie without inner references" ;
 680     }
 681
 682     checkRaw 'Op_dbmx',
 683             'abc'       => 'def',
 684             '123'       => '456',
 685             'ABC'       => 'AC',
 686             'alphaABC'  => 'betaAC',
 687             'greenABC'  => 'blueAC',
 688             'afterAB'   => 'noonA',
 689             'morningA'  => 'afterA',
 690             'and'       => 'finally';
 691
 692 }
 693
 694 {
 695     #diag "Test Set: define the filter package in-line";
 696
 697     {
 698         package DBM_Filter::append_X;
 699
 700         sub Store { $_ .= 'X' }
 701         sub Fetch { s/X$//    }
 702     }
 703
 704     my %h = () ;
 705     my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
 706     ok $db, "tied to $db_file";
 707
 708     doPreData(\%h);
 709
 710     eval { $db->Filter_Push('append_X') };
 711     is $@, '', "push 'append_X' filter" ;
 712
 713     doPostData(\%h);
 714
 715     undef $db;
 716     {
 717         use warnings FATAL => 'untie';
 718         eval { untie %h };
 719         is $@, '', "untie without inner references" ;
 720     }
 721
 722     checkRaw 'Op_dbmx',
 723             'abc'       => 'def',
 724             '123'       => '456',
 725             'X'         => 'X',
 726             'alphaX'    => 'betaX',
 727             'greenX'    => 'blueX';
 728
 729 }
 730