DBM Filters (via private mail)

	Message-Id: <199904182009.NAA19152@activestate.com>
	Subject: DBM Filters

p4raw-id: //depot/perl@3317

4 files changed, 145 insertions, 20 deletions

diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 2fab919229..82d9af5af0 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -230,5 +230,10 @@
    * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail.
 
 1.65 6th March 1999
+
    * Fixed a bug in the recno PUSH logic.
    * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2
+
+1.66 15th March 1999
+
+   * Added DBM Filter code
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index e5759ff558..7e6c90789f 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -2,7 +2,7 @@
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
 # last modified 6th March 1999
-# version 1.65
+# version 1.66
 #
 #     Copyright (c) 1995-9 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver
 use Carp;
 
 
-$VERSION = "1.65" ;
+$VERSION = "1.66" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -1811,7 +1811,8 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
 
 =head1 SEE ALSO
 
-L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> 
+L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<dbmfilter>
 
 =head1 AUTHOR
 
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index 3f6c094395..cdadf29068 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -4,7 +4,7 @@
 
  written by Paul Marquess <Paul.Marquess@btinternet.com>
  last modified 6th March 1999
- version 1.65
+ version 1.66
 
  All comments/suggestions/problems are welcome
 
@@ -65,6 +65,7 @@
 		to fix a flag mapping problem with O_RDONLY on the Hurd
         1.65 -  Fixed a bug in the PUSH logic.
 		Added BOOT check that using 2.3.4 or greater
+        1.66 -  Added DBM filter code
 
 
 
@@ -105,6 +106,7 @@
 #include <fcntl.h> 
 
 /* #define TRACE */
+#define DBM_FILTERING
 
 
 
@@ -277,28 +279,67 @@ 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 ;*/   /* save $_ */			\
+	    save_defsv = newSVsv(DEFSV) ;			\
+	    sv_setsv(DEFSV, arg) ;				\
+	    PUSHMARK(sp) ;					\
+	    (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); 	\
+	    /* SPAGAIN ; */						\
+	    sv_setsv(arg, DEFSV) ;				\
+	    sv_setsv(DEFSV, save_defsv) ;				\
+	    SvREFCNT_dec(save_defsv) ;				\
+	    /* PUTBACK ; */						\
+	    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) ;		\
-	  }							\
+#define OutputValue(arg, name)  					\
+	{ if (RETVAL == 0) {						\
+	      my_sv_setpvn(arg, name.data, name.size) ;			\
+	      ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; 	\
+	  }								\
 	}
 
-#define OutputKey(arg, name)	 				\
-	{ if (RETVAL == 0) 					\
-	  { 							\
-		if (db->type != DB_RECNO) {			\
-		    my_sv_setpvn(arg, name.data, name.size); 	\
-		}						\
-		else 						\
-		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 	\
-	  } 							\
+#define OutputKey(arg, name)	 					\
+	{ if (RETVAL == 0) 						\
+	  { 								\
+		if (db->type != DB_RECNO) {				\
+		    my_sv_setpvn(arg, name.data, name.size); 		\
+		}							\
+		else 							\
+		    sv_setiv(arg, (I32)*(I32*)name.data - 1); 		\
+	      ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; 	\
+	  } 								\
 	}
 
 
@@ -620,6 +661,11 @@ 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 ;
 
@@ -1165,6 +1211,16 @@ 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)
+	    SvREFCNT_dec(db->filter_store_key) ;
+	  if (db->filter_fetch_value)
+	    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)
@@ -1380,7 +1436,8 @@ push(db, ...)
 	            if (RETVAL != 0)
 	                break;
 		}
-#else
+#else		
+	    
 	    /* Set the Cursor to the Last element */
 	    RETVAL = do_SEQ(db, key, value, R_LAST) ;
 	    if (RETVAL >= 0)
@@ -1531,3 +1588,63 @@ db_seq(db, key, value, flags)
 	  key
 	  value
 
+#ifdef DBM_FILTERING
+
+#define setFilter(type)					\
+	{						\
+	    if (db->type)				\
+	        RETVAL = newSVsv(db->type) ; 		\
+	    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) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_key(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_fetch_value(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_value(db, code)
+	DB_File		db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
+	OUTPUT:
+	    RETVAL
+
+#endif /* DBM_FILTERING */
diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 994ba27232..29dc778df7 100644
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -1,8 +1,8 @@
 # typemap for Perl 5 interface to Berkeley 
 #
 # written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 21st February 1999
-# version 1.65
+# last modified 20th March 1999
+# version 1.66
 #
 #################################### DB SECTION
 #
@@ -15,6 +15,7 @@ DBTKEY			T_dbtkeydatum
 
 INPUT
 T_dbtkeydatum
+	ckFilter($arg, filter_store_key, \"filter_store_key\");
 	if (db->type != DB_RECNO) {
 	    $var.data = SvPV($arg, PL_na);
 	    $var.size = (int)PL_na;
@@ -27,6 +28,7 @@ T_dbtkeydatum
 	    DBT_flags($var);
 	}
 T_dbtdatum
+	ckFilter($arg, filter_store_value, \"filter_store_value\");
 	$var.data = SvPV($arg, PL_na);
 	$var.size = (int)PL_na;
 	DBT_flags($var);