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, 46 deletions

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