[perl5.git] / t / lib / sdbm.t

#!./perl

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

BEGIN {
    chdir 't' if -d 't';
    unshift @INC, '../lib';
    require Config; import Config;
    if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
	print "1..0\n";
	exit 0;
    }
}
require SDBM_File;
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;

print "1..66\n";

unlink <Op_dbmx.*>;

umask(0);
print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
       ? "ok 1\n" : "not ok 1\n");

$Dfile = "Op_dbmx.pag";
if (! -e $Dfile) {
	($Dfile) = <Op_dbmx.*>;
}
if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
    print "ok 2 # Skipped: different file permission semantics\n";
}
else {
    ($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");
}
while (($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,SDBM_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'};

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

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

while (($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
$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");

($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;
@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");


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

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

{
   # sub-class test

   package Another ;

   use strict ;

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

   package SubDB ;

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

   require Exporter ;
   use SDBM_File;
   @ISA=qw(SDBM_File);
   @EXPORT = @SDBM_File::EXPORT if defined @SDBM_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.*> ;

}

ok(19, !exists $h{'goner1'});
ok(20, exists $h{'foo'});

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

{
   # DBM Filter tests
   use strict ;
   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(21, $db = tie(%h, 'SDBM_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(22, checkOutput( "", "fred", "", "joe")) ;

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

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

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

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

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

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

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

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

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

{    
    # DBM Filter with a closure

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

    unlink <Op_dbmx*>;
    ok(42, $db = tie(%h, 'SDBM_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(43, $result{"store key"} eq "store key - 1: [fred]");
    ok(44, $result{"store value"} eq "store value - 1: [joe]");
    ok(45, !defined $result{"fetch key"} );
    ok(46, !defined $result{"fetch value"} );
    ok(47, $_ eq "original") ;

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

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

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

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

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

   ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;

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

   eval '$h{1} = 1234' ;
   ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
   
   undef $db ;
   untie %h;
   unlink <Op_dbmx*>;
}
Commit	Line	Data
a687059c LW	1	#!./perl
a687059c LW	2
79072805	3	# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
a687059c	4
85e6fe83	5	BEGIN {
a0d0e21e	6	chdir 't' if -d 't';
93430cb4	7	unshift @INC, '../lib';
85e6fe83	8	require Config; import Config;
bf99883d	9	if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
a0d0e21e	10	print "1..0\n";
85e6fe83 LW	11	exit 0;
	12	}
	13	}
8990e307	14	require SDBM_File;
a0d0e21e LW	15	#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR\|O_CREAT
a0d0e21e LW	16	use Fcntl;
a687059c	17
9fe6733a	18	print "1..66\n";
a687059c	19
bf99883d	20	unlink <Op_dbmx.*>;
79072805	21
a687059c	22	umask(0);
bf99883d	23	print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR\|O_CREAT, 0640)
544a3566	24	? "ok 1\n" : "not ok 1\n");
79072805	25
bf99883d	26	$Dfile = "Op_dbmx.pag";
79072805	27	if (! -e $Dfile) {
bf99883d	28	($Dfile) = <Op_dbmx.*>;
79072805	29	}
39e571d4	30	if ($^O eq 'amigaos' \|\| $^O eq 'os2' \|\| $^O eq 'MSWin32' \|\| $^O eq 'dos') {
fac76ed7	31	print "ok 2 # Skipped: different file permission semantics\n";
544a3566 CS	32	}
	33	else {
	34	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
	35	$blksize,$blocks) = stat($Dfile);
	36	print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
	37	}
463ee0b2	38	while (($key,$value) = each(%h)) {
a687059c LW	39	$i++;
	40	}
	41	print (!$i ? "ok 3\n" : "not ok 3\n");
	42
	43	$h{'goner1'} = 'snork';
	44
	45	$h{'abc'} = 'ABC';
	46	$h{'def'} = 'DEF';
	47	$h{'jkl','mno'} = "JKL\034MNO";
	48	$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
	49	$h{'a'} = 'A';
	50	$h{'b'} = 'B';
	51	$h{'c'} = 'C';
	52	$h{'d'} = 'D';
	53	$h{'e'} = 'E';
	54	$h{'f'} = 'F';
	55	$h{'g'} = 'G';
	56	$h{'h'} = 'H';
	57	$h{'i'} = 'I';
	58
	59	$h{'goner2'} = 'snork';
	60	delete $h{'goner2'};
	61
463ee0b2	62	untie(%h);
bf99883d	63	print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
a687059c LW	64
	65	$h{'j'} = 'J';
	66	$h{'k'} = 'K';
	67	$h{'l'} = 'L';
	68	$h{'m'} = 'M';
	69	$h{'n'} = 'N';
	70	$h{'o'} = 'O';
	71	$h{'p'} = 'P';
	72	$h{'q'} = 'Q';
	73	$h{'r'} = 'R';
	74	$h{'s'} = 'S';
	75	$h{'t'} = 'T';
	76	$h{'u'} = 'U';
	77	$h{'v'} = 'V';
	78	$h{'w'} = 'W';
	79	$h{'x'} = 'X';
	80	$h{'y'} = 'Y';
	81	$h{'z'} = 'Z';
	82
	83	$h{'goner3'} = 'snork';
	84
	85	delete $h{'goner1'};
	86	delete $h{'goner3'};
	87
	88	@keys = keys(%h);
	89	@values = values(%h);
	90
	91	if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
	92
c6aa4a32	93	while (($key,$value) = each(%h)) {
2f52a358	94	if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
a687059c LW	95	$key =~ y/a-z/A-Z/;
	96	$i++ if $key eq $value;
	97	}
	98	}
	99
	100	if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
	101
c6aa4a32	102	@keys = ('blurfl', keys(%h), 'dyick');
a687059c LW	103	if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
a687059c LW	104
fe14fcc3 LW	105	$h{'foo'} = '';
	106	$h{''} = 'bar';
	107
a687059c LW	108	# check cache overflow and numeric keys and contents
	109	$ok = 1;
	110	for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
	111	for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
	112	print ($ok ? "ok 8\n" : "not ok 8\n");
	113
	114	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
79072805	115	$blksize,$blocks) = stat($Dfile);
a687059c LW	116	print ($size > 0 ? "ok 9\n" : "not ok 9\n");
a687059c LW	117
0f85fab0 LW	118	@h{0..200} = 200..400;
0f85fab0 LW	119	@foo = @h{0..200};
fe14fcc3 LW	120	print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
	121
	122	print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
	123	print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
0f85fab0	124
4e2a63a7 PM	125
	126	sub ok
	127	{
	128	my $no = shift ;
	129	my $result = shift ;
	130
	131	print "not " unless $result ;
	132	print "ok $no\n" ;
	133	}
	134
	135	{
	136	# sub-class test
	137
	138	package Another ;
	139
	140	use strict ;
	141
	142	open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
	143	print FILE <<'EOM' ;
	144
	145	package SubDB ;
	146
	147	use strict ;
	148	use vars qw( @ISA @EXPORT) ;
	149
	150	require Exporter ;
	151	use SDBM_File;
	152	@ISA=qw(SDBM_File);
	153	@EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ;
	154
	155	sub STORE {
	156	my $self = shift ;
	157	my $key = shift ;
	158	my $value = shift ;
	159	$self->SUPER::STORE($key, $value * 2) ;
	160	}
	161
	162	sub FETCH {
	163	my $self = shift ;
	164	my $key = shift ;
	165	$self->SUPER::FETCH($key) - 1 ;
	166	}
	167
	168	sub A_new_method
	169	{
	170	my $self = shift ;
	171	my $key = shift ;
	172	my $value = $self->FETCH($key) ;
	173	return "[[$value]]" ;
	174	}
	175
	176	1 ;
	177	EOM
	178
	179	close FILE ;
	180
	181	BEGIN { push @INC, '.'; }
	182
	183	eval 'use SubDB ; use Fcntl ;';
	184	main::ok(13, $@ eq "") ;
	185	my %h ;
	186	my $X ;
	187	eval '
bf99883d	188	$X = tie(%h, "SubDB","dbhash_tmp", O_RDWR\|O_CREAT, 0640 );
4e2a63a7 PM	189	' ;
	190
	191	main::ok(14, $@ eq "") ;
	192
	193	my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
	194	main::ok(15, $@ eq "") ;
	195	main::ok(16, $ret == 5) ;
	196
	197	$ret = eval '$X->A_new_method("fred") ' ;
	198	main::ok(17, $@ eq "") ;
	199	main::ok(18, $ret eq "[[5]]") ;
	200
fac76ed7 MB	201	undef $X;
fac76ed7 MB	202	untie(%h);
bf99883d	203	unlink "SubDB.pm", <dbhash_tmp.*> ;
4e2a63a7 PM	204
4e2a63a7 PM	205	}
f4b9d880 RA	206
	207	ok(19, !exists $h{'goner1'});
	208	ok(20, exists $h{'foo'});
	209
	210	untie %h;
9fe6733a PM	211	unlink <Op_dbmx*>, $Dfile;
	212
	213	{
	214	# DBM Filter tests
	215	use strict ;
	216	my (%h, $db) ;
	217	my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	218
	219	sub checkOutput
	220	{
	221	my($fk, $sk, $fv, $sv) = @_ ;
	222	return
	223	$fetch_key eq $fk && $store_key eq $sk &&
	224	$fetch_value eq $fv && $store_value eq $sv &&
	225	$_ eq 'original' ;
	226	}
	227
	228	unlink <Op_dbmx*>;
	229	ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR\|O_CREAT, 0640)) ;
	230
	231	$db->filter_fetch_key (sub { $fetch_key = $_ }) ;
	232	$db->filter_store_key (sub { $store_key = $_ }) ;
	233	$db->filter_fetch_value (sub { $fetch_value = $_}) ;
	234	$db->filter_store_value (sub { $store_value = $_ }) ;
	235
	236	$_ = "original" ;
	237
	238	$h{"fred"} = "joe" ;
	239	# fk sk fv sv
	240	ok(22, checkOutput( "", "fred", "", "joe")) ;
	241
	242	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	243	ok(23, $h{"fred"} eq "joe");
	244	# fk sk fv sv
	245	ok(24, checkOutput( "", "fred", "joe", "")) ;
	246
	247	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	248	ok(25, $db->FIRSTKEY() eq "fred") ;
	249	# fk sk fv sv
	250	ok(26, checkOutput( "fred", "", "", "")) ;
	251
	252	# replace the filters, but remember the previous set
	253	my ($old_fk) = $db->filter_fetch_key
	254	(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
	255	my ($old_sk) = $db->filter_store_key
	256	(sub { $_ = lc $_ ; $store_key = $_ }) ;
	257	my ($old_fv) = $db->filter_fetch_value
	258	(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
	259	my ($old_sv) = $db->filter_store_value
	260	(sub { s/o/x/g; $store_value = $_ }) ;
	261
	262	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	263	$h{"Fred"} = "Joe" ;
	264	# fk sk fv sv
	265	ok(27, checkOutput( "", "fred", "", "Jxe")) ;
	266
	267	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	268	ok(28, $h{"Fred"} eq "[Jxe]");
	269	# fk sk fv sv
	270	ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
	271
	272	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
	273	ok(30, $db->FIRSTKEY() eq "FRED") ;
	274	# fk sk fv sv
275	ok(31, checkOutput( "FRED", "", "", "")) ;
276
277	# put the original filters back
278	$db->filter_fetch_key ($old_fk);
279	$db->filter_store_key ($old_sk);
280	$db->filter_fetch_value ($old_fv);
281	$db->filter_store_value ($old_sv);
282
283	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
284	$h{"fred"} = "joe" ;
285	ok(32, checkOutput( "", "fred", "", "joe")) ;
286
287	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
288	ok(33, $h{"fred"} eq "joe");
289	ok(34, checkOutput( "", "fred", "joe", "")) ;
290
291	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
292	ok(35, $db->FIRSTKEY() eq "fred") ;
293	ok(36, checkOutput( "fred", "", "", "")) ;
294
295	# delete the filters
296	$db->filter_fetch_key (undef);
297	$db->filter_store_key (undef);
298	$db->filter_fetch_value (undef);
299	$db->filter_store_value (undef);
300
301	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
302	$h{"fred"} = "joe" ;
303	ok(37, checkOutput( "", "", "", "")) ;
304
305	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
306	ok(38, $h{"fred"} eq "joe");
307	ok(39, checkOutput( "", "", "", "")) ;
308
309	($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
310	ok(40, $db->FIRSTKEY() eq "fred") ;
311	ok(41, checkOutput( "", "", "", "")) ;
312
313	undef $db ;
314	untie %h;
315	unlink <Op_dbmx*>;
316	}
317
318	{
319	# DBM Filter with a closure
320
321	use strict ;
322	my (%h, $db) ;
323
324	unlink <Op_dbmx*>;
325	ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR\|O_CREAT, 0640)) ;
326
327	my %result = () ;
328
329	sub Closure
330	{
331	my ($name) = @_ ;
332	my $count = 0 ;
333	my @kept = () ;
334
335	return sub { ++$count ;
336	push @kept, $_ ;
337	$result{$name} = "$name - $count: [@kept]" ;
338	}
339	}
340
341	$db->filter_store_key(Closure("store key")) ;
342	$db->filter_store_value(Closure("store value")) ;
343	$db->filter_fetch_key(Closure("fetch key")) ;
344	$db->filter_fetch_value(Closure("fetch value")) ;
345
346	$_ = "original" ;
347
348	$h{"fred"} = "joe" ;
349	ok(43, $result{"store key"} eq "store key - 1: [fred]");
350	ok(44, $result{"store value"} eq "store value - 1: [joe]");
351	ok(45, !defined $result{"fetch key"} );
352	ok(46, !defined $result{"fetch value"} );
353	ok(47, $_ eq "original") ;
354
355	ok(48, $db->FIRSTKEY() eq "fred") ;
356	ok(49, $result{"store key"} eq "store key - 1: [fred]");
357	ok(50, $result{"store value"} eq "store value - 1: [joe]");
358	ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
359	ok(52, ! defined $result{"fetch value"} );
360	ok(53, $_ eq "original") ;
361
362	$h{"jim"} = "john" ;
363	ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
364	ok(55, $result{"store value"} eq "store value - 2: [joe john]");
365	ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
366	ok(57, $result{"fetch value"} eq "");
367	ok(58, $_ eq "original") ;
368
369	ok(59, $h{"fred"} eq "joe");
370	ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
371	ok(61, $result{"store value"} eq "store value - 2: [joe john]");
372	ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
373	ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
374	ok(64, $_ eq "original") ;
375
376	undef $db ;
377	untie %h;
378	unlink <Op_dbmx*>;
379	}
380
381	{
382	# DBM Filter recursion detection
383	use strict ;
384	my (%h, $db) ;
385	unlink <Op_dbmx*>;
386
387	ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR\|O_CREAT, 0640)) ;
388
389	$db->filter_store_key (sub { $_ = $h{$_} }) ;
390
391	eval '$h{1} = 1234' ;
392	ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
393
394	undef $db ;
395	untie %h;
396	unlink <Op_dbmx*>;
f4b9d880	397	}
9fe6733a	398