From 4e2a63a79975e6f132b1e2902946589b4ad25bb6 Mon Sep 17 00:00:00 2001 From: Paul Marquess Date: Fri, 11 Jul 1997 22:01:43 +1200 Subject: [PATCH] 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 --- ext/GDBM_File/typemap | 2 ++ ext/NDBM_File/typemap | 2 ++ ext/ODBM_File/ODBM_File.xs | 2 +- ext/SDBM_File/typemap | 2 ++ t/lib/gdbm.t | 85 +++++++++++++++++++++++++++++++++++++++++++++- t/lib/ndbm.t | 81 ++++++++++++++++++++++++++++++++++++++++++- t/lib/odbm.t | 81 ++++++++++++++++++++++++++++++++++++++++++- t/lib/sdbm.t | 81 ++++++++++++++++++++++++++++++++++++++++++- 8 files changed, 331 insertions(+), 5 deletions(-) diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index a6b0e5f..a9b73d8 100644 --- 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 --- 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 --- 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 --- 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 --- 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 ; @@ -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 --- 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 ; @@ -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 --- 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 ; @@ -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 --- 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 ; @@ -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" ; + +} -- 2.7.4