From: Paul Marquess Date: Thu, 17 Jul 1997 10:47:30 +0000 (+1200) Subject: DB_File 1.15 patch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a6ed719b27c92569338047d45a029ec503c5d762;p=p5sagit%2Fp5-mst-13.2.git DB_File 1.15 patch This patch for DB_File fixes a few minor bugs and adds the sub-class patch. Patch from Gisle Aas to suppress "use of undefined value" warning with db_get and db_seq. Patch from Gisle Aas to make DB_File export only the O_* constants from Fcntl. Removed the DESTROY method from the DB_File::HASHINFO module. Previously DB_File hard-wired the class name of any object that it created to "DB_File". This makes sub-classing difficult. Now DB_File creats objects in the namespace of the package it has been inherited into. p5p-msgid: 9707192117.AA01973@claudius.bfsec.bt.co.uk --- diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 2d5e744..df1593f 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 30th Apr 1997 -# version 1.14 +# last modified 29th Jun 1997 +# version 1.15 # # Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -98,7 +98,6 @@ sub NotHere croak ref($self) . " does not define the method ${method}" ; } -sub DESTROY { undef %{$_[0]} } sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } @@ -146,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ; use Carp; -$VERSION = "1.14" ; +$VERSION = "1.15" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -212,17 +211,13 @@ sub AUTOLOAD { } -# import borrowed from IO::File -# exports Fcntl constants if available. -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export $pkg, $callpkg, @_; - eval { - require Fcntl; - Exporter::export 'Fcntl', $callpkg, '/^O_/'; - }; -} +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; bootstrap DB_File $VERSION; @@ -1666,6 +1661,21 @@ Minor changes to DB_FIle.xs and DB_File.pm Made it illegal to tie an associative array to a RECNO database and an ordinary array to a HASH or BTREE database. +=item 1.15 + +Patch from Gisle Aas to suppress "use of undefined +value" warning with db_get and db_seq. + +Patch from Gisle Aas to make DB_File export only the O_* +constants from Fcntl. + +Removed the DESTROY method from the DB_File::HASHINFO module. + +Previously DB_File hard-wired the class name of any object that it +created to "DB_File". This makes sub-classing difficult. Now DB_File +creats objects in the namespace of the package it has been inherited +into. + =back =head1 BUGS diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 8d01d91..d2c7e6c 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 30th Apr 1997 - version 1.14 + last modified 29th Jun 1997 + version 1.15 All comments/suggestions/problems are welcome @@ -42,6 +42,9 @@ 1.13 - Tidied up a few casts. 1.14 - Made it illegal to tie an associative array to a RECNO database and an ordinary array to a HASH or BTREE database. + 1.15 - Patch from Gisle Aas to suppress "use of + undefined value" warning with db_get and db_seq. + */ @@ -50,6 +53,9 @@ #include "XSUB.h" #include +/* #ifdef DB_VERSION_MAJOR */ +/* #include */ +/* #endif */ #include @@ -87,7 +93,7 @@ typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; -/* #define TRACE */ +/* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) @@ -1062,7 +1068,7 @@ int db_get(db, key, value, flags=0) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; @@ -1098,7 +1104,7 @@ int db_seq(db, key, value, flags) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 5ca9c54..a621224 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -34,3 +34,5 @@ T_dbtkeydatum OutputKey($arg, $var) T_dbtdatum OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index c90c9d7..bebb63d 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..92\n"; +print "1..102\n"; sub ok { @@ -91,7 +91,7 @@ ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); +ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; @@ -513,4 +513,96 @@ unlink $Dfile1 ; unlink $filename ; } + +{ + # 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 DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_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 put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + 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(93, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(94, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(97, $@ eq "") ; + main::ok(98, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(99, $@ eq "" ) ; + main::ok(100, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(101, $@ eq "") ; + main::ok(102, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 471ee02..9df918c 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..52\n"; +print "1..62\n"; sub ok { @@ -70,7 +70,7 @@ ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); +ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; @@ -320,4 +320,95 @@ untie %h ; unlink $filename ; } +{ + # 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 DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_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 put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + 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(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "dbhash.tmp" ; + +} + exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 338edd0..9950741 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -41,7 +41,7 @@ sub bad_one EOM } -print "1..56\n"; +print "1..66\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -93,7 +93,7 @@ my $X ; my @h ; ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; -ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) +ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos') ; #my $l = @h ; @@ -198,6 +198,17 @@ untie(@h); unlink $Dfile; +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = ; + close(CAT); + return $result; +} + + { # Check bval defaults to \n @@ -208,7 +219,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; ok(49, $x eq "abc\ndef\n\nghi\n") ; } @@ -224,7 +235,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc-def--ghi-") ; bad_one() unless $ok ; @@ -243,7 +254,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc def ghi ") ; bad_one() unless $ok ; @@ -263,7 +274,7 @@ unlink $Dfile; $h[1] = "def" ; $h[3] = "ghi" ; untie @h ; - my $x = `cat $Dfile` ; + my $x = docat($Dfile) ; unlink $Dfile; my $ok = ($x eq "abc--def-------ghi--") ; bad_one() unless $ok ; @@ -280,4 +291,95 @@ unlink $Dfile; unlink $filename ; } +{ + # 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 DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_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 put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + 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(57, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + + main::ok(58, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(59, $@ eq "") ; + main::ok(60, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(63, $@ eq "" ) ; + main::ok(64, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(65, $@ eq "") ; + main::ok(66, $ret eq "[[11]]") ; + + unlink "SubDB.pm", "recno.tmp" ; + +} + exit ;