Move common code from ext/[GONS]DBM_File/t/[gons]dbm.t to t/lib/dbmt_common.pl

This eliminates 1445 lines, ie almost 500 lines duplicated fourfold.

6 files changed, 523 insertions, 1968 deletions

diff --git a/MANIFEST b/MANIFEST
index d5f41b35ab..e559e7ae15 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4516,6 +4516,7 @@ t/lib/commonsense.t		See if configuration meets basic needs
 t/lib/compmod.pl		Helper for 1_compile.t
 t/lib/croak.t			Test calls to Perl_croak() in the C source.
 t/lib/cygwin.t			Builtin cygwin function tests
+t/lib/dbmt_common.pl		Common functionality for ?DBM_File tests
 t/lib/deprecate/Deprecated.pm	Deprecated module to test deprecate.pm
 t/lib/deprecate/Optionally.pm	Optionally deprecated module to test deprecate.pm
 t/lib/deprecate.t		Test deprecate.pm
diff --git a/ext/GDBM_File/t/gdbm.t b/ext/GDBM_File/t/gdbm.t
index a071dd7fd3..af9dd3824a 100644
--- a/ext/GDBM_File/t/gdbm.t
+++ b/ext/GDBM_File/t/gdbm.t
@@ -1,495 +1,6 @@
 #!./perl
 
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+$::Create_and_Write = '(GDBM_WRCREAT, GDBM_WRITER)';
+our $DBM_Class = 'GDBM_File';
 
-our $DBM_Class;
-
-BEGIN {
-    $DBM_Class = 'GDBM_File';
-}
-
-BEGIN {
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
-	print "1..0 # Skip: $DBM_Class was not built\n";
-	exit 0;
-    }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 84;
-BEGIN {use_ok($DBM_Class)};
-
-unlink <Op_dbmx.*>;
-
-umask(0);
-my %h ;
-isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640), $DBM_Class);
-
-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, $DBM_Class, 'Op_dbmx', GDBM_WRITER, 0640), $DBM_Class);
-
-$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" ;
-   printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
-   package SubDB ;
-
-   use strict ;
-   use warnings ;
-   use vars qw(@ISA @EXPORT) ;
-
-   require Exporter ;
-   use %s;
-   @ISA=qw(%s);
-   @EXPORT = @%s::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 ; ';
-    main::is($@, "");
-    my %h ;
-    my $X ;
-    eval '
-	$X = tie(%h, "SubDB","dbhash_tmp", &GDBM_WRCREAT, 0640 );
-	' ;
-
-    main::is($@, "");
-
-    my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
-    main::is($@, "");
-    main::is($ret, 5);
-
-    $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
-    main::is($@, "");
-    main::is($ret, 1);
-
-    $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, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
-    isa_ok($db, $DBM_Class);
-
-    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, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640), $DBM_Class);
-    $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, $DBM_Class, 'Op_dbmx', GDBM_WRCREAT, 0640;
-    isa_ok($db, $DBM_Class);
-    $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, $DBM_Class, 'Op1_dbmx', GDBM_WRCREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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*>;
-}
+require '../../t/lib/dbmt_common.pl';
diff --git a/ext/NDBM_File/t/ndbm.t b/ext/NDBM_File/t/ndbm.t
index fb132f37a1..889b0c7dcb 100644
--- a/ext/NDBM_File/t/ndbm.t
+++ b/ext/NDBM_File/t/ndbm.t
@@ -1,494 +1,5 @@
 #!./perl
 
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'NDBM_File';
 
-our $DBM_Class;
-
-BEGIN {
-    $DBM_Class = 'NDBM_File';
-}
-
-BEGIN {
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
-	print "1..0 # Skip: $DBM_Class was not built\n";
-	exit 0;
-    }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 82;
-
-BEGIN {use_ok($DBM_Class)};
-#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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-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, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$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" ;
-   printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
-   package SubDB ;
-
-   use strict ;
-   use warnings ;
-   use vars qw(@ISA @EXPORT) ;
-
-   require Exporter ;
-   use %s;
-   @ISA=qw(%s);
-   @EXPORT = @%s::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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-
-    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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-    $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, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-    $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, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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*>;
-}
+require '../../t/lib/dbmt_common.pl';
diff --git a/ext/ODBM_File/t/odbm.t b/ext/ODBM_File/t/odbm.t
index 86072fd8e6..079b9f1f15 100644
--- a/ext/ODBM_File/t/odbm.t
+++ b/ext/ODBM_File/t/odbm.t
@@ -1,497 +1,8 @@
 #!./perl
 
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'ODBM_File';
 
-our $DBM_Class;
-
-BEGIN {
-    $DBM_Class = 'ODBM_File';
-}
-
-BEGIN {
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\b$DBM_Class\b/ or $Config{'d_cplusplus'}) {
-	print "1..0 # Skip: $DBM_Class was not built\n";
-	exit 0;
-    }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 82;
-
-BEGIN {use_ok($DBM_Class)};
-#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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-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, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$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" ;
-   printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
-   package SubDB ;
-
-   use strict ;
-   use warnings ;
-   use vars qw(@ISA @EXPORT) ;
-
-   require Exporter ;
-   use %s;
-   @ISA=qw(%s);
-   @EXPORT = @%s::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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-
-    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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-    $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, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-    $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, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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*>;
-}
+require '../../t/lib/dbmt_common.pl';
 
 if ($^O eq 'hpux') {
     print <<EOM;
diff --git a/ext/SDBM_File/t/sdbm.t b/ext/SDBM_File/t/sdbm.t
index abc30a0bf5..560d0bcee5 100644
--- a/ext/SDBM_File/t/sdbm.t
+++ b/ext/SDBM_File/t/sdbm.t
@@ -1,497 +1,5 @@
 #!./perl
 
-# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+our $DBM_Class = 'SDBM_File';
 
-our $DBM_Class;
-
-BEGIN {
-    $DBM_Class = 'SDBM_File';
-}
-
-BEGIN {
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\b$DBM_Class\b/) {
-	print "1..0 # Skip: $DBM_Class was not built\n";
-	exit 0;
-    }
-}
-
-use strict;
-use warnings;
-
-use Test::More tests => 84;
-
-BEGIN {use_ok($DBM_Class)};
-#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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-
-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, $DBM_Class, 'Op_dbmx', O_RDWR, 0640), $DBM_Class);
-
-$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');
-
-is(exists $h{goner1}, '');
-is(exists $h{foo}, 1);
-
-untie %h;
-unlink <Op_dbmx*>, $Dfile;
-
-{
-   # sub-class test
-
-   package Another ;
-
-   open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
-   printf FILE <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
-
-   package SubDB ;
-
-   use strict ;
-   use warnings ;
-   use vars qw(@ISA @EXPORT) ;
-
-   require Exporter ;
-   use %s;
-   @ISA=qw(%s);
-   @EXPORT = @%s::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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-
-    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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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, $DBM_Class, 'Op_dbmx', O_RDWR|O_CREAT, 0640), $DBM_Class);
-    $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, $DBM_Class,'Op_dbmx', O_RDWR|O_CREAT, 0640;
-    isa_ok($db, $DBM_Class);
-    $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, $DBM_Class, 'Op1_dbmx', O_RDWR|O_CREAT, 0640;
-   isa_ok($db, $DBM_Class);
-
-   $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*>;
-}
+require '../../t/lib/dbmt_common.pl';
diff --git a/t/lib/dbmt_common.pl b/t/lib/dbmt_common.pl
new file mode 100644
index 0000000000..268b0d68cb
--- /dev/null
+++ b/t/lib/dbmt_common.pl
@@ -0,0 +1,513 @@
+#!perl
+BEGIN {
+}
+
+use strict;
+use warnings;
+
+use Test::More;
+use Config;
+
+our $DBM_Class;
+
+my ($create, $write);
+BEGIN {
+    plan(skip_all => "$DBM_Class was not built")
+	unless $Config{extensions} =~ /\b$DBM_Class\b/;
+    plan(skip_all => "$DBM_Class not compatible with C++")
+	 if $DBM_Class eq 'ODBM_File' && $Config{d_cplusplus};
+
+    use_ok($DBM_Class);
+
+    if ($::Create_and_Write) {
+	($create, $write) = eval $::Create_and_Write;
+	isnt($create, undef, "(eval q{$::Create_and_Write})[0]");
+	isnt($write, undef, "(eval q{$::Create_and_Write})[1]");
+    } else {
+	#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+	use_ok('Fcntl');
+	$create = O_RDWR()|O_CREAT();
+	$write = O_RDWR();
+    }
+}
+
+unlink <Op_dbmx.*>;
+
+umask(0);
+my %h;
+isa_ok(tie(%h, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
+
+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, $DBM_Class, 'Op_dbmx', $write, 0640), $DBM_Class);
+
+$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');
+
+if($DBM_Class eq 'SDBM_File') {
+    is(exists $h{goner1}, '');
+    is(exists $h{foo}, 1);
+}
+
+untie %h;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+   # sub-class test
+
+   package Another;
+
+   open my $file, '>', 'SubDB.pm' or die "Cannot open SubDB.pm: $!\n";
+   printf $file <<'EOM', $DBM_Class, $DBM_Class, $DBM_Class;
+
+   package SubDB;
+
+   use strict;
+   use warnings;
+   use vars qw(@ISA @EXPORT);
+
+   require Exporter;
+   use %s;
+   @ISA=qw(%s);
+   @EXPORT = @%s::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*>;
+
+    main::use_ok('SubDB');
+    my %h;
+    my $X;
+    eval '
+	$X = tie(%h, "SubDB", "dbhash_tmp", $create, 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]]");
+
+    if ($DBM_Class eq 'GDBM_File') {
+        $ret = eval 'GDBM_WRCREAT eq main::GDBM_WRCREAT';
+        main::is($@, "");
+        main::is($ret, 1);
+    }
+
+    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, $DBM_Class, 'Op_dbmx', $create, 0640;
+   isa_ok($db, $DBM_Class);
+
+   $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, $DBM_Class, 'Op_dbmx', $create, 0640;
+    isa_ok($db, $DBM_Class);
+
+    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, $DBM_Class, 'Op_dbmx', $create, 0640;
+   isa_ok($db, $DBM_Class);
+
+   $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, $DBM_Class, 'Op_dbmx', $create, 0640), $DBM_Class);
+    $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, $DBM_Class, 'Op_dbmx', $create, 0640;
+    isa_ok($db, $DBM_Class);
+    $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, $DBM_Class, 'Op1_dbmx', $create, 0640;
+   isa_ok($db, $DBM_Class);
+
+   $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*>;
+}
+
+done_testing();
+1;