PATCH: make DBM*_File modules sub-classable

Here is a patch to make the DBM*_File modules sub-classable.

The sub-class patch for DB_File will be along presently.

p5p-msgid: 9707121854.AA19472@claudius.bfsec.bt.co.uk

diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap
index a6b0e5f..a9b73d8 100644 (file)
--- a/ext/GDBM_File/typemap
+++ b/ext/GDBM_File/typemap
@@ -23,3 +23,5 @@ T_DATUM
        sv_setpvn($arg, $var.dptr, $var.dsize);
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+        sv_setref_pv($arg, dbtype, (void*)$var);

diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap
index a6b0e5f..a9b73d8 100644 (file)
--- a/ext/NDBM_File/typemap
+++ b/ext/NDBM_File/typemap
@@ -23,3 +23,5 @@ T_DATUM
        sv_setpvn($arg, $var.dptr, $var.dsize);
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+        sv_setref_pv($arg, dbtype, (void*)$var);

diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index d23b318..b57e560 100644 (file)
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -73,7 +73,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
            }
            RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
            ST(0) = sv_mortalcopy(&sv_undef);
-           sv_setptrobj(ST(0), RETVAL, "ODBM_File");
+           sv_setptrobj(ST(0), RETVAL, dbtype);
        }
 
 void

diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap
index a6b0e5f..a9b73d8 100644 (file)
--- a/ext/SDBM_File/typemap
+++ b/ext/SDBM_File/typemap
@@ -23,3 +23,5 @@ T_DATUM
        sv_setpvn($arg, $var.dptr, $var.dsize);
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+        sv_setref_pv($arg, dbtype, (void*)$var);

diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t
index a0f081f..2d5e897 100755 (executable)
--- a/t/lib/gdbm.t
+++ b/t/lib/gdbm.t
@@ -13,7 +13,7 @@ BEGIN {
 
 use GDBM_File;
 
-print "1..12\n";
+print "1..20\n";
 
 unlink <Op.dbmx*>;
 
@@ -121,3 +121,86 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
 
 untie %h;
 unlink 'Op.dbmx.dir', $Dfile;
+
+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 GDBM_File;
+   @ISA=qw(GDBM_File);
+   @EXPORT = @GDBM_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 ; ';
+    main::ok(13, $@ eq "") ;
+    my %h ;
+    my $X ;
+    eval '
+       $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 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 ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
+    main::ok(17, $@ eq "" ) ;
+    main::ok(18, $ret == 1) ;
+
+    $ret = eval '$X->A_new_method("fred") ' ;
+    main::ok(19, $@ eq "") ;
+    main::ok(20, $ret eq "[[5]]") ;
+
+    unlink "SubDB.pm", "dbhash.tmp" ;
+
+}

diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t
index b10d7c2..5fed98d 100755 (executable)
--- a/t/lib/ndbm.t
+++ b/t/lib/ndbm.t
@@ -16,7 +16,7 @@ require NDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..12\n";
+print "1..18\n";
 
 unlink <Op.dbmx*>;
 
@@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
 
 untie %h;
 unlink 'Op.dbmx.dir', $Dfile;
+
+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 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]]") ;
+
+    unlink "SubDB.pm", "dbhash.tmp" ;
+
+}

diff --git a/t/lib/odbm.t b/t/lib/odbm.t
index 06ba844..a7a4e69 100755 (executable)
--- a/t/lib/odbm.t
+++ b/t/lib/odbm.t
@@ -16,7 +16,7 @@ require ODBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..12\n";
+print "1..18\n";
 
 unlink <Op.dbmx*>;
 
@@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
 
 untie %h;
 unlink 'Op.dbmx.dir', $Dfile;
+
+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 ODBM_File;
+   @ISA=qw(ODBM_File);
+   @EXPORT = @ODBM_File::EXPORT ;
+
+   sub STORE { 
+       my $self = shift ;
+        my $key = shift ;
+        my $value = shift ;
+        $self->SUPER::STORE($key, $value * 2) ;
+   }
+
+   sub FETCH { 
+       my $self = shift ;
+        my $key = shift ;
+        $self->SUPER::FETCH($key) - 1 ;
+   }
+
+   sub A_new_method
+   {
+       my $self = shift ;
+        my $key = shift ;
+        my $value = $self->FETCH($key) ;
+       return "[[$value]]" ;
+   }
+
+   1 ;
+EOM
+
+    close FILE ;
+
+    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]]") ;
+
+    unlink "SubDB.pm", "dbhash.tmp" ;
+
+}

diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t
index 9928847..576d0fe 100755 (executable)
--- a/t/lib/sdbm.t
+++ b/t/lib/sdbm.t
@@ -15,7 +15,7 @@ require SDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..12\n";
+print "1..18\n";
 
 unlink <Op.dbmx*>;
 
@@ -124,3 +124,82 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
 
 untie %h;
 unlink 'Op.dbmx.dir', $Dfile;
+
+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]]") ;
+
+    unlink "SubDB.pm", "dbhash.tmp" ;
+
+}