Fix DBM filters

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

p4raw-id: //depot/perl@17750

15 files changed, 264 insertions, 236 deletions

diff --git a/XSUB.h b/XSUB.h
index 2d1b8edad7..a2826ea194 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -228,6 +228,49 @@ C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
 #  define XS_VERSION_BOOTCHECK
 #endif
 
+/* 
+   The DBM_setFilter & DBM_ckFilter macros are only used by 
+   the *DB*_File modules 
+*/
+
+#define DBM_setFilter(db_type,code)				\
+	{							\
+	    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) ;			\
+	    }	    						\
+	}
+
+#define DBM_ckFilter(arg,type,name)				\
+	if (db->type) {						\
+	    if (db->filtering) {				\
+	        croak("recursion detected in %s", name) ;	\
+	    }                     				\
+	    ENTER ;						\
+	    SAVETMPS ;						\
+	    SAVEINT(db->filtering) ;				\
+	    db->filtering = TRUE ;				\
+	    SAVESPTR(DEFSV) ;					\
+	    DEFSV = arg ;					\
+	    SvTEMP_off(arg) ;					\
+	    PUSHMARK(SP) ;					\
+	    PUTBACK ;						\
+	    (void) perl_call_sv(db->type, G_DISCARD); 		\
+	    SPAGAIN ;						\
+	    PUTBACK ;						\
+	    FREETMPS ;						\
+	    LEAVE ;						\
+	}
+
 #if 1		/* for compatibility */
 #  define VTBL_sv		&PL_vtbl_sv
 #  define VTBL_env		&PL_vtbl_env
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index fc2f63e12a..489ba96890 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -162,7 +162,6 @@
 #include <fcntl.h> 
 
 /* #define TRACE */
-#define DBM_FILTERING
 
 #ifdef TRACE
 #    define Trace(x)        printf x
@@ -367,51 +366,23 @@ typedef struct {
 #ifdef DB_VERSION_MAJOR
 	DBC *	cursor ;
 #endif
-#ifdef DBM_FILTERING
 	SV *    filter_fetch_key ;
 	SV *    filter_store_key ;
 	SV *    filter_fetch_value ;
 	SV *    filter_store_value ;
 	int     filtering ;
-#endif /* DBM_FILTERING */
 
 	} DB_File_type;
 
 typedef DB_File_type * DB_File ;
 typedef DBT DBTKEY ;
 
-#ifdef DBM_FILTERING
-
-#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) ; */ 	\
-	}
-
-#else
-
-#define ckFilter(arg,type, name)
-
-#endif /* DBM_FILTERING */
-
 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
 
 #define OutputValue(arg, name)  					\
 	{ if (RETVAL == 0) {						\
 	      my_sv_setpvn(arg, name.data, name.size) ;			\
-	      ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
+	      DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
 	  }								\
 	}
 
@@ -423,7 +394,7 @@ typedef DBT DBTKEY ;
 		}							\
 		else 							\
 		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 		\
-	      ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
+	      DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
 	  } 								\
 	}
 
@@ -876,11 +847,9 @@ SV *   sv ;
     Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
-#ifdef DBM_FILTERING
     RETVAL->filtering = 0 ;
     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
-#endif /* DBM_FILTERING */
     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
     RETVAL->type = DB_HASH ;
 
@@ -1150,11 +1119,9 @@ SV *   sv ;
     Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
-#ifdef DBM_FILTERING
     RETVAL->filtering = 0 ;
     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
-#endif /* DBM_FILTERING */
     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
     RETVAL->type = DB_HASH ;
 
@@ -1444,7 +1411,6 @@ db_DESTROY(db)
 	    SvREFCNT_dec(db->compare) ;
 	  if (db->prefix)
 	    SvREFCNT_dec(db->prefix) ;
-#ifdef DBM_FILTERING
 	  if (db->filter_fetch_key)
 	    SvREFCNT_dec(db->filter_fetch_key) ;
 	  if (db->filter_store_key)
@@ -1453,7 +1419,6 @@ db_DESTROY(db)
 	    SvREFCNT_dec(db->filter_fetch_value) ;
 	  if (db->filter_store_value)
 	    SvREFCNT_dec(db->filter_store_value) ;
-#endif /* DBM_FILTERING */
 	  safefree(db) ;
 #ifdef DB_VERSION_MAJOR
 	  if (RETVAL > 0)
@@ -1857,33 +1822,13 @@ db_seq(db, key, value, flags)
 	  key
 	  value
 
-#ifdef DBM_FILTERING
-
-#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)
 	DB_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)
@@ -1891,7 +1836,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)
@@ -1899,7 +1844,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)
@@ -1907,6 +1852,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) ;
 
-#endif /* DBM_FILTERING */
diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 55439ee76d..ecd378514a 100644
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -15,7 +15,7 @@ DBTKEY			T_dbtkeydatum
 
 INPUT
 T_dbtkeydatum
-	ckFilter($arg, filter_store_key, \"filter_store_key\");
+	DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
 	DBT_clear($var) ;
 	if (db->type != DB_RECNO) {
 	    $var.data = SvPV($arg, PL_na);
@@ -27,7 +27,7 @@ T_dbtkeydatum
 	    $var.size = (int)sizeof(recno_t);
 	}
 T_dbtdatum
-	ckFilter($arg, filter_store_value, \"filter_store_value\");
+	DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
 	DBT_clear($var) ;
 	if (SvOK($arg)) {
 	    $var.data = SvPV($arg, PL_na);
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index 5684a968e0..22350fd692 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -19,26 +19,6 @@ typedef datum datum_key ;
 typedef datum datum_value ;
 typedef datum datum_key_copy;
 
-#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 GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
 
 typedef void (*FATALFUNC)();
@@ -183,32 +163,13 @@ gdbm_setopt (db, optflag, optval, optlen)
 	int		optlen
 
 
-#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)
 	GDBM_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)
@@ -216,7 +177,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)
@@ -224,7 +185,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)
@@ -232,5 +193,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/GDBM_File/gdbm.t b/ext/GDBM_File/gdbm.t
index 7c268936f3..87e30d086b 100755
--- a/ext/GDBM_File/gdbm.t
+++ b/ext/GDBM_File/gdbm.t
@@ -18,7 +18,7 @@ use warnings;
 
 use GDBM_File;
 
-print "1..74\n";
+print "1..80\n";
 
 unlink <Op.dbmx*>;
 
@@ -467,4 +467,47 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(75, my $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 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(76, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+
+   # 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(78, $h{"fred"} eq "joe");
+
+   ok(79, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (80, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;
diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap
index 8952938ccd..048f0dd11c 100644
--- a/ext/GDBM_File/typemap
+++ b/ext/GDBM_File/typemap
@@ -15,7 +15,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
@@ -23,7 +23,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;
@@ -31,7 +31,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;
@@ -43,9 +43,9 @@ T_DATUM_V
 OUTPUT
 T_DATUM_K
 	output_datum(aTHX_ $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
 	output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
-	ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+	DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_PTROBJ
         sv_setref_pv($arg, dbtype, (void*)$var);
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
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);
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index b454d59152..3bf3c2baf9 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -17,24 +17,6 @@ typedef SDBM_File_type * SDBM_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) ;*/		\
-	}
-
 #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
 #define sdbm_FETCH(db,key)			sdbm_fetch(db->dbp,key)
 #define sdbm_STORE(db,key,value,flags)		sdbm_store(db->dbp,key,value,flags)
@@ -138,32 +120,13 @@ sdbm_clearerr(db)
 	  RETVAL
 
 
-#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)
 	SDBM_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)
@@ -171,7 +134,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)
@@ -179,7 +142,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)
@@ -187,5 +150,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/SDBM_File/sdbm.t b/ext/SDBM_File/sdbm.t
index f942b97d96..d1e2b4ac2e 100644
--- a/ext/SDBM_File/sdbm.t
+++ b/ext/SDBM_File/sdbm.t
@@ -28,7 +28,7 @@ require SDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..74\n";
+print "1..80\n";
 
 unlink <Op_dbmx.*>;
 
@@ -469,4 +469,48 @@ unlink <Op_dbmx*>, $Dfile;
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op1.dbmx*>;
+
+   ok(75, my $db = tie(%h, 'SDBM_File','Op1_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(76, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+
+   # 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(78, $h{"fred"} eq "joe");
+
+   ok(79, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (80, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op1.dbmx*>;
+}
 exit ;
diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap
index 40b95f22c0..093c426409 100644
--- a/ext/SDBM_File/typemap
+++ b/ext/SDBM_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