Fix DBM filters

From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-ID: <AIEAJICLCBDNAAOLLOKLAEHCFEAA.Paul.Marquess@btinternet.com>

p4raw-id: //depot/perl@17750

3 files changed, 54 insertions, 29 deletions

diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index 3bc94fe073..376af1f0ba 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -56,25 +56,6 @@ typedef datum datum_key ;
 typedef datum datum_key_copy ;
 typedef datum datum_value ;
 
-#define ckFilter(arg,type,name)					\
-	if (db->type) {						\
-	    SV * save_defsv ;					\
-            /* printf("filtering %s\n", name) ;*/		\
-	    if (db->filtering)					\
-	        croak("recursion detected in %s", name) ;	\
-	    db->filtering = TRUE ;				\
-	    save_defsv = newSVsv(DEFSV) ;			\
-	    sv_setsv(DEFSV, arg) ;				\
-	    PUSHMARK(sp) ;					\
-	    (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); 	\
-	    sv_setsv(arg, DEFSV) ;				\
-	    sv_setsv(DEFSV, save_defsv) ;			\
-	    SvREFCNT_dec(save_defsv) ;				\
-	    db->filtering = FALSE ;				\
-	    /*printf("end of filtering %s\n", name) ;*/		\
-	}
-
-
 #define odbm_FETCH(db,key)			fetch(key)
 #define odbm_STORE(db,key,value,flags)		store(key,value)
 #define odbm_DELETE(db,key)			delete(key)
@@ -207,7 +188,7 @@ filter_fetch_key(db, code)
 	SV *		code
 	SV *		RETVAL = &PL_sv_undef ;
 	CODE:
-	    setFilter(filter_fetch_key) ;
+	    DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -215,7 +196,7 @@ filter_store_key(db, code)
 	SV *		code
 	SV *		RETVAL =  &PL_sv_undef ;
 	CODE:
-	    setFilter(filter_store_key) ;
+	    DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -223,7 +204,7 @@ filter_fetch_value(db, code)
 	SV *		code
 	SV *		RETVAL =  &PL_sv_undef ;
 	CODE:
-	    setFilter(filter_fetch_value) ;
+	    DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -231,5 +212,5 @@ filter_store_value(db, code)
 	SV *		code
 	SV *		RETVAL =  &PL_sv_undef ;
 	CODE:
-	    setFilter(filter_store_value) ;
+	    DBM_setFilter(db->filter_store_value, code) ;
 
diff --git a/ext/ODBM_File/odbm.t b/ext/ODBM_File/odbm.t
index ecffffd81a..c4df3d8a1b 100755
--- a/ext/ODBM_File/odbm.t
+++ b/ext/ODBM_File/odbm.t
@@ -28,7 +28,7 @@ require ODBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..72\n";
+print "1..78\n";
 
 unlink <Op.dbmx*>;
 
@@ -466,6 +466,50 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(73, my $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(74, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (75, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(76, $h{"fred"} eq "joe");
+
+   ok(77, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (78, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;
 if ($^O eq 'hpux') {
     print <<EOM;
diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap
index 62b8622569..4f4802cfa5 100644
--- a/ext/ODBM_File/typemap
+++ b/ext/ODBM_File/typemap
@@ -16,7 +16,7 @@ FATALFUNC		T_OPAQUEPTR
 
 INPUT
 T_DATUM_K
-	ckFilter($arg, filter_store_key, \"filter_store_key\");
+	DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
 	$var.dptr = SvPV($arg, PL_na);
 	$var.dsize = (int)PL_na;
 T_DATUM_K_C
@@ -24,7 +24,7 @@ T_DATUM_K_C
 	    SV * tmpSV ;
 	    if (db->filter_store_key){
 	        tmpSV = sv_2mortal(newSVsv($arg));
-	        ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
+	        DBM_ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
 	    }
 	    else
 		tmpSV = $arg;
@@ -32,7 +32,7 @@ T_DATUM_K_C
 	    $var.dsize = (int)PL_na;
 	}
 T_DATUM_V
-        ckFilter($arg, filter_store_value, \"filter_store_value\");
+        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
 	if (SvOK($arg)) {
 	    $var.dptr = SvPV($arg, PL_na);
 	    $var.dsize = (int)PL_na;
@@ -46,9 +46,9 @@ T_GDATUM
 OUTPUT
 T_DATUM_K
 	sv_setpvn($arg, $var.dptr, $var.dsize);
-	ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+	DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
 T_DATUM_V
 	sv_setpvn($arg, $var.dptr, $var.dsize);
-	ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+	DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_GDATUM
 	sv_usepvn($arg, $var.dptr, $var.dsize);