[perl5.git] / ext / ODBM_File / t / odbm.t

#!./perl

# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $

BEGIN {
    require Config; import Config;
    if ($Config{'extensions'} !~ /\bODBM_File\b/ or $Config{'d_cplusplus'}) {
	print "1..0 # Skip: ODBM_File was not built\n";
	exit 0;
    }
}

use strict;
use warnings;

use Test::More tests => 81;

require ODBM_File;
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;

unlink <Op_dbmx.*>;

umask(0);
my %h;
isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'ODBM_File');

my $Dfile = "Op_dbmx.pag";
if (! -e $Dfile) {
	($Dfile) = <Op_dbmx*>;
}
SKIP: {
    skip "different file permission semantics on $^O", 1
	if $^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin';
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
     $blksize,$blocks) = stat($Dfile);
    is($mode & 0777, 0640);
}
my $i = 0;
while (my ($key,$value) = each(%h)) {
    $i++;
}
is($i, 0);

$h{'goner1'} = 'snork';

$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
$h{'a'} = 'A';
$h{'b'} = 'B';
$h{'c'} = 'C';
$h{'d'} = 'D';
$h{'e'} = 'E';
$h{'f'} = 'F';
$h{'g'} = 'G';
$h{'h'} = 'H';
$h{'i'} = 'I';

$h{'goner2'} = 'snork';
delete $h{'goner2'};

untie(%h);
isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR, 0640), 'ODBM_File');

$h{'j'} = 'J';
$h{'k'} = 'K';
$h{'l'} = 'L';
$h{'m'} = 'M';
$h{'n'} = 'N';
$h{'o'} = 'O';
$h{'p'} = 'P';
$h{'q'} = 'Q';
$h{'r'} = 'R';
$h{'s'} = 'S';
$h{'t'} = 'T';
$h{'u'} = 'U';
$h{'v'} = 'V';
$h{'w'} = 'W';
$h{'x'} = 'X';
$h{'y'} = 'Y';
$h{'z'} = 'Z';

$h{'goner3'} = 'snork';

delete $h{'goner1'};
delete $h{'goner3'};

my @keys = keys(%h);
my @values = values(%h);

is($#keys, 29);
is($#values, 29);

while (my ($key,$value) = each(%h)) {
    if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
	$key =~ y/a-z/A-Z/;
	$i++ if $key eq $value;
    }
}

is($i, 30);

@keys = ('blurfl', keys(%h), 'dyick');
is($#keys, 31);

$h{'foo'} = '';
$h{''} = 'bar';

my $ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
is($ok, 1, 'check cache overflow and numeric keys and contents');

my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
   $blksize,$blocks) = stat($Dfile);
cmp_ok($size, '>', 0);

@h{0..200} = 200..400;
my @foo = @h{0..200};
is(join(':',200..400), join(':',@foo));

is($h{'foo'}, '');
is($h{''}, 'bar');

untie %h;
unlink <Op_dbmx*>, $Dfile;

{
   # sub-class test

   package Another ;

   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
   print FILE <<'EOM' ;

   package SubDB ;

   use strict ;
   use warnings ;
   use vars qw(@ISA @EXPORT) ;

   require Exporter ;
   use ODBM_File;
   @ISA=qw(ODBM_File);
   @EXPORT = @ODBM_File::EXPORT ;

   sub STORE { 
	my $self = shift ;
        my $key = shift ;
        my $value = shift ;
        $self->SUPER::STORE($key, $value * 2) ;
   }

   sub FETCH { 
	my $self = shift ;
        my $key = shift ;
        $self->SUPER::FETCH($key) - 1 ;
   }

   sub A_new_method
   {
	my $self = shift ;
        my $key = shift ;
        my $value = $self->FETCH($key) ;
	return "[[$value]]" ;
   }

   1 ;
EOM

    close FILE  or die "Could not close: $!";

    BEGIN { push @INC, '.'; }
    unlink <dbhash_tmp*> ;

    eval 'use SubDB ; use Fcntl ;';
    main::is($@, "");
    my %h ;
    my $X ;
    eval '
	$X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
	' ;

    main::is($@, "");

    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
    main::is($@, "");
    main::is($ret, 5);

    $ret = eval '$X->A_new_method("fred") ' ;
    main::is($@, "");
    main::is($ret, "[[5]]");

    undef $X;
    untie(%h);
    unlink "SubDB.pm", <dbhash_tmp.*> ;

}

untie %h;
unlink <Op_dbmx*>, $Dfile;

{
   # DBM Filter tests
   my (%h, $db) ;
   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;

   sub checkOutput
   {
       my($fk, $sk, $fv, $sv) = @_ ;
       return
           $fetch_key eq $fk && $store_key eq $sk && 
	   $fetch_value eq $fv && $store_value eq $sv &&
	   $_ eq 'original' ;
   }
   
   unlink <Op_dbmx*>;
   $db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
   isa_ok($db, 'ODBM_File');

   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
   $db->filter_store_key   (sub { $store_key = $_ }) ;
   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
   $db->filter_store_value (sub { $store_value = $_ }) ;

   $_ = "original" ;

   $h{"fred"} = "joe" ;
   #                   fk   sk     fv   sv
   ok(checkOutput("", "fred", "", "joe"));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($h{"fred"}, "joe");
   #                   fk    sk     fv    sv
   ok(checkOutput("", "fred", "joe", ""));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($db->FIRSTKEY(), "fred");
   #                    fk     sk  fv  sv
   ok(checkOutput("fred", "", "", ""));

   # replace the filters, but remember the previous set
   my ($old_fk) = $db->filter_fetch_key   
   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
   my ($old_sk) = $db->filter_store_key   
   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
   my ($old_fv) = $db->filter_fetch_value 
   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
   my ($old_sv) = $db->filter_store_value 
   			(sub { s/o/x/g; $store_value = $_ }) ;
   
   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   $h{"Fred"} = "Joe" ;
   #                   fk   sk     fv    sv
   ok(checkOutput("", "fred", "", "Jxe"));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($h{"Fred"}, "[Jxe]");
   #                   fk   sk     fv    sv
   ok(checkOutput("", "fred", "[Jxe]", ""));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($db->FIRSTKEY(), "FRED");
   #                   fk   sk     fv    sv
   ok(checkOutput("FRED", "", "", ""));

   # put the original filters back
   $db->filter_fetch_key   ($old_fk);
   $db->filter_store_key   ($old_sk);
   $db->filter_fetch_value ($old_fv);
   $db->filter_store_value ($old_sv);

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   $h{"fred"} = "joe" ;
   ok(checkOutput("", "fred", "", "joe"));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($h{"fred"}, "joe");
   ok(checkOutput("", "fred", "joe", ""));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($db->FIRSTKEY(), "fred");
   ok(checkOutput("fred", "", "", ""));

   # delete the filters
   $db->filter_fetch_key   (undef);
   $db->filter_store_key   (undef);
   $db->filter_fetch_value (undef);
   $db->filter_store_value (undef);

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   $h{"fred"} = "joe" ;
   ok(checkOutput("", "", "", ""));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($h{"fred"}, "joe");
   ok(checkOutput("", "", "", ""));

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   is($db->FIRSTKEY(), "fred");
   ok(checkOutput("", "", "", ""));

   undef $db ;
   untie %h;
   unlink <Op_dbmx*>;
}

{    
    # DBM Filter with a closure

    my (%h, $db) ;

    unlink <Op_dbmx*>;
    $db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
    isa_ok($db, 'ODBM_File');

    my %result = () ;

    sub Closure
    {
        my ($name) = @_ ;
	my $count = 0 ;
	my @kept = () ;

	return sub { ++$count ; 
		     push @kept, $_ ; 
		     $result{$name} = "$name - $count: [@kept]" ;
		   }
    }

    $db->filter_store_key(Closure("store key")) ;
    $db->filter_store_value(Closure("store value")) ;
    $db->filter_fetch_key(Closure("fetch key")) ;
    $db->filter_fetch_value(Closure("fetch value")) ;

    $_ = "original" ;

    $h{"fred"} = "joe" ;
    is($result{"store key"}, "store key - 1: [fred]");
    is($result{"store value"}, "store value - 1: [joe]");
    is($result{"fetch key"}, undef);
    is($result{"fetch value"}, undef);
    is($_, "original");

    is($db->FIRSTKEY(), "fred");
    is($result{"store key"}, "store key - 1: [fred]");
    is($result{"store value"}, "store value - 1: [joe]");
    is($result{"fetch key"}, "fetch key - 1: [fred]");
    is($result{"fetch value"}, undef);
    is($_, "original");

    $h{"jim"}  = "john" ;
    is($result{"store key"}, "store key - 2: [fred jim]");
    is($result{"store value"}, "store value - 2: [joe john]");
    is($result{"fetch key"}, "fetch key - 1: [fred]");
    is($result{"fetch value"}, undef);
    is($_, "original");

    is($h{"fred"}, "joe");
    is($result{"store key"}, "store key - 3: [fred jim fred]");
    is($result{"store value"}, "store value - 2: [joe john]");
    is($result{"fetch key"}, "fetch key - 1: [fred]");
    is($result{"fetch value"}, "fetch value - 1: [joe]");
    is($_, "original");

    undef $db ;
    untie %h;
    unlink <Op_dbmx*>;
}		

{
   # DBM Filter recursion detection
   my (%h, $db) ;
   unlink <Op_dbmx*>;

   $db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640;
   isa_ok($db, 'ODBM_File');

   $db->filter_store_key (sub { $_ = $h{$_} }) ;

   eval '$h{1} = 1234' ;
   like($@, qr/^recursion detected in filter_store_key at/);
   
   undef $db ;
   untie %h;
   unlink <Op_dbmx*>;
}

{
    # Bug ID 20001013.009
    #
    # test that $hash{KEY} = undef doesn't produce the warning
    #     Use of uninitialized value in null operation 

    unlink <Op_dbmx*>;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;

    isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR|O_CREAT, 0640), 'ODBM_File');
    $h{ABC} = undef;
    is($a, "");
    untie %h;
    unlink <Op_dbmx*>;
}

{
    # When iterating over a tied hash using "each", the key passed to FETCH
    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
    # key in FETCH via a filter_fetch_key method we need to check that the
    # modified key doesn't get passed to NEXTKEY.
    # Also Test "keys" & "values" while we are at it.

    unlink <Op_dbmx*>;
    my $bad_key = 0 ;
    my %h = () ;
    my $db = tie %h, 'ODBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640;
    isa_ok($db, 'ODBM_File');
    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;

    $h{'Alpha_ABC'} = 2 ;
    $h{'Alpha_DEF'} = 5 ;

    is($h{'Alpha_ABC'}, 2);
    is($h{'Alpha_DEF'}, 5);

    my ($k, $v) = ("","");
    while (($k, $v) = each %h) {}
    is($bad_key, 0);

    $bad_key = 0 ;
    foreach $k (keys %h) {}
    is($bad_key, 0);

    $bad_key = 0 ;
    foreach $v (values %h) {}
    is($bad_key, 0);

    undef $db ;
    untie %h ;
    unlink <Op_dbmx*>;
}

{
   # Check that DBM Filter can cope with read-only $_

   my %h ;
   unlink <Op1_dbmx*>;

   my $db = tie %h, 'ODBM_File','Op1_dbmx', O_RDWR|O_CREAT, 0640;
   isa_ok($db, 'ODBM_File');

   $db->filter_fetch_key   (sub { }) ;
   $db->filter_store_key   (sub { }) ;
   $db->filter_fetch_value (sub { }) ;
   $db->filter_store_value (sub { }) ;

   $_ = "original" ;

   $h{"fred"} = "joe" ;
   is($h{"fred"}, "joe");

   is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
   is($@, '');


   # delete the filters
   $db->filter_fetch_key   (undef);
   $db->filter_store_key   (undef);
   $db->filter_fetch_value (undef);
   $db->filter_store_value (undef);

   $h{"fred"} = "joe" ;

   is($h{"fred"}, "joe");

   is($db->FIRSTKEY(), "fred");
   
   is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
   is($@, '');

   undef $db ;
   untie %h;
   unlink <Op1_dbmx*>;
}

if ($^O eq 'hpux') {
    print <<EOM;
#
# If you experience failures with the odbm test in HP-UX,
# this is a well-known bug that's unfortunately very hard to fix.
# The suggested course of action is to avoid using the ODBM_File,
# but to use instead the NDBM_File extension.
#
EOM
}
Commit	Line	Data
bee1dbe2 LW	1	#!./perl
bee1dbe2 LW	2
a0d0e21e LW	3	# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
	4
	5	BEGIN {
a0d0e21e	6	require Config; import Config;
ae5c2706	7	if ($Config{'extensions'} !~ /\bODBM_File\b/ or $Config{'d_cplusplus'}) {
45c0de28	8	print "1..0 # Skip: ODBM_File was not built\n";
a0d0e21e LW	9	exit 0;
	10	}
	11	}
	12
698828ad JH	13	use strict;
	14	use warnings;
	15
28e5c022	16	use Test::More tests => 81;
698828ad	17
a0d0e21e LW	18	require ODBM_File;
	19	#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR\|O_CREAT
	20	use Fcntl;
	21
89cebecc	22	unlink <Op_dbmx.*>;
a0d0e21e	23
bee1dbe2	24	umask(0);
698828ad	25	my %h;
89cebecc	26	isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR\|O_CREAT, 0640), 'ODBM_File');
a0d0e21e	27
89cebecc	28	my $Dfile = "Op_dbmx.pag";
a0d0e21e	29	if (! -e $Dfile) {
89cebecc	30	($Dfile) = <Op_dbmx*>;
a0d0e21e	31	}
876dc03f NC	32	SKIP: {
876dc03f NC	33	skip "different file permission semantics on $^O", 1
28e5c022	34	if $^O eq 'amigaos' \|\| $^O eq 'os2' \|\| $^O eq 'MSWin32' \|\| $^O eq 'NetWare' \|\| $^O eq 'dos' \|\| $^O eq 'cygwin';
698828ad	35	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
544a3566	36	$blksize,$blocks) = stat($Dfile);
876dc03f	37	is($mode & 0777, 0640);
544a3566	38	}
698828ad JH	39	my $i = 0;
698828ad JH	40	while (my ($key,$value) = each(%h)) {
bee1dbe2 LW	41	$i++;
bee1dbe2 LW	42	}
876dc03f	43	is($i, 0);
bee1dbe2 LW	44
	45	$h{'goner1'} = 'snork';
	46
	47	$h{'abc'} = 'ABC';
	48	$h{'def'} = 'DEF';
	49	$h{'jkl','mno'} = "JKL\034MNO";
	50	$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
	51	$h{'a'} = 'A';
	52	$h{'b'} = 'B';
	53	$h{'c'} = 'C';
	54	$h{'d'} = 'D';
	55	$h{'e'} = 'E';
	56	$h{'f'} = 'F';
	57	$h{'g'} = 'G';
	58	$h{'h'} = 'H';
	59	$h{'i'} = 'I';
	60
	61	$h{'goner2'} = 'snork';
	62	delete $h{'goner2'};
	63
a0d0e21e	64	untie(%h);
89cebecc	65	isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR, 0640), 'ODBM_File');
bee1dbe2 LW	66
	67	$h{'j'} = 'J';
	68	$h{'k'} = 'K';
	69	$h{'l'} = 'L';
	70	$h{'m'} = 'M';
	71	$h{'n'} = 'N';
	72	$h{'o'} = 'O';
	73	$h{'p'} = 'P';
	74	$h{'q'} = 'Q';
	75	$h{'r'} = 'R';
	76	$h{'s'} = 'S';
	77	$h{'t'} = 'T';
	78	$h{'u'} = 'U';
	79	$h{'v'} = 'V';
	80	$h{'w'} = 'W';
	81	$h{'x'} = 'X';
	82	$h{'y'} = 'Y';
	83	$h{'z'} = 'Z';
	84
	85	$h{'goner3'} = 'snork';
	86
	87	delete $h{'goner1'};
	88	delete $h{'goner3'};
	89
698828ad JH	90	my @keys = keys(%h);
698828ad JH	91	my @values = values(%h);
bee1dbe2	92
876dc03f NC	93	is($#keys, 29);
876dc03f NC	94	is($#values, 29);
bee1dbe2	95
698828ad	96	while (my ($key,$value) = each(%h)) {
2f52a358	97	if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
bee1dbe2 LW	98	$key =~ y/a-z/A-Z/;
	99	$i++ if $key eq $value;
	100	}
	101	}
	102
876dc03f	103	is($i, 30);
bee1dbe2	104
c6aa4a32	105	@keys = ('blurfl', keys(%h), 'dyick');
876dc03f	106	is($#keys, 31);
bee1dbe2 LW	107
	108	$h{'foo'} = '';
	109	$h{''} = 'bar';
	110
698828ad	111	my $ok = 1;
bee1dbe2 LW	112	for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
bee1dbe2 LW	113	for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
876dc03f	114	is($ok, 1, 'check cache overflow and numeric keys and contents');
bee1dbe2	115
698828ad	116	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
a0d0e21e	117	$blksize,$blocks) = stat($Dfile);
876dc03f	118	cmp_ok($size, '>', 0);
bee1dbe2 LW	119
bee1dbe2 LW	120	@h{0..200} = 200..400;
698828ad	121	my @foo = @h{0..200};
876dc03f	122	is(join(':',200..400), join(':',@foo));
bee1dbe2	123
876dc03f NC	124	is($h{'foo'}, '');
876dc03f NC	125	is($h{''}, 'bar');
bee1dbe2	126
bbad3607	127	untie %h;
89cebecc	128	unlink <Op_dbmx*>, $Dfile;
4e2a63a7	129
4e2a63a7 PM	130	{
	131	# sub-class test
	132
	133	package Another ;
	134
4e2a63a7 PM	135	open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
	136	print FILE <<'EOM' ;
	137
	138	package SubDB ;
	139
	140	use strict ;
698828ad	141	use warnings ;
4e2a63a7 PM	142	use vars qw(@ISA @EXPORT) ;
	143
	144	require Exporter ;
	145	use ODBM_File;
	146	@ISA=qw(ODBM_File);
	147	@EXPORT = @ODBM_File::EXPORT ;
	148
	149	sub STORE {
	150	my $self = shift ;
	151	my $key = shift ;
	152	my $value = shift ;
	153	$self->SUPER::STORE($key, $value * 2) ;
	154	}
	155
	156	sub FETCH {
	157	my $self = shift ;
	158	my $key = shift ;
	159	$self->SUPER::FETCH($key) - 1 ;
	160	}
	161
	162	sub A_new_method
	163	{
	164	my $self = shift ;
	165	my $key = shift ;
	166	my $value = $self->FETCH($key) ;
	167	return "[[$value]]" ;
	168	}
	169
	170	1 ;
	171	EOM
	172
28e5c022	173	close FILE or die "Could not close: $!";
4e2a63a7 PM	174
4e2a63a7 PM	175	BEGIN { push @INC, '.'; }
89cebecc	176	unlink <dbhash_tmp*> ;
4e2a63a7 PM	177
4e2a63a7 PM	178	eval 'use SubDB ; use Fcntl ;';
876dc03f	179	main::is($@, "");
4e2a63a7 PM	180	my %h ;
	181	my $X ;
	182	eval '
89cebecc	183	$X = tie(%h, "SubDB","dbhash_tmp", O_RDWR\|O_CREAT, 0640 );
4e2a63a7 PM	184	' ;
4e2a63a7 PM	185
876dc03f	186	main::is($@, "");
4e2a63a7 PM	187
4e2a63a7 PM	188	my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
876dc03f NC	189	main::is($@, "");
876dc03f NC	190	main::is($ret, 5);
4e2a63a7 PM	191
4e2a63a7 PM	192	$ret = eval '$X->A_new_method("fred") ' ;
876dc03f NC	193	main::is($@, "");
876dc03f NC	194	main::is($ret, "[[5]]");
4e2a63a7	195
fac76ed7 MB	196	undef $X;
fac76ed7 MB	197	untie(%h);
89cebecc	198	unlink "SubDB.pm", <dbhash_tmp.*> ;
4e2a63a7 PM	199
4e2a63a7 PM	200	}
9fe6733a	201
89cebecc NC	202	untie %h;
	203	unlink <Op_dbmx*>, $Dfile;
	204
9fe6733a PM	205	{
9fe6733a PM	206	# DBM Filter tests
9fe6733a PM	207	my (%h, $db) ;
	208	my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	209
	210	sub checkOutput
	211	{
	212	my($fk, $sk, $fv, $sv) = @_ ;
	213	return
	214	$fetch_key eq $fk && $store_key eq $sk &&
	215	$fetch_value eq $fv && $store_value eq $sv &&
	216	$_ eq 'original' ;
	217	}
	218
89cebecc NC	219	unlink <Op_dbmx*>;
89cebecc NC	220	$db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR\|O_CREAT, 0640;
876dc03f	221	isa_ok($db, 'ODBM_File');
9fe6733a PM	222
	223	$db->filter_fetch_key (sub { $fetch_key = $_ }) ;
	224	$db->filter_store_key (sub { $store_key = $_ }) ;
	225	$db->filter_fetch_value (sub { $fetch_value = $_}) ;
	226	$db->filter_store_value (sub { $store_value = $_ }) ;
	227
	228	$_ = "original" ;
	229
	230	$h{"fred"} = "joe" ;
	231	# fk sk fv sv
876dc03f	232	ok(checkOutput("", "fred", "", "joe"));
9fe6733a PM	233
9fe6733a PM	234	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f	235	is($h{"fred"}, "joe");
9fe6733a	236	# fk sk fv sv
876dc03f	237	ok(checkOutput("", "fred", "joe", ""));
9fe6733a PM	238
9fe6733a PM	239	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f	240	is($db->FIRSTKEY(), "fred");
9fe6733a	241	# fk sk fv sv
876dc03f	242	ok(checkOutput("fred", "", "", ""));
9fe6733a PM	243
	244	# replace the filters, but remember the previous set
	245	my ($old_fk) = $db->filter_fetch_key
	246	(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
	247	my ($old_sk) = $db->filter_store_key
	248	(sub { $_ = lc $_ ; $store_key = $_ }) ;
	249	my ($old_fv) = $db->filter_fetch_value
	250	(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
	251	my ($old_sv) = $db->filter_store_value
	252	(sub { s/o/x/g; $store_value = $_ }) ;
	253
	254	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	255	$h{"Fred"} = "Joe" ;
	256	# fk sk fv sv
876dc03f	257	ok(checkOutput("", "fred", "", "Jxe"));
9fe6733a PM	258
9fe6733a PM	259	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f	260	is($h{"Fred"}, "[Jxe]");
9fe6733a	261	# fk sk fv sv
876dc03f	262	ok(checkOutput("", "fred", "[Jxe]", ""));
9fe6733a PM	263
9fe6733a PM	264	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f	265	is($db->FIRSTKEY(), "FRED");
9fe6733a	266	# fk sk fv sv
876dc03f	267	ok(checkOutput("FRED", "", "", ""));
9fe6733a PM	268
	269	# put the original filters back
	270	$db->filter_fetch_key ($old_fk);
	271	$db->filter_store_key ($old_sk);
	272	$db->filter_fetch_value ($old_fv);
	273	$db->filter_store_value ($old_sv);
	274
	275	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	276	$h{"fred"} = "joe" ;
876dc03f	277	ok(checkOutput("", "fred", "", "joe"));
9fe6733a PM	278
9fe6733a PM	279	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f NC	280	is($h{"fred"}, "joe");
876dc03f NC	281	ok(checkOutput("", "fred", "joe", ""));
9fe6733a PM	282
9fe6733a PM	283	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f NC	284	is($db->FIRSTKEY(), "fred");
876dc03f NC	285	ok(checkOutput("fred", "", "", ""));
9fe6733a PM	286
	287	# delete the filters
	288	$db->filter_fetch_key (undef);
	289	$db->filter_store_key (undef);
	290	$db->filter_fetch_value (undef);
	291	$db->filter_store_value (undef);
	292
	293	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	294	$h{"fred"} = "joe" ;
876dc03f	295	ok(checkOutput("", "", "", ""));
9fe6733a PM	296
9fe6733a PM	297	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f NC	298	is($h{"fred"}, "joe");
876dc03f NC	299	ok(checkOutput("", "", "", ""));
9fe6733a PM	300
9fe6733a PM	301	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
876dc03f NC	302	is($db->FIRSTKEY(), "fred");
876dc03f NC	303	ok(checkOutput("", "", "", ""));
9fe6733a PM	304
	305	undef $db ;
	306	untie %h;
89cebecc	307	unlink <Op_dbmx*>;
9fe6733a PM	308	}
	309
	310	{
	311	# DBM Filter with a closure
	312
9fe6733a PM	313	my (%h, $db) ;
9fe6733a PM	314
89cebecc NC	315	unlink <Op_dbmx*>;
89cebecc NC	316	$db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR\|O_CREAT, 0640;
876dc03f	317	isa_ok($db, 'ODBM_File');
9fe6733a PM	318
	319	my %result = () ;
	320
	321	sub Closure
	322	{
	323	my ($name) = @_ ;
	324	my $count = 0 ;
	325	my @kept = () ;
	326
	327	return sub { ++$count ;
	328	push @kept, $_ ;
	329	$result{$name} = "$name - $count: [@kept]" ;
	330	}
	331	}
	332
	333	$db->filter_store_key(Closure("store key")) ;
	334	$db->filter_store_value(Closure("store value")) ;
	335	$db->filter_fetch_key(Closure("fetch key")) ;
	336	$db->filter_fetch_value(Closure("fetch value")) ;
	337
	338	$_ = "original" ;
	339
	340	$h{"fred"} = "joe" ;
876dc03f NC	341	is($result{"store key"}, "store key - 1: [fred]");
	342	is($result{"store value"}, "store value - 1: [joe]");
	343	is($result{"fetch key"}, undef);
	344	is($result{"fetch value"}, undef);
	345	is($_, "original");
	346
	347	is($db->FIRSTKEY(), "fred");
	348	is($result{"store key"}, "store key - 1: [fred]");
	349	is($result{"store value"}, "store value - 1: [joe]");
	350	is($result{"fetch key"}, "fetch key - 1: [fred]");
	351	is($result{"fetch value"}, undef);
	352	is($_, "original");
9fe6733a PM	353
9fe6733a PM	354	$h{"jim"} = "john" ;
876dc03f NC	355	is($result{"store key"}, "store key - 2: [fred jim]");
	356	is($result{"store value"}, "store value - 2: [joe john]");
	357	is($result{"fetch key"}, "fetch key - 1: [fred]");
	358	is($result{"fetch value"}, undef);
	359	is($_, "original");
	360
	361	is($h{"fred"}, "joe");
	362	is($result{"store key"}, "store key - 3: [fred jim fred]");
	363	is($result{"store value"}, "store value - 2: [joe john]");
	364	is($result{"fetch key"}, "fetch key - 1: [fred]");
	365	is($result{"fetch value"}, "fetch value - 1: [joe]");
	366	is($_, "original");
9fe6733a PM	367
	368	undef $db ;
	369	untie %h;
89cebecc	370	unlink <Op_dbmx*>;
9fe6733a PM	371	}
	372
	373	{
	374	# DBM Filter recursion detection
9fe6733a	375	my (%h, $db) ;
89cebecc	376	unlink <Op_dbmx*>;
9fe6733a	377
89cebecc	378	$db = tie %h, 'ODBM_File', 'Op_dbmx', O_RDWR\|O_CREAT, 0640;
876dc03f	379	isa_ok($db, 'ODBM_File');
9fe6733a PM	380
	381	$db->filter_store_key (sub { $_ = $h{$_} }) ;
	382
	383	eval '$h{1} = 1234' ;
876dc03f	384	like($@, qr/^recursion detected in filter_store_key at/);
9fe6733a PM	385
	386	undef $db ;
	387	untie %h;
89cebecc	388	unlink <Op_dbmx*>;
9fe6733a	389	}
9394203c	390
cbc5248d PM	391	{
	392	# Bug ID 20001013.009
	393	#
	394	# test that $hash{KEY} = undef doesn't produce the warning
	395	# Use of uninitialized value in null operation
cbc5248d	396
89cebecc	397	unlink <Op_dbmx*>;
cbc5248d PM	398	my %h ;
	399	my $a = "";
	400	local $SIG{__WARN__} = sub {$a = $_[0]} ;
89cebecc NC	401
89cebecc NC	402	isa_ok(tie(%h, 'ODBM_File', 'Op_dbmx', O_RDWR\|O_CREAT, 0640), 'ODBM_File');
cbc5248d	403	$h{ABC} = undef;
876dc03f	404	is($a, "");
cbc5248d	405	untie %h;
89cebecc	406	unlink <Op_dbmx*>;
cbc5248d PM	407	}
cbc5248d PM	408
0bf2e707 PM	409	{
	410	# When iterating over a tied hash using "each", the key passed to FETCH
	411	# will be recycled and passed to NEXTKEY. If a Source Filter modifies the
	412	# key in FETCH via a filter_fetch_key method we need to check that the
	413	# modified key doesn't get passed to NEXTKEY.
	414	# Also Test "keys" & "values" while we are at it.
	415
89cebecc	416	unlink <Op_dbmx*>;
0bf2e707 PM	417	my $bad_key = 0 ;
0bf2e707 PM	418	my %h = () ;
89cebecc	419	my $db = tie %h, 'ODBM_File','Op_dbmx', O_RDWR\|O_CREAT, 0640;
876dc03f	420	isa_ok($db, 'ODBM_File');
0bf2e707 PM	421	$db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
	422	$db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;
	423
	424	$h{'Alpha_ABC'} = 2 ;
	425	$h{'Alpha_DEF'} = 5 ;
	426
876dc03f NC	427	is($h{'Alpha_ABC'}, 2);
876dc03f NC	428	is($h{'Alpha_DEF'}, 5);
0bf2e707 PM	429
	430	my ($k, $v) = ("","");
	431	while (($k, $v) = each %h) {}
876dc03f	432	is($bad_key, 0);
0bf2e707 PM	433
	434	$bad_key = 0 ;
	435	foreach $k (keys %h) {}
876dc03f	436	is($bad_key, 0);
0bf2e707 PM	437
	438	$bad_key = 0 ;
	439	foreach $v (values %h) {}
876dc03f	440	is($bad_key, 0);
0bf2e707 PM	441
	442	undef $db ;
	443	untie %h ;
89cebecc	444	unlink <Op_dbmx*>;
0bf2e707 PM	445	}
0bf2e707 PM	446
6a31061a PM	447	{
	448	# Check that DBM Filter can cope with read-only $_
	449
6a31061a	450	my %h ;
89cebecc	451	unlink <Op1_dbmx*>;
6a31061a	452
89cebecc	453	my $db = tie %h, 'ODBM_File','Op1_dbmx', O_RDWR\|O_CREAT, 0640;
876dc03f	454	isa_ok($db, 'ODBM_File');
6a31061a PM	455
	456	$db->filter_fetch_key (sub { }) ;
	457	$db->filter_store_key (sub { }) ;
	458	$db->filter_fetch_value (sub { }) ;
	459	$db->filter_store_value (sub { }) ;
	460
	461	$_ = "original" ;
	462
	463	$h{"fred"} = "joe" ;
876dc03f	464	is($h{"fred"}, "joe");
6a31061a	465
28e5c022	466	is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
876dc03f	467	is($@, '');
6a31061a PM	468
	469
	470	# delete the filters
	471	$db->filter_fetch_key (undef);
	472	$db->filter_store_key (undef);
	473	$db->filter_fetch_value (undef);
	474	$db->filter_store_value (undef);
	475
	476	$h{"fred"} = "joe" ;
	477
876dc03f	478	is($h{"fred"}, "joe");
6a31061a	479
876dc03f	480	is($db->FIRSTKEY(), "fred");
6a31061a	481
28e5c022	482	is_deeply([eval { map { $h{$_} } (1, 2, 3) }], [undef, undef, undef]);
876dc03f	483	is($@, '');
6a31061a PM	484
	485	undef $db ;
	486	untie %h;
89cebecc	487	unlink <Op1_dbmx*>;
6a31061a	488	}
876dc03f	489
9394203c JH	490	if ($^O eq 'hpux') {
	491	print <<EOM;
	492	#
	493	# If you experience failures with the odbm test in HP-UX,
	494	# this is a well-known bug that's unfortunately very hard to fix.
	495	# The suggested course of action is to avoid using the ODBM_File,
	496	# but to use instead the NDBM_File extension.
	497	#
	498	EOM
	499	}