DB_File 1.810

From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-Id: <20040807142059.CTQC10838.mta10-svc.ntlworld.com@MARQUESSPT21>

p4raw-id: //depot/perl@23202

4 files changed, 97 insertions, 16 deletions

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index e74c3e2ac9..89027d13f6 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -1,5 +1,11 @@
 
 
+1.810 7th August 2004
+
+   * Fixed db-hash.t for Cygwin
+
+   * Added substr tests to db-hast.t
+
 1.809 20th June 2004
 
    * Merged core patch 22258
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index 3f53d468cd..5ddac46c96 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 (pmqs@cpan.org)
-# last modified 20th June 2004
-# version 1.809
+# last modified 7th August 2004
+# version 1.810
 #
 #     Copyright (c) 1995-2004 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -165,7 +165,7 @@ our ($db_version, $use_XSLoader, $splice_end_array);
 use Carp;
 
 
-$VERSION = "1.809" ;
+$VERSION = "1.810" ;
 
 {
     local $SIG{__WARN__} = sub {$splice_end_array = "@_";};
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index eb83670338..8f6cec1cc3 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 <pmqs@cpan.org>
- last modified 20th June 2004
- version 1.809
+ last modified 7th August 2004
+ version 1.810
 
  All comments/suggestions/problems are welcome
 
@@ -109,6 +109,7 @@
         1.807 - no change
         1.808 - leak fixed in ParseOpenInfo
         1.809 - no change
+        1.810 - no change
 
 */
 
@@ -397,8 +398,9 @@ typedef DBT DBTKEY ;
 
 #define OutputValue(arg, name)  					\
 	{ if (RETVAL == 0) {						\
+	      SvGETMAGIC(arg) ;          				\
 	      my_sv_setpvn(arg, name.data, name.size) ;			\
-	      TAINT;                                       	\
+	      TAINT;                                       		\
 	      SvTAINTED_on(arg);                                       	\
 	      SvUTF8_off(arg);                                       	\
 	      DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
@@ -408,12 +410,13 @@ typedef DBT DBTKEY ;
 #define OutputKey(arg, name)	 					\
 	{ if (RETVAL == 0) 						\
 	  { 								\
+		SvGETMAGIC(arg) ;          				\
 		if (db->type != DB_RECNO) {				\
 		    my_sv_setpvn(arg, name.data, name.size); 		\
 		}							\
 		else 							\
 		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 		\
-	      TAINT;                                       	\
+	      TAINT;                                       		\
 	      SvTAINTED_on(arg);                                       	\
 	      SvUTF8_off(arg);                                       	\
 	      DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
diff --git a/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t
index 86a64ff705..018952f9d4 100755
--- a/ext/DB_File/t/db-hash.t
+++ b/ext/DB_File/t/db-hash.t
@@ -23,7 +23,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..161\n";
+print "1..166\n";
 
 unlink glob "__db.*";
 
@@ -877,14 +877,14 @@ EOM
 #
 #    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
 #    {
-#        local ($^W) = 0; #no warnings;
+#        no warnings;
 #        untie %hash;
 #    }
 #    unlink $Dfile;
 #}
 
-#ok(127,1);
-#ok(128,1);
+#ok(127, 1);
+#ok(128, 1);
 
 {
     # Check that two hash's don't interact
@@ -934,9 +934,11 @@ EOM
     tie %hash1, 'DB_File',$Dfile, undef;
     ok(133, $warn_count == 0);
     $warn_count = 0;
+    untie %hash1;
     unlink $Dfile;
     tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
     ok(134, $warn_count == 0);
+    untie %hash1;
     unlink $Dfile;
     tie %hash1, 'DB_File',$Dfile, undef, undef;
     ok(135, $warn_count == 0);
@@ -1113,9 +1115,9 @@ EOM
 
     my %bad = () ;
     $key = '';
-    for ($status = $db->seq($key, $value, R_FIRST ) ;
+    for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
          $status == 0 ;
-         $status = $db->seq($key, $value, R_NEXT ) ) {
+         $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {
 
         #print "# key [$key] value [$value]\n" ;
         if (defined $remember{$key} && defined $value && 
@@ -1130,11 +1132,11 @@ EOM
     ok 157, keys %bad == 0 ;
     ok 158, keys %remember == 0 ;
 
-    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
-    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
+    print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key=>$value\n" while ($key, $value) = each %bad;
 
     # Make sure this fix does not break code to handle an undef key
-    # Berkeley DB undef key is bron between versions 2.3.16 and 
+    # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
     my $value = 'fred';
     $warned = '';
     $db->put(undef, $value) ;
@@ -1156,4 +1158,74 @@ EOM
     unlink $Dfile;
 }
 
+{
+   # Check filter + substr
+
+   use warnings ;
+   use strict ;
+   my (%h, $db) ;
+   my $Dfile = "xxy.db";
+   unlink $Dfile;
+
+   ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+
+   {
+       $db->filter_fetch_key   (sub { lc $_ } );
+       $db->filter_store_key   (sub { uc $_ } );
+       $db->filter_fetch_value (sub { lc $_ } );
+       $db->filter_store_value (sub { uc $_ } );
+   }
+
+   $_ = 'fred';
+
+    # db-put with substr of key
+    my %remember = () ;
+    my $status = 0 ;
+    for my $ix ( 1 .. 2 )
+    {
+        my $key = $ix . "data" ;
+        my $value = "value$ix" ;
+        $remember{$key} = $value ;
+        $status += $db->put(substr($key,0), substr($value,0)) ;
+    }
+
+    ok 163, $status == 0 or print "# Status $status\n" ;
+
+    if (1)
+    {
+       $db->filter_fetch_key   (undef);
+       $db->filter_store_key   (undef);
+       $db->filter_fetch_value (undef);
+       $db->filter_store_value (undef);
+    }
+
+    my %bad = () ;
+    my $key = '';
+    my $value = '';
+    for ($status = $db->seq($key, $value, R_FIRST ) ;
+         $status == 0 ;
+         $status = $db->seq($key, $value, R_NEXT ) ) {
+
+        #print "# key [$key] value [$value]\n" ;
+        if (defined $remember{$key} && defined $value && 
+             $remember{$key} eq $value) {
+            delete $remember{$key} ;
+        }
+        else {
+            $bad{$key} = $value ;
+        }
+    }
+    
+    ok 164, $_ eq 'fred';
+    ok 165, keys %bad == 0 ;
+    ok 166, keys %remember == 0 ;
+
+    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
+    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
 exit ;