DB_File 1.58 patch

p4raw-id: //depot/perl@506

5 files changed, 333 insertions, 46 deletions

diff --git a/MANIFEST b/MANIFEST
index 68708c132a..88c6092417 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -120,6 +120,7 @@ emacs/ptags		Creates smart TAGS file
 embed.h			Maps symbols to safer names
 embed.pl		Produces embed.h
 embedvar.h		C namespace management
+ext/DB_File/Changes		Berkeley DB extension change log
 ext/DB_File/DB_File.pm		Berkeley DB extension Perl module
 ext/DB_File/DB_File.xs		Berkeley DB extension external subroutines
 ext/DB_File/DB_File_BS		Berkeley DB extension mkbootstrap fodder
diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
new file mode 100644
index 0000000000..a86ea4a26d
--- /dev/null
+++ b/ext/DB_File/Changes
@@ -0,0 +1,194 @@
+
+0.1
+
+    First Release.
+
+0.2
+
+    When DB_File is opening a database file it no longer terminates the
+    process if dbopen returned an error. This allows file protection
+    errors to be caught at run time. Thanks to Judith Grass
+    <grass@cybercash.com> for spotting the bug.
+
+0.3
+
+    Added prototype support for multiple btree compare callbacks.
+
+1.0
+
+    DB_File has been in use for over a year. To reflect that, the
+    version number has been incremented to 1.0.
+
+    Added complete support for multiple concurrent callbacks.
+
+    Using the push method on an empty list didn't work properly. This
+    has been fixed.
+
+1.01
+
+    Fixed a core dump problem with SunOS.
+
+    The return value from TIEHASH wasn't set to NULL when dbopen
+    returned an error.
+
+1.02
+
+    Merged OS/2 specific code into DB_File.xs
+
+    Removed some redundant code in DB_File.xs.
+
+    Documentation update.
+
+    Allow negative subscripts with RECNO interface.
+
+    Changed the default flags from O_RDWR to O_CREAT|O_RDWR.
+
+    The example code which showed how to lock a database needed a call
+    to sync added. Without it the resultant database file was empty.
+
+    Added get_dup method.
+
+1.03
+
+    Documentation update.
+
+    DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl
+    automatically.
+
+    The standard hash function exists is now supported.
+
+    Modified the behavior of get_dup. When it returns an associative
+    array, the value is the count of the number of matching BTREE
+    values.
+
+1.04
+
+    Minor documentation changes.
+
+    Fixed a bug in hash_cb. Patches supplied by Dave Hammen,
+    <hammen@gothamcity.jsc.nasa.govt>.
+
+    Fixed a bug with the constructors for DB_File::HASHINFO,
+    DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the
+    constructors to make them -w clean.
+
+    Reworked part of the test harness to be more locale friendly.
+
+1.05
+
+    Made all scripts in the documentation strict and -w clean.
+
+    Added logic to DB_File.xs to allow the module to be built after
+    Perl is installed.
+
+1.06
+
+    Minor namespace cleanup: Localized PrintBtree.
+
+1.07
+
+    Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+
+1.08
+
+    Documented operation of bval.
+
+1.09
+
+    Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and
+    DB_File::BTREEINFO.
+
+    Changed default mode to 0666.
+
+1.10
+
+    Fixed fd method so that it still returns -1 for in-memory files
+    when db 1.86 is used.
+
+1.11
+
+    Documented the untie gotcha.
+
+1.12
+
+    Documented the incompatibility with version 2 of Berkeley DB.
+
+1.13
+
+    Minor changes to DB_FIle.xs and DB_File.pm
+
+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 <gisle@aas.no> to suppress "use of undefined
+    value" warning with db_get and db_seq.
+
+    Patch from Gisle Aas <gisle@aas.no> 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.
+
+
+1.16
+
+   A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5
+
+    Small fix for the AIX strict C compiler XLC which doesn't like
+    __attribute__ being defined via proto.h and redefined via db.h. Fix
+    courtesy of Jarkko Hietaniemi.
+
+1.50
+
+    DB_File can now build with either DB 1.x or 2.x, but not both at
+    the same time.
+
+1.51
+
+    Fixed the test harness so that it doesn't expect DB_File to have
+    been installed by the main Perl build.
+
+
+    Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
+
+1.52
+
+   Patch from Nick Ing-Simmons now allows DB_File to build on NT.
+   Merged 1.15 patch.
+
+1.53
+
+   Added DB_RENUMBER to flags for recno.
+
+1.54
+
+   Fixed a small bug in the test harness when run under win32
+   The emulation of fd when useing DB 2.x was busted.
+
+1.55
+   Merged 1.16 changes.
+
+1.56
+   Documented the Solaris 2.5 mutex bug
+
+1.57
+   If Perl has been compiled with Threads support,the symbol op will be
+   defined. This clashes with a field name in db.h, so it needs to be
+   #undef'ed before db.h is included.
+
+1.58
+   Tied Array support was enhanced in Perl 5.004_57. DB_File now
+   supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE.
+
+   Fixed a problem with the use of sv_setpvn. When the size is
+   specified as 0, it does a strlen on the data.  This was ok for DB
+   1.x, but isn't for DB 2.x.
+
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index 812464361a..95e0a5599f 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 20th Nov 1997
-# version 1.56
+# last modified 20th Dec 1997
+# version 1.57
 #
 #     Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -106,7 +106,7 @@ package DB_File::RECNOINFO ;
 
 use strict ;
 
-@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;  
+@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
 
 sub TIEHASH
 {
@@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver
 use Carp;
 
 
-$VERSION = "1.56" ;
+$VERSION = "1.58" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -189,9 +189,7 @@ require DynaLoader;
 	R_SNAPSHOT
 	__R_UNUSED
 
-);  
-
-*FETCHSIZE = \&length;
+);
 
 sub AUTOLOAD {
     my($constname);
@@ -267,7 +265,8 @@ sub TIEARRAY
     tie_hash_or_array(@_) ;
 }
 
-sub CLEAR {
+sub CLEAR 
+{
     my $self = shift;
     my $key = "" ;
     my $value = "" ;
@@ -283,6 +282,23 @@ sub CLEAR {
     }
 }
 
+sub EXTEND { }
+
+sub STORESIZE
+{
+    my $self = shift;
+    my $length = shift ;
+    my $current_length = $self->length() ;
+
+    if ($length < $current_length) {
+	my $key ;
+        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
+	  { $self->del($key) }
+    }
+    elsif ($length > $current_length)
+        { $self->put($length-1, "") }
+}
+ 
 sub get_dup
 {
     croak "Usage: \$db->get_dup(key [,flag])\n"
@@ -1022,11 +1038,15 @@ Here is the output from the script:
 
 =head2 Extra Methods
 
-As you can see from the example above, the tied array interface is
-quite limited. To make the interface more useful, a number of methods
-are supplied with B<DB_File> to simulate the standard array operations
-that are not currently implemented in Perl's tied array interface. All
-these methods are accessed via the object returned from the tie call.
+If you are using a version of Perl earlier than 5.004_57, the tied
+array interface is quite limited. The example script above will work,
+but you won't be able to use C<push>, C<pop>, C<shift>, C<unshift>
+etc. with the tied array.
+
+To make the interface more useful for older versions of Perl, a number
+of methods are supplied with B<DB_File> to simulate the missing array
+operations. All these methods are accessed via the object returned from
+the tie call.
 
 Here are the methods:
 
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index 8f2eda10b0..91b4dc2ad5 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -3,12 +3,12 @@
  DB_File.xs -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 20th Nov 1997
- version 1.56
+ last modified 2nd Feb 1998
+ version 1.58
 
  All comments/suggestions/problems are welcome
 
-     Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
+     Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved.
      This program is free software; you can redistribute it and/or
      modify it under the same terms as Perl itself.
 
@@ -50,6 +50,10 @@
 	1.54 -  Fixed bug in the fd method
         1.55 -  Fix for AIX from Jarkko Hietaniemi
         1.56 -  No change to DB_File.xs
+        1.57 -  added the #undef op to allow building with Threads support.
+	1.58 -  Fixed a problem with the use of sv_setpvn. When the
+		size is specified as 0, it does a strlen on the data.
+		This was ok for DB 1.x, but isn't for DB 2.x.
 
 
 
@@ -65,6 +69,12 @@
 
 #undef __attribute__
 
+/* If Perl has been compiled with Threads support,the symbol op will
+   be defined here. This clashes with a field name in db.h, so get rid of it.
+ */
+#ifdef op
+#undef op
+#endif
 #include <db.h>
 
 #include <fcntl.h> 
@@ -238,10 +248,11 @@ typedef struct {
 typedef DB_File_type * DB_File ;
 typedef DBT DBTKEY ;
 
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
 
 #define OutputValue(arg, name)  				\
 	{ if (RETVAL == 0) {					\
-	      sv_setpvn(arg, name.data, name.size) ;		\
+	      my_sv_setpvn(arg, name.data, name.size) ;		\
 	  }							\
 	}
 
@@ -249,13 +260,14 @@ typedef DBT DBTKEY ;
 	{ if (RETVAL == 0) 					\
 	  { 							\
 		if (db->type != DB_RECNO) {			\
-		    sv_setpvn(arg, name.data, name.size); 	\
+		    my_sv_setpvn(arg, name.data, name.size); 	\
 		}						\
 		else 						\
 		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 	\
 	  } 							\
 	}
 
+
 /* Internal Global Data */
 static recno_t Value ; 
 static recno_t zero = 0 ;
@@ -560,13 +572,12 @@ SV *   sv ;
 {
     SV **	svp;
     HV *	action ;
-    DB_File	RETVAL;
+    DB_File	RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
     void *	openinfo = NULL ;
-    INFO	* info;
+    INFO	* info  = &RETVAL->info ;
 
 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */
-    Newz(777, RETVAL, 1, DB_File_type) ;
-    info  = &RETVAL->info ;
+    Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
@@ -1159,7 +1170,7 @@ db_FETCH(db, key, flags=0)
 	    RETVAL = db_get(db, key, value, flags) ;
 	    ST(0) = sv_newmortal();
 	    if (RETVAL == 0) 
-	        sv_setpvn(ST(0), value.data, value.size);
+	        my_sv_setpvn(ST(0), value.data, value.size);
 	}
 
 int
@@ -1189,7 +1200,7 @@ db_FIRSTKEY(db)
 	    if (RETVAL == 0)
 	    {
 	        if (db->type != DB_RECNO)
-	            sv_setpvn(ST(0), key.data, key.size);
+	            my_sv_setpvn(ST(0), key.data, key.size);
 	        else
 	            sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
 	    }
@@ -1211,7 +1222,7 @@ db_NEXTKEY(db, key)
 	    if (RETVAL == 0)
 	    {
 	        if (db->type != DB_RECNO)
-	            sv_setpvn(ST(0), key.data, key.size);
+	            my_sv_setpvn(ST(0), key.data, key.size);
 	        else
 	            sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
 	    }
@@ -1224,6 +1235,7 @@ db_NEXTKEY(db, key)
 int
 unshift(db, ...)
 	DB_File		db
+	ALIAS:		UNSHIFT = 1
 	CODE:
 	{
 	    DBTKEY	key ;
@@ -1264,6 +1276,7 @@ unshift(db, ...)
 I32
 pop(db)
 	DB_File		db
+	ALIAS:		POP = 1
 	CODE:
 	{
 	    DBTKEY	key ;
@@ -1281,7 +1294,7 @@ pop(db)
 	    if (RETVAL == 0)
 	    {
 		/* the call to del will trash value, so take a copy now */
-	        sv_setpvn(ST(0), value.data, value.size);
+	        my_sv_setpvn(ST(0), value.data, value.size);
 	        RETVAL = db_del(db, key, R_CURSOR) ;
 	        if (RETVAL != 0) 
 	            sv_setsv(ST(0), &sv_undef); 
@@ -1291,6 +1304,7 @@ pop(db)
 I32
 shift(db)
 	DB_File		db
+	ALIAS:		SHIFT = 1
 	CODE:
 	{
 	    DBT		value ;
@@ -1307,7 +1321,7 @@ shift(db)
 	    if (RETVAL == 0)
 	    {
 		/* the call to del will trash value, so take a copy now */
-	        sv_setpvn(ST(0), value.data, value.size);
+	        my_sv_setpvn(ST(0), value.data, value.size);
 	        RETVAL = db_del(db, key, R_CURSOR) ;
 	        if (RETVAL != 0)
 	            sv_setsv (ST(0), &sv_undef) ;
@@ -1318,6 +1332,7 @@ shift(db)
 I32
 push(db, ...)
 	DB_File		db
+	ALIAS:		PUSH = 1
 	CODE:
 	{
 	    DBTKEY	key ;
@@ -1365,6 +1380,7 @@ push(db, ...)
 I32
 length(db)
 	DB_File		db
+	ALIAS:		FETCHSIZE = 1
 	CODE:
 	    CurrentDB = db ;
 	    RETVAL = GetArrayLength(db) ;
diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t
index b332c5eb6c..c2161b279c 100755
--- a/t/lib/db-recno.t
+++ b/t/lib/db-recno.t
@@ -12,7 +12,10 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 use strict ;
-use vars qw($dbh $Dfile $bad_ones) ;
+use vars qw($dbh $Dfile $bad_ones $FA) ;
+
+# full tied array support started in Perl 5.004_57
+$FA = ($] >= 5.004_57) ;
 
 sub ok
 {
@@ -41,7 +44,7 @@ sub bad_one
 EOM
 }
 
-print "1..66\n";
+print "1..78\n";
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -98,7 +101,7 @@ ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666
 
 #my $l = @h ;
 my $l = $X->length ;
-ok(19, !$l );
+ok(19, ($FA ? @h == 0 : !$l) );
 
 my @data = qw( a b c d ever f g h  i j k longername m n o p) ;
 
@@ -113,7 +116,7 @@ unshift (@data, 'a') ;
 
 ok(21, defined $h[1] );
 ok(22, ! defined $h[16] );
-ok(23, $X->length == @data );
+ok(23, $FA ? @h == @data : $X->length == @data );
 
 
 # Overwrite an entry & check fetch it
@@ -123,8 +126,7 @@ ok(24, $h[3] eq 'replaced' );
 
 #PUSH
 my @push_data = qw(added to the end) ;
-#my push (@h, @push_data) ;
-$X->push(@push_data) ;
+($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
 push (@data, @push_data) ;
 ok(25, $h[++$i] eq 'added' );
 ok(26, $h[++$i] eq 'to' );
@@ -133,27 +135,24 @@ ok(28, $h[++$i] eq 'end' );
 
 # POP
 my $popped = pop (@data) ;
-#my $value = pop(@h) ;
-my $value = $X->pop ;
+my $value = ($FA ? pop @h : $X->pop) ;
 ok(29, $value eq $popped) ;
 
 # SHIFT
-#$value = shift @h
-$value = $X->shift ;
+$value = ($FA ? shift @h : $X->shift) ;
 my $shifted = shift @data ;
 ok(30, $value eq $shifted );
 
 # UNSHIFT
 
 # empty list
-$X->unshift ;
-ok(31, $X->length == @data );
+($FA ? unshift @h : $X->unshift) ;
+ok(31, ($FA ? @h == @data : $X->length == @data ));
 
 my @new_data = qw(add this to the start of the array) ;
-#unshift @h, @new_data ;
-$X->unshift (@new_data) ;
+$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
 unshift (@data, @new_data) ;
-ok(32, $X->length == @data );
+ok(32, $FA ? @h == @data : $X->length == @data );
 ok(33, $h[0] eq "add") ;
 ok(34, $h[1] eq "this") ;
 ok(35, $h[2] eq "to") ;
@@ -180,15 +179,15 @@ ok(42, $ok );
 
 # get the last element of the array
 ok(43, $h[-1] eq $data[-1] );
-ok(44, $h[-1] eq $h[$X->length -1] );
+ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
 
 # get the first element using a negative subscript
-eval '$h[ - ( $X->length)] = "abcd"' ;
+eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
 ok(45, $@ eq "" );
 ok(46, $h[0] eq "abcd" );
 
 # now try to read before the start of the array
-eval '$h[ - (1 + $X->length)] = 1234' ;
+eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
 ok(47, $@ =~ '^Modification of non-creatable array value attempted' );
 
 # IMPORTANT - $X must be undefined before the untie otherwise the
@@ -350,7 +349,7 @@ EOM
 
     close FILE ;
 
-    BEGIN { push @INC, '.'; }   
+    BEGIN { push @INC, '.'; } 
     eval 'use SubDB ; ';
     main::ok(57, $@ eq "") ;
     my @h ;
@@ -384,4 +383,61 @@ EOM
 
 }
 
+{
+
+    # test $#
+    my $self ;
+    unlink $Dfile;
+    ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+    $h[0] = "abc" ;
+    $h[1] = "def" ;
+    $h[2] = "ghi" ;
+    $h[3] = "jkl" ;
+    ok(68, $FA ? $#h == 3 : $self->length() == 4) ;
+    undef $self ;
+    untie @h ;
+    my $x = docat($Dfile) ;
+    ok(69, $x eq "abc\ndef\nghi\njkl\n") ;
+
+    # $# sets array to same length
+    ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    if ($FA)
+      { $#h = 3 }
+    else 
+      { $self->STORESIZE(4) }
+    ok(71, $FA ? $#h == 3 : $self->length() == 4) ;
+    undef $self ;
+    untie @h ;
+    $x = docat($Dfile) ;
+    ok(72, $x eq "abc\ndef\nghi\njkl\n") ;
+
+    # $# sets array to bigger
+    ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    if ($FA)
+      { $#h = 6 }
+    else 
+      { $self->STORESIZE(7) }
+    ok(74, $FA ? $#h == 6 : $self->length() == 7) ;
+    undef $self ;
+    untie @h ;
+    $x = docat($Dfile) ;
+    ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+
+    # $# sets array smaller
+    ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+    if ($FA)
+      { $#h = 2 }
+    else 
+      { $self->STORESIZE(3) }
+    ok(77, $FA ? $#h == 2 : $self->length() == 3) ;
+    undef $self ;
+    untie @h ;
+    $x = docat($Dfile) ;
+    ok(78, $x eq "abc\ndef\nghi\n") ;
+
+    unlink $Dfile;
+
+
+}
+
 exit ;