[perl5.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 
            || die "Cannot create directory 'DBM_Filter': $!\n" ;
    }
}


sub writeFile
{
    my $filename = shift ;
    my $content = shift;
    open F, ">DBM_Filter/$filename.pm" || 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') };
BEGIN { use_ok('SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640), "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
    ok $db, "tied to SDBM_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 PM	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