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, 53 insertions, 48 deletions

diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index 78a56cb7cc..201ab6cc05 100644
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -5,7 +5,6 @@
  * by DB3 and Perl.  We drop the Perl definition now.
  * See also INSTALL section on DB3.
  * -- Stanislav Brabec <utx@penguin.cz> */
-#undef ENTER
 #include <ndbm.h>
 
 typedef struct {
@@ -21,25 +20,6 @@ typedef NDBM_File_type * NDBM_File ;
 typedef datum datum_key ;
 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) ;*/		\
-	}
-
-
 MODULE = NDBM_File	PACKAGE = NDBM_File	PREFIX = ndbm_
 
 NDBM_File
@@ -120,32 +100,13 @@ ndbm_clearerr(db)
 	NDBM_File	db
 
 
-#define setFilter(type)					\
-	{						\
-	    if (db->type)				\
-	        RETVAL = sv_mortalcopy(db->type) ; 	\
-	    ST(0) = RETVAL ;				\
-	    if (db->type && (code == &PL_sv_undef)) {	\
-                SvREFCNT_dec(db->type) ;		\
-	        db->type = NULL ;			\
-	    }						\
-	    else if (code) {				\
-	        if (db->type)				\
-	            sv_setsv(db->type, code) ;		\
-	        else					\
-	            db->type = newSVsv(code) ;		\
-	    }	    					\
-	}
-
-
-
 SV *
 filter_fetch_key(db, code)
 	NDBM_File	db
 	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)
@@ -153,7 +114,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)
@@ -161,7 +122,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)
@@ -169,5 +130,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/NDBM_File/ndbm.t b/ext/NDBM_File/ndbm.t
index a340e33214..a7e49b8860 100755
--- a/ext/NDBM_File/ndbm.t
+++ b/ext/NDBM_File/ndbm.t
@@ -28,7 +28,7 @@ require NDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..71\n";
+print "1..77\n";
 
 unlink <Op.dbmx*>;
 
@@ -460,4 +460,48 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(72, my $db = tie(%h, 'NDBM_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(73, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (74, ! $@);
+
+
+   # 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(75, $h{"fred"} eq "joe");
+
+   ok(76, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;
diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap
index 40b95f22c0..093c426409 100644
--- a/ext/NDBM_File/typemap
+++ b/ext/NDBM_File/typemap
@@ -15,11 +15,11 @@ 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_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;
@@ -33,10 +33,10 @@ 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);
 T_PTROBJ