[p5sagit/p5-mst-13.2.git] / ext / NDBM_File / t / ndbm.t

#!./perl

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

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

use strict;
use warnings;

sub ok
{
    my $no = shift ;
    my $result = shift ;

    print "not " unless $result ;
    print "ok $no\n" ;
}

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

print "1..77\n";

unlink <Op.dbmx*>;

umask(0);
my %h;
ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));

my $Dfile = "Op.dbmx.pag";
if (! -e $Dfile) {
	($Dfile) = <Op.dbmx*>;
}
if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'MacOS') {
    print "ok 2 # Skipped: different file permission semantics\n";
}
else {
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
     $blksize,$blocks) = stat($Dfile);
    print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
}
my $i = 0;
while (my ($key,$value) = each(%h)) {
    $i++;
}
print (!$i ? "ok 3\n" : "not ok 3\n");

$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);
print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");

$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);

if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}

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

if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}

@keys = ('blurfl', keys(%h), 'dyick');
if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}

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

# check cache overflow and numeric keys and contents
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; }
print ($ok ? "ok 8\n" : "not ok 8\n");

my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
   $blksize,$blocks) = stat($Dfile);
print ($size > 0 ? "ok 9\n" : "not ok 9\n");

@h{0..200} = 200..400;
my @foo = @h{0..200};
print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";

print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");

untie %h;
unlink <Op.dbmx*>, $Dfile;

{
   # sub-class test

   package Another ;

   use strict ;
   use warnings ;

   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 NDBM_File;
   @ISA=qw(NDBM_File);
   @EXPORT = @NDBM_File::EXPORT if defined @NDBM_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 ;

    BEGIN { push @INC, '.'; }

    eval 'use SubDB ; use Fcntl ; ';
    main::ok(13, $@ eq "") ;
    my %h ;
    my $X ;
    eval '
	$X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
	' ;

    main::ok(14, $@ eq "") ;

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

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

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

}

{
   # DBM Filter tests
   use strict ;
   use warnings ;
   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*>;
   ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;

   $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(20, checkOutput( "", "fred", "", "joe")) ;

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

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   ok(23, $db->FIRSTKEY() eq "fred") ;
   #                    fk     sk  fv  sv
   ok(24, 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(25, checkOutput( "", "fred", "", "Jxe")) ;

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

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   ok(28, $db->FIRSTKEY() eq "FRED") ;
   #                   fk   sk     fv    sv
   ok(29, 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(30, checkOutput( "", "fred", "", "joe")) ;

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

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   ok(33, $db->FIRSTKEY() eq "fred") ;
   ok(34, 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(35, checkOutput( "", "", "", "")) ;

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

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

   undef $db ;
   untie %h;
   unlink <Op.dbmx*>;
}

{    
    # DBM Filter with a closure

    use strict ;
    use warnings ;
    my (%h, $db) ;

    unlink <Op.dbmx*>;
    ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;

    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" ;
    ok(41, $result{"store key"} eq "store key - 1: [fred]");
    ok(42, $result{"store value"} eq "store value - 1: [joe]");
    ok(43, !defined $result{"fetch key"} );
    ok(44, !defined $result{"fetch value"} );
    ok(45, $_ eq "original") ;

    ok(46, $db->FIRSTKEY() eq "fred") ;
    ok(47, $result{"store key"} eq "store key - 1: [fred]");
    ok(48, $result{"store value"} eq "store value - 1: [joe]");
    ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(50, ! defined $result{"fetch value"} );
    ok(51, $_ eq "original") ;

    $h{"jim"}  = "john" ;
    ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
    ok(53, $result{"store value"} eq "store value - 2: [joe john]");
    ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(55, ! defined $result{"fetch value"} );
    ok(56, $_ eq "original") ;

    ok(57, $h{"fred"} eq "joe");
    ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
    ok(59, $result{"store value"} eq "store value - 2: [joe john]");
    ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
    ok(62, $_ eq "original") ;

    undef $db ;
    untie %h;
    unlink <Op.dbmx*>;
}		

{
   # DBM Filter recursion detection
   use strict ;
   use warnings ;
   my (%h, $db) ;
   unlink <Op.dbmx*>;

   ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;

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

   eval '$h{1} = 1234' ;
   ok(64, $@ =~ /^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 
    use warnings ;
    use strict ;
    use NDBM_File ;

    unlink <Op.dbmx*>;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
    
    ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
}

{
    # 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.

    use warnings ;
    use strict ;
    use NDBM_File ;

    unlink <Op.dbmx*>;
    my $bad_key = 0 ;
    my %h = () ;
    ok(66, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
    $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 ;

    ok(67, $h{'Alpha_ABC'} == 2);
    ok(68, $h{'Alpha_DEF'} == 5);

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

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

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

    undef $db ;
    untie %h ;
    unlink <Op.dbmx*>;
}


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

   use warnings ;
   use strict ;
   my %h ;
   unlink <Op.dbmx*>;

   ok(72, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;

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

   $_ = "original" ;

   $h{"fred"} = "joe" ;
   ok(73, $h{"fred"} eq "joe");

   eval { grep { $h{$_} } (1, 2, 3) };
   ok (74, ! $@);


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

   ok(75, $h{"fred"} eq "joe");

   ok(76, $db->FIRSTKEY() eq "fred") ;
   
   eval { grep { $h{$_} } (1, 2, 3) };
   ok (77, ! $@);

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