Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
01error.t	4.9 KB	-r--r--r--	2014-12-27 11:48
02core.t	15.32 KB	-r--r--r--	2014-12-27 11:48
compress.t	2.06 KB	-r--r--r--	2014-12-27 11:48
encode.t	2.27 KB	-r--r--r--	2014-12-27 11:48
int32.t	1.58 KB	-r--r--r--	2014-12-27 11:48
null.t	1.59 KB	-r--r--r--	2014-12-27 11:48
utf8.t	1.78 KB	-r--r--r--	2014-12-27 11:48

Rename

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";