[p5sagit/p5-mst-13.2.git] / lib / DBM_Filter / t / 02core.t


use strict;
use warnings;
use Carp;

my %files = ();

use lib '.';

{
    chdir 't' if -d 't';
    if ( ! -d 'DBM_Filter')
    {
        mkdir 'DBM_Filter', 0777 
	    or die "Cannot create directory 'DBM_Filter': $!\n" ;
    }
}

END { rmdir 'DBM_Filter' }

sub writeFile
{
    my $filename = shift ;
    my $content = shift;
    open F, ">DBM_Filter/$filename.pm" or croak "Cannot open $filename: $!" ;
    print F $content ;
    close F;
    $files{"DBM_Filter/$filename.pm"} ++;
}

END { unlink keys %files if keys %files }

use Test::More tests => 189;

BEGIN { use_ok('DBM_Filter') };
my $db_file;
BEGIN {
    use Config;
    foreach (qw/SDBM_File ODBM_File NDBM_File GDBM_File DB_File/) {
        if ($Config{extensions} =~ /\b$_\b/) {
            $db_file = $_;
            last;
        }
    }
    use_ok($db_file);
};
BEGIN { use_ok('Fcntl') };

unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }

writeFile('times_ten', <<'EOM');
    package DBM_Filter::times_ten;
    sub Store { $_ *= 10 }
    sub Fetch { $_ /= 10 }
    1;
EOM

writeFile('append_A', <<'EOM');
    package DBM_Filter::append_A;
    sub Store { $_ .= 'A' }
    sub Fetch { s/A$//    }
    1;
EOM

writeFile('append_B', <<'EOM');
    package DBM_Filter::append_B;
    sub Store { $_ .= 'B' }
    sub Fetch { s/B$//    }
    1;
EOM

writeFile('append_C', <<'EOM');
    package DBM_Filter::append_C;
    sub Store { $_ .= 'C' }
    sub Fetch { s/C$//    }
    1;
EOM

writeFile('append_D', <<'EOM');
    package DBM_Filter::append_D;
    sub Store { $_ .= 'D' }
    sub Fetch { s/D$//    }
    1;
EOM

writeFile('append', <<'EOM');
    package DBM_Filter::append;
    sub Filter
    {
         my $string = shift ;
         return {
                    Store => sub { $_ .= $string   },
                    Fetch => sub { s/${string}$//  }
                }
    }
    1;
EOM

writeFile('double', <<'EOM');
    package DBM_Filter::double;
    sub Store { $_ *= 2 }
    sub Fetch { $_ /= 2 }
    1;
EOM

writeFile('uc', <<'EOM');
    package DBM_Filter::uc;
    sub Store { $_ = uc $_ }
    sub Fetch { $_ = lc $_ }
    1;
EOM

writeFile('reverse', <<'EOM');
    package DBM_Filter::reverse;
    sub Store { $_ = reverse $_ }
    sub Fetch { $_ = reverse $_ }
    1;
EOM


my %PreData = (
	'abc'	=> 'def',
	'123'	=> '456',
	);

my %PostData = (
	'alpha'	=> 'beta',
	'green'	=> 'blue',
	);

sub doPreData
{
    my $h = shift ;

    $$h{"abc"} = "def";
    $$h{"123"} = "456";
    ok $$h{"abc"} eq "def", "read eq written" ;
    ok $$h{"123"} eq "456", "read eq written" ;

}

sub doPostData
{
    my $h = shift ;

    no warnings 'uninitialized';
    $$h{undef()} = undef();
    $$h{"alpha"} = "beta";
    $$h{"green"} = "blue";
    ok $$h{""} eq "", "read eq written" ;
    ok $$h{"green"} eq "blue", "read eq written" ;
    ok $$h{"green"} eq "blue", "read eq written" ;

}

sub checkRaw
{
    my $filename = shift ;
    my %expected = @_ ;
    my %h;

    # read the dbm file without the filter
    ok tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640), "tied to $db_file";

    my %bad = ();
    while (my ($k, $v) = each %h) {
        if ( defined $expected{$k} &&  $expected{$k} eq $v ) {
            delete $expected{$k} ;
        }
        else
          { $bad{$k} = $v }
    }

    ok keys(%expected) + keys(%bad) == 0, "Raw hash is ok"; 

    if ( keys(%expected) + keys(%bad) ) {
        my $bad = "Expected does not match actual\nExpected:\n" ;
        while (my ($k, $v) = each %expected) {
            $bad .= "\t'$k' =>\t'$v'\n";
        }
        $bad .= "\nGot:\n" ;
        while (my ($k, $v) = each %bad) {
            $bad .= "\t'$k' =>\t'$v'\n";
        }
        diag $bad ;
    }
    
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }
    unlink <Op_dbmx*>;
}

{
    #diag "Test Set: Key and Value Filter, no stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'A'	=> 'A',
	    'alphaA'	=> 'betaA',
	    'greenA'	=> 'blueA';

}

{
    #diag "Test Set: Key Only Filter, no stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Key_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'A'	=> '',
	    'alphaA'	=> 'beta',
	    'greenA'	=> 'blue';

}

{
    #diag "Test Set: Value Only Filter, no stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Value_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    ''	=> 'A',
	    'alpha'	=> 'betaA',
	    'green'	=> 'blueA';

}

{
    #diag "Test Set: Key and Value Filter, with stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'AB'	=> 'AB',
	    'alphaAB'	=> 'betaAB',
	    'greenAB'	=> 'blueAB';

}

{
    #diag "Test Set: Key Filter != Value Filter, with stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Value_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Key_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    eval { $db->Filter_Value_Push('append_C') };
    is $@, '', "push 'append_C' filter" ;
    
    eval { $db->Filter_Key_Push('append_D') };
    is $@, '', "push 'append_D' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'BD'	=> 'AC',
	    'alphaBD'	=> 'betaAC',
	    'greenBD'	=> 'blueAC';

}

{
    #diag "Test Set: Key only Filter, with stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Key_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    eval { $db->Filter_Key_Push('append_D') };
    is $@, '', "push 'append_D' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'BD'	=> '',
	    'alphaBD'	=> 'beta',
	    'greenBD'	=> 'blue';

}

{
    #diag "Test Set: Value only Filter, with stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Value_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Value_Push('append_C') };
    is $@, '', "push 'append_C' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    ''	=> 'AC',
	    'alpha'	=> 'betaAC',
	    'green'	=> 'blueAC';

}

{
    #diag "Test Set: Combination Key/Value + Key Filter != Value Filter, with stacking, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Value_Push('append_C') };
    is $@, '', "push 'append_C' filter" ;
    
    eval { $db->Filter_Key_Push('append_D') };
    is $@, '', "push 'append_D' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'AD'	=> 'AC',
	    'alphaAD'	=> 'betaAC',
	    'greenAD'	=> 'blueAC';

}

{
    #diag "Test Set: Combination Key/Value + Key + Key/Value, no closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append_A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Key_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    eval { $db->Filter_Push('append_C') };
    is $@, '', "push 'append_C' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'ABC'	=> 'AC',
	    'alphaABC'	=> 'betaAC',
	    'greenABC'	=> 'blueAC';

}

{
    #diag "Test Set: Combination Key/Value + Key + Key/Value, with closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append' => 'A') };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Key_Push('append' => 'B') };
    is $@, '', "push 'append_B' filter" ;
    
    eval { $db->Filter_Push('append' => 'C') };
    is $@, '', "push 'append_C' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'ABC'	=> 'AC',
	    'alphaABC'	=> 'betaAC',
	    'greenABC'	=> 'blueAC';

}

{
    #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { 
        $db->Filter_Push(
                Store => sub { $_ .= 'A' },
                Fetch => sub { s/A$//    }) };
    is $@, '', "push 'append_A' filter" ;
    
    eval { 
        $db->Filter_Key_Push(
                Store => sub { $_ .= 'B' },
                Fetch => sub { s/B$//    }) };
    is $@, '', "push 'append_B' filter" ;
    
    eval { 
        $db->Filter_Push(
                Store => sub { $_ .= 'C' },
                Fetch => sub { s/C$//    }) };
    is $@, '', "push 'append_C' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'ABC'	=> 'AC',
	    'alphaABC'	=> 'betaAC',
	    'greenABC'	=> 'blueAC';

}

{
    #diag "Test Set: Combination Key/Value + Key + Key/Value, immediate, closure";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { 
        $db->Filter_Push(
                Store => sub { $_ .= 'A' },
                Fetch => sub { s/A$//    }) };
    is $@, '', "push 'append_A' filter" ;
    
    eval { $db->Filter_Key_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    eval { $db->Filter_Push('append' => 'C') };
    is $@, '', "push 'append_C' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'ABC'	=> 'AC',
	    'alphaABC'	=> 'betaAC',
	    'greenABC'	=> 'blueAC';

}

{
    #diag "Test Set: Filtered & Filter_Pop";

    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    ok ! $db->Filtered, "not filtered" ;

    eval { 
        $db->Filter_Push(
                Store => sub { $_ .= 'A' },
                Fetch => sub { s/A$//    }) };
    is $@, '', "push 'append_A' filter" ;
    
    ok $db->Filtered, "is filtered" ;

    eval { $db->Filter_Key_Push('append_B') };
    is $@, '', "push 'append_B' filter" ;
    
    ok $db->Filtered, "is filtered" ;
    
    eval { $db->Filter_Push('append' => 'C') };
    is $@, '', "push 'append_C' filter" ;
    
    ok $db->Filtered, "is filtered" ;
    
    doPostData(\%h);
    
    eval { $db->Filter_Pop() };
    is $@, '', "Filter_Pop";
    
    ok $db->Filtered, "is filtered" ;

    $h{'after'} = 'noon';
    is $h{'after'}, 'noon', "read eq written";

    eval { $db->Filter_Pop() };
    is $@, '', "Filter_Pop";
    
    ok $db->Filtered, "is filtered" ;

    $h{'morning'} = 'after';
    is $h{'morning'}, 'after', "read eq written";

    eval { $db->Filter_Pop() };
    is $@, '', "Filter_Pop";
    
    ok ! $db->Filtered, "not filtered" ;

    $h{'and'} = 'finally';
    is $h{'and'}, 'finally', "read eq written";

    eval { $db->Filter_Pop() };
    is $@, '', "Filter_Pop";
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'ABC'	=> 'AC',
	    'alphaABC'	=> 'betaAC',
	    'greenABC'	=> 'blueAC',
	    'afterAB'	=> 'noonA',
	    'morningA'	=> 'afterA',
	    'and'	=> 'finally';

}

{
    #diag "Test Set: define the filter package in-line";

    {
        package DBM_Filter::append_X;

        sub Store { $_ .= 'X' }
        sub Fetch { s/X$//    }
    }
    
    my %h = () ;
    my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to $db_file";
    
    doPreData(\%h);

    eval { $db->Filter_Push('append_X') };
    is $@, '', "push 'append_X' filter" ;
    
    doPostData(\%h);
    
    undef $db;
    {
        use warnings FATAL => 'untie';
        eval { untie %h };
        is $@, '', "untie without inner references" ;
    }

    checkRaw 'Op_dbmx', 
	    'abc'	=> 'def',
	    '123'	=> '456',
	    'X'  	=> 'X',
	    'alphaX'	=> 'betaX',
	    'greenX'	=> 'blueX';

}
Commit	Line	Data
0e9b1cbd	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
9aedf6d8	15	or die "Cannot create directory 'DBM_Filter': $!\n" ;
0e9b1cbd	16	}
	17	}
	18
9aedf6d8	19	END { rmdir 'DBM_Filter' }
0e9b1cbd	20
	21	sub writeFile
	22	{
	23	my $filename = shift ;
	24	my $content = shift;
9aedf6d8	25	open F, ">DBM_Filter/$filename.pm" or croak "Cannot open $filename: $!" ;
0e9b1cbd	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') };
e8ebc68a	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	};
0e9b1cbd	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
e8ebc68a	164	ok tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640), "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	201	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	202	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	231	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	232	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	261	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	262	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	291	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	292	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	324	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	325	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	363	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	364	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	396	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	397	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	429	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	430	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	465	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	466	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	501	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	502	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	537	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	538	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	582	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	583	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	621	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	622	ok $db, "tied to $db_file";
0e9b1cbd	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 = () ;
e8ebc68a	705	my $db = tie(%h, $db_file,'Op_dbmx', O_RDWR\|O_CREAT, 0640) ;
e8ebc68a	706	ok $db, "tied to $db_file";
0e9b1cbd	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