dslinux/user/perl/lib/DBM_Filter/t 01error.t 02core.t compress.t encode.t int32.t null.t utf8.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:27:07 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/DBM_Filter/t
In directory antilope:/tmp/cvs-serv7729/lib/DBM_Filter/t
Added Files:
01error.t 02core.t compress.t encode.t int32.t null.t utf8.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: encode.t ---
use strict;
use warnings;
use Carp;
BEGIN
{
eval { require Encode; };
if ($@) {
print "1..0 # Skip: Encode is not available\n";
exit 0;
}
}
require "dbm_filter_util.pl";
use Test::More tests => 26;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
BEGIN { use_ok('charnames', qw{greek})};
use charnames qw{greek};
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db1, "tied to SDBM_File";
eval { $db1->Filter_Push('encode' => 'blah') };
like $@, qr/^Encoding 'blah' is not available/, "push an illigal filter" ;
eval { $db1->Filter_Push('encode') };
is $@, '', "push an 'encode' filter (default to utf-8)" ;
{
no warnings 'uninitialized';
StoreData(\%h1,
{
undef() => undef(),
'alpha' => "\N{alpha}",
"\N{gamma}"=> "gamma",
"beta" => "\N{beta}",
});
}
VerifyData(\%h1,
{
'alpha' => "\N{alpha}",
"beta" => "\N{beta}",
"\N{gamma}"=> "gamma",
"" => "",
});
eval { $db1->Filter_Pop() };
is $@, '', "pop the 'utf8' filter" ;
eval { $db1->Filter_Push('encode' => 'iso-8859-16') };
is $@, '', "push an 'encode' filter (specify iso-8859-16)" ;
use charnames qw{:full};
StoreData(\%h1,
{
'euro' => "\N{EURO SIGN}",
});
undef $db1;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
# read the dbm file without the filter
my %h2 = () ;
my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
VerifyData(\%h2,
{
'alpha' => "\xCE\xB1",
'beta' => "\xCE\xB2",
"\xCE\xB3"=> "gamma",
'euro' => "\xA4",
"" => "",
});
undef $db2;
{
use warnings FATAL => 'untie';
eval { untie %h2 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: utf8.t ---
use strict;
use warnings;
use Carp;
BEGIN
{
eval { require Encode; };
if ($@) {
print "1..0 # Skip: Encode is not available\n";
exit 0;
}
}
require "dbm_filter_util.pl";
use Test::More tests => 20;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
BEGIN { use_ok('charnames', qw{greek})};
use charnames qw{greek};
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db1, "tied to SDBM_File";
eval { $db1->Filter_Push('utf8') };
is $@, '', "push a 'utf8' filter" ;
{
no warnings 'uninitialized';
StoreData(\%h1,
{
undef() => undef(),
"beta" => "\N{beta}",
'alpha' => "\N{alpha}",
"\N{gamma}"=> "gamma",
});
}
VerifyData(\%h1,
{
'alpha' => "\N{alpha}",
"beta" => "\N{beta}",
"\N{gamma}"=> "gamma",
"" => "",
});
undef $db1;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
# read the dbm file without the filter
my %h2 = () ;
my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
VerifyData(\%h2,
{
'alpha' => "\xCE\xB1",
'beta' => "\xCE\xB2",
"\xCE\xB3"=> "gamma",
"" => "",
});
undef $db2;
{
use warnings FATAL => 'untie';
eval { untie %h2 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: null.t ---
use strict;
use warnings;
use Carp;
require "dbm_filter_util.pl";
use Test::More tests => 26;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db1, "tied to SDBM_File";
# store before adding the filter
StoreData(\%h1,
{
"abc" => "def",
});
VerifyData(\%h1,
{
"abc" => "def",
});
eval { $db1->Filter_Push('null') };
is $@, '', "push a 'null' filter" ;
{
no warnings 'uninitialized';
StoreData(\%h1,
{
undef() => undef(),
"alpha" => "beta",
});
VerifyData(\%h1,
{
undef() => undef(),
"abc" => "", # not "def", because the filter is in place
"alpha" => "beta",
});
}
while (my ($k, $v) = each %h1) {
no warnings 'uninitialized';
#diag "After Match [$k][$v]";
}
undef $db1;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
# read the dbm file without the filter, check for null termination
my %h2 = () ;
my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
VerifyData(\%h2,
{
"abc" => "def",
"alpha\x00" => "beta\x00",
"\x00" => "\x00",
});
undef $db2;
{
use warnings FATAL => 'untie';
eval { untie %h2 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: 01error.t ---
use strict;
use warnings;
use Carp;
use lib '.';
our $db ;
{
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, ">$filename" or croak "Cannot open $filename: $!" ;
print F $content ;
close F;
}
sub runFilter
{
my $name = shift ;
my $filter = shift ;
print "# runFilter $name\n" ;
my $filename = "DBM_Filter/$name.pm";
$filter = "package DBM_Filter::$name ;\n$filter"
unless $filter =~ /^\s*package/ ;
writeFile($filename, $filter);
eval { $db->Filter_Push($name) };
unlink $filename;
return $@;
}
use Test::More tests => 21;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my %h2 = () ;
$db = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db, "tied to SDBM_File ok";
# Error cases
eval { $db->Filter_Push() ; };
like $@, qr/^Filter_Push: no parameters present/,
"croak if not parameters passed to Filter_Push";
eval { $db->Filter_Push("unknown_class") ; };
like $@, qr/^Filter_Push: Cannot Load DBM Filter 'DBM_Filter::unknown_class'/,
"croak on unknown class" ;
eval { $db->Filter_Push("Some::unknown_class") ; };
like $@, qr/^Filter_Push: Cannot Load DBM Filter 'Some::unknown_class'/,
"croak on unknown fully qualified class" ;
eval { $db->Filter_Push('Store') ; };
like $@, qr/^Filter_Push: not even params/,
"croak if not passing even number or params to Filter_Push";
runFilter('bad1', <<'EOM');
package DBM_Filter::bad1 ;
1;
EOM
like $@, qr/^Filter_Push: No methods \(Filter, Fetch or Store\) found in class 'DBM_Filter::bad1'/,
"croak if none of Filter/Fetch/Store in filter" ;
runFilter('bad2', <<'EOM');
package DBM_Filter::bad2 ;
sub Filter
{
return 2;
}
1;
EOM
like $@, qr/^Filter_Push: 'DBM_Filter::bad2::Filter' did not return a hash reference./,
"croak if Filter doesn't return hash reference" ;
runFilter('bad3', <<'EOM');
package DBM_Filter::bad3 ;
sub Filter
{
return { BadKey => sub { } } ;
}
1;
EOM
like $@, qr/^Filter_Push: Unknown key 'BadKey'/,
"croak if bad keyword returned from Filter";
runFilter('bad4', <<'EOM');
package DBM_Filter::bad4 ;
sub Filter
{
return { Store => "abc" } ;
}
1;
EOM
like $@, qr/^Filter_Push: value associated with key 'Store' is not a code reference/,
"croak if not a code reference";
runFilter('bad5', <<'EOM');
package DBM_Filter::bad5 ;
sub Filter
{
return { } ;
}
1;
EOM
like $@, qr/^Filter_Push: expected both Store & Fetch - got neither/,
"croak if neither fetch or store is present";
runFilter('bad6', <<'EOM');
package DBM_Filter::bad6 ;
sub Filter
{
return { Store => sub {} } ;
}
1;
EOM
like $@, qr/^Filter_Push: expected both Store & Fetch - got Store/,
"croak if store is present but fetch isn't";
runFilter('bad7', <<'EOM');
package DBM_Filter::bad7 ;
sub Filter
{
return { Fetch => sub {} } ;
}
1;
EOM
like $@, qr/^Filter_Push: expected both Store & Fetch - got Fetch/,
"croak if fetch is present but store isn't";
runFilter('bad8', <<'EOM');
package DBM_Filter::bad8 ;
sub Filter {}
sub Store {}
sub Fetch {}
1;
EOM
like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad8'/,
"croak if Fetch, Store and Filter";
runFilter('bad9', <<'EOM');
package DBM_Filter::bad9 ;
sub Filter {}
sub Store {}
1;
EOM
like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad9'/,
"croak if Store and Filter";
runFilter('bad10', <<'EOM');
package DBM_Filter::bad10 ;
sub Filter {}
sub Fetch {}
1;
EOM
like $@, qr/^Filter_Push: Can't mix Filter with Store and Fetch in class 'DBM_Filter::bad10'/,
"croak if Fetch and Filter";
runFilter('bad11', <<'EOM');
package DBM_Filter::bad11 ;
sub Fetch {}
1;
EOM
like $@, qr/^Filter_Push: Missing method 'Store' in class 'DBM_Filter::bad11'/,
"croak if Fetch but no Store";
runFilter('bad12', <<'EOM');
package DBM_Filter::bad12 ;
sub Store {}
1;
EOM
like $@, qr/^Filter_Push: Missing method 'Fetch' in class 'DBM_Filter::bad12'/,
"croak if Store but no Fetch";
undef $db;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: int32.t ---
use strict;
use warnings;
use Carp;
require "dbm_filter_util.pl";
use Test::More tests => 22;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db1, "tied to SDBM_File";
# store before adding the filter
StoreData(\%h1,
{
1234 => 5678,
-3 => -5,
"22" => "88",
"-45" => "-88",
});
VerifyData(\%h1,
{
1234 => 5678,
-3 => -5,
22 => 88,
-45 => -88,
});
eval { $db1->Filter_Push('int32') };
is $@, '', "push an 'int32' filter" ;
{
no warnings 'uninitialized';
StoreData(\%h1,
{
undef() => undef(),
"400" => "500",
0 => 1,
1 => 0,
-47 => -6,
});
}
undef $db1;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
# read the dbm file without the filter
my %h2 = () ;
my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
VerifyData(\%h2,
{
1234 => 5678,
-3 => -5,
22 => 88,
-45 => -88,
#undef() => undef(),
pack("i", 400) => pack("i", 500),
pack("i", 0) => pack("i", 1),
pack("i", 1) => pack("i", 0),
pack("i", -47) => pack("i", -6),
});
undef $db2;
{
use warnings FATAL => 'untie';
eval { untie %h2 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: compress.t ---
use strict;
use warnings;
use Carp;
BEGIN
{
eval { require Compress::Zlib ; };
if ($@) {
print "1..0 # Skip: Compress::Zlib is not available\n";
print "# $@\n";
exit 0;
}
}
require "dbm_filter_util.pl";
use Test::More tests => 23;
BEGIN { use_ok('DBM_Filter') };
BEGIN { use_ok('SDBM_File') };
BEGIN { use_ok('Fcntl') };
BEGIN { use_ok('Compress::Zlib') };
unlink <Op_dbmx*>;
END { unlink <Op_dbmx*>; }
my %h1 = () ;
my $db1 = tie(%h1, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db1, "tied to SDBM_File";
# store before adding the filter
StoreData(\%h1,
{
1234 => 5678,
-3 => -5,
"22" => "88",
"-45" => "-88",
"fred" => "Joe",
"alpha" => "Alpha",
"Beta" => "beta",
});
VerifyData(\%h1,
{
1234 => 5678,
-3 => -5,
"22" => "88",
"-45" => "-88",
"fred" => "Joe",
"alpha" => "Alpha",
"Beta" => "beta",
});
eval { $db1->Filter_Push('compress') };
is $@, '', "push a 'compress' filter" ;
{
no warnings 'uninitialized';
StoreData(\%h1,
{
undef() => undef(),
"400" => "500",
0 => 1,
1 => 0,
"abc" => "de0",
"\x00\x01" => "\x03\xFF",
});
}
undef $db1;
{
use warnings FATAL => 'untie';
eval { untie %h1 };
is $@, '', "untie without inner references" ;
}
# read the dbm file without the filter
my %h2 = () ;
my $db2 = tie(%h2, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640) ;
ok $db2, "tied to SDBM_File";
VerifyData(\%h2,
{
1234 => 5678,
-3 => -5,
"22" => "88",
"-45" => "-88",
"fred" => "Joe",
"alpha" => "Alpha",
"Beta" => "beta",
compress("") => compress(""),
compress("400") => compress("500"),
compress("0") => compress("1"),
compress("1") => compress("0"),
compress("abc") => compress("de0"),
compress("\x00\x01") => compress("\x03\xFF"),
});
undef $db2;
{
use warnings FATAL => 'untie';
eval { untie %h2 };
is $@, '', "untie without inner references" ;
}
--- NEW FILE: 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') };
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';
}
More information about the dslinux-commit
mailing list