DBM Filters (via private mail)

Message-Id: <199904182009.NAA19152@activestate.com> Subject: DBM Filters p4raw-id: //depot/perl@3317
author: Paul Marquess <paul.marquess@btinternet.com> 1999-04-18 22:05:52 +0100
committer: Gurusamy Sarathy <gsar@cpan.org> 1999-05-07 04:18:11 +0000
commit: 9fe6733ac5627eddc014ed5f2afb208fa4afd501 (patch)
tree: fdda517b5f127b50bec181cf6351e2957d9e27fc
parent: fdb068fae82a164ca46639e6b096f05aeb3dc5ea (diff)
download: perl-9fe6733ac5627eddc014ed5f2afb208fa4afd501.tar.gz
30 files changed, 2197 insertions, 119 deletions
diff --git a/MANIFEST b/MANIFEST
index 60612f2333..bb9cb4b1a2 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -951,6 +951,7 @@ pod/perldebug.pod	Debugger info
 pod/perldelta.pod	Changes since last version
 pod/perl5005delta.pod	Changes from 5.004 to 5.005
 pod/perl5004delta.pod	Changes from 5.003 to 5.004
+pod/perldbmfilter.pod	Info about DBM Filters
 pod/perldiag.pod	Diagnostic info
 pod/perldsc.pod		Data Structures Cookbook
 pod/perlembed.pod	Embedding info
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);
diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm
index af9a5dc6a3..42bb6d28e8 100644
--- a/ext/GDBM_File/GDBM_File.pm
+++ b/ext/GDBM_File/GDBM_File.pm
@@ -33,7 +33,7 @@ The available functions and the gdbm/perl interface need to be documented.
 
 =head1 SEE ALSO
 
-L<perl(1)>, L<DB_File(3)>. 
+L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. 
 
 =cut
 
@@ -59,7 +59,7 @@ require DynaLoader;
 	GDBM_WRITER
 );
 
-$VERSION = "1.01";
+$VERSION = "1.02";
 
 sub AUTOLOAD {
     my($constname);
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index 808850d849..275c509698 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -5,18 +5,40 @@
 #include <gdbm.h>
 #include <fcntl.h>
 
-typedef GDBM_FILE GDBM_File;
+typedef struct {
+	GDBM_FILE 	dbp ;
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+	} GDBM_File_type;
+
+typedef GDBM_File_type * GDBM_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 GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
-#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \
-	gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)
 
-#define gdbm_FETCH(db,key)			gdbm_fetch(db,key)
-#define gdbm_STORE(db,key,value,flags)		gdbm_store(db,key,value,flags)
-#define gdbm_DELETE(db,key)			gdbm_delete(db,key)
-#define gdbm_FIRSTKEY(db)			gdbm_firstkey(db)
-#define gdbm_NEXTKEY(db,key)			gdbm_nextkey(db,key)
-#define gdbm_EXISTS(db,key)			gdbm_exists(db,key)
+
+#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
 
 typedef void (*FATALFUNC)();
 
@@ -187,7 +209,23 @@ gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
 	int		read_write
 	int		mode
 	FATALFUNC	fatal_func
+	CODE:
+	{
+	    GDBM_FILE  	dbp ;
 
+	    RETVAL = NULL ;
+	    if (dbp =  gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) {
+	        RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ;
+    	        Zero(RETVAL, 1, GDBM_File_type) ;
+		RETVAL->dbp = dbp ;
+	    }
+	    
+	}
+	OUTPUT:
+	  RETVAL
+	
+
+#define gdbm_close(db)			gdbm_close(db->dbp)
 void
 gdbm_close(db)
 	GDBM_File	db
@@ -199,16 +237,18 @@ gdbm_DESTROY(db)
 	CODE:
 	gdbm_close(db);
 
-datum
+#define gdbm_FETCH(db,key)			gdbm_fetch(db->dbp,key)
+datum_value
 gdbm_FETCH(db, key)
 	GDBM_File	db
-	datum		key
+	datum_key	key
 
+#define gdbm_STORE(db,key,value,flags)		gdbm_store(db->dbp,key,value,flags)
 int
 gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
 	GDBM_File	db
-	datum		key
-	datum		value
+	datum_key	key
+	datum_value	value
 	int		flags
     CLEANUP:
 	if (RETVAL) {
@@ -216,37 +256,44 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
 		croak("No write permission to gdbm file");
 	    croak("gdbm store returned %d, errno %d, key \"%.*s\"",
 			RETVAL,errno,key.dsize,key.dptr);
-	    /* gdbm_clearerr(db); */
+	    gdbm_clearerr(db);
 	}
 
+#define gdbm_DELETE(db,key)			gdbm_delete(db->dbp,key)
 int
 gdbm_DELETE(db, key)
 	GDBM_File	db
-	datum		key
+	datum_key	key
 
-datum
+#define gdbm_FIRSTKEY(db)			gdbm_firstkey(db->dbp)
+datum_key
 gdbm_FIRSTKEY(db)
 	GDBM_File	db
 
-datum
+#define gdbm_NEXTKEY(db,key)			gdbm_nextkey(db->dbp,key)
+datum_key
 gdbm_NEXTKEY(db, key)
 	GDBM_File	db
-	datum		key
+	datum_key	key
 
+#define gdbm_reorganize(db)			gdbm_reorganize(db->dbp)
 int
 gdbm_reorganize(db)
 	GDBM_File	db
 
 
+#define gdbm_sync(db)				gdbm_sync(db->dbp)
 void
 gdbm_sync(db)
 	GDBM_File	db
 
+#define gdbm_EXISTS(db,key)			gdbm_exists(db->dbp,key)
 int
 gdbm_EXISTS(db, key)
 	GDBM_File	db
-	datum		key
+	datum_key	key
 
+#define gdbm_setopt(db,optflag, optval, optlen)	gdbm_setopt(db->dbp,optflag, optval, optlen)
 int
 gdbm_setopt (db, optflag, optval, optlen)
 	GDBM_File	db
@@ -254,3 +301,62 @@ gdbm_setopt (db, optflag, optval, optlen)
 	int		&optval
 	int		optlen
 
+
+#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)
+	GDBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_key(db, code)
+	GDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_fetch_value(db, code)
+	GDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_value(db, code)
+	GDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
+	OUTPUT:
+	    RETVAL
+
diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap
index d122d07a43..20d5cd99bd 100644
--- a/ext/GDBM_File/typemap
+++ b/ext/GDBM_File/typemap
@@ -2,7 +2,8 @@
 #################################### DBM SECTION
 #
 
-datum			T_DATUM
+datum_key		T_DATUM_K
+datum_value		T_DATUM_V
 NDBM_File		T_PTROBJ
 GDBM_File		T_PTROBJ
 SDBM_File		T_PTROBJ
@@ -12,11 +13,20 @@ DBZ_File		T_PTROBJ
 FATALFUNC		T_OPAQUEPTR
 
 INPUT
-T_DATUM
+T_DATUM_K
+	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\");
 	$var.dptr = SvPV($arg, PL_na);
 	$var.dsize = (int)PL_na;
 OUTPUT
-T_DATUM
+T_DATUM_K
+	output_datum($arg, $var.dptr, $var.dsize);
+	ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+T_DATUM_V
 	output_datum($arg, $var.dptr, $var.dsize);
+	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.pm b/ext/NDBM_File/NDBM_File.pm
index ed4fe2b36f..cad800adf4 100644
--- a/ext/NDBM_File/NDBM_File.pm
+++ b/ext/NDBM_File/NDBM_File.pm
@@ -12,7 +12,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.01";
+$VERSION = "1.02";
 
 bootstrap NDBM_File $VERSION;
 
@@ -35,6 +35,6 @@ NDBM_File - Tied access to ndbm files
 
 =head1 DESCRIPTION
 
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
 
 =cut
diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index d129a9c490..f5bc0f9a6a 100644
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -3,13 +3,37 @@
 #include "XSUB.h"
 #include <ndbm.h>
 
-typedef DBM* NDBM_File;
-#define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode)
-#define dbm_FETCH(db,key)			dbm_fetch(db,key)
-#define dbm_STORE(db,key,value,flags)		dbm_store(db,key,value,flags)
-#define dbm_DELETE(db,key)			dbm_delete(db,key)
-#define dbm_FIRSTKEY(db)			dbm_firstkey(db)
-#define dbm_NEXTKEY(db,key)			dbm_nextkey(db)
+typedef struct {
+	DBM * 	dbp ;
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+	} NDBM_File_type;
+
+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 = dbm_
 
@@ -19,23 +43,39 @@ dbm_TIEHASH(dbtype, filename, flags, mode)
 	char *		filename
 	int		flags
 	int		mode
+	CODE:
+	{
+	    DBM * 	dbp ;
+
+	    RETVAL = NULL ;
+	    if (dbp =  dbm_open(filename, flags, mode)) {
+	        RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ;
+    	        Zero(RETVAL, 1, NDBM_File_type) ;
+		RETVAL->dbp = dbp ;
+	    }
+	    
+	}
+	OUTPUT:
+	  RETVAL
 
 void
 dbm_DESTROY(db)
 	NDBM_File	db
 	CODE:
-	dbm_close(db);
+	dbm_close(db->dbp);
 
-datum
+#define dbm_FETCH(db,key)			dbm_fetch(db->dbp,key)
+datum_value
 dbm_FETCH(db, key)
 	NDBM_File	db
-	datum		key
+	datum_key	key
 
+#define dbm_STORE(db,key,value,flags)		dbm_store(db->dbp,key,value,flags)
 int
 dbm_STORE(db, key, value, flags = DBM_REPLACE)
 	NDBM_File	db
-	datum		key
-	datum		value
+	datum_key	key
+	datum_value	value
 	int		flags
     CLEANUP:
 	if (RETVAL) {
@@ -43,28 +83,92 @@ dbm_STORE(db, key, value, flags = DBM_REPLACE)
 		croak("No write permission to ndbm file");
 	    croak("ndbm store returned %d, errno %d, key \"%s\"",
 			RETVAL,errno,key.dptr);
-	    dbm_clearerr(db);
+	    dbm_clearerr(db->dbp);
 	}
 
+#define dbm_DELETE(db,key)			dbm_delete(db->dbp,key)
 int
 dbm_DELETE(db, key)
 	NDBM_File	db
-	datum		key
+	datum_key	key
 
-datum
+#define dbm_FIRSTKEY(db)			dbm_firstkey(db->dbp)
+datum_key
 dbm_FIRSTKEY(db)
 	NDBM_File	db
 
-datum
+#define dbm_NEXTKEY(db,key)			dbm_nextkey(db->dbp)
+datum_key
 dbm_NEXTKEY(db, key)
 	NDBM_File	db
-	datum		key
+	datum_key	key
 
+#define dbm_error(db)				dbm_error(db->dbp)
 int
 dbm_error(db)
 	NDBM_File	db
 
+#define dbm_clearerr(db)			dbm_clearerr(db->dbp)
 void
 dbm_clearerr(db)
 	NDBM_File	db
 
+
+#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)
+	NDBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_key(db, code)
+	NDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_fetch_value(db, code)
+	NDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_value(db, code)
+	NDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
+	OUTPUT:
+	    RETVAL
+
diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap
index 317a8f3886..eeb5d59027 100644
--- a/ext/NDBM_File/typemap
+++ b/ext/NDBM_File/typemap
@@ -2,7 +2,8 @@
 #################################### DBM SECTION
 #
 
-datum			T_DATUM
+datum_key		T_DATUM_K
+datum_value		T_DATUM_V
 gdatum			T_GDATUM
 NDBM_File		T_PTROBJ
 GDBM_File		T_PTROBJ
@@ -13,14 +14,23 @@ DBZ_File		T_PTROBJ
 FATALFUNC		T_OPAQUEPTR
 
 INPUT
-T_DATUM
+T_DATUM_K
+	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\");
 	$var.dptr = SvPV($arg, PL_na);
 	$var.dsize = (int)PL_na;
 T_GDATUM
 	UNIMPLEMENTED
 OUTPUT
-T_DATUM
+T_DATUM_K
+	sv_setpvn($arg, $var.dptr, $var.dsize);
+	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\");
 T_GDATUM
 	sv_usepvn($arg, $var.dptr, $var.dsize);
 T_PTROBJ
diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm
index 923640ff34..572318b0cd 100644
--- a/ext/ODBM_File/ODBM_File.pm
+++ b/ext/ODBM_File/ODBM_File.pm
@@ -8,7 +8,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.00";
+$VERSION = "1.01";
 
 bootstrap ODBM_File $VERSION;
 
@@ -30,6 +30,6 @@ ODBM_File - Tied access to odbm files
 
 =head1 DESCRIPTION
 
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
 
 =cut
diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index 892c038a9c..0ab06ef6b1 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -30,7 +30,37 @@
 
 #include <fcntl.h>
 
-typedef void* ODBM_File;
+typedef struct {
+	void * 	dbp ;
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+	} ODBM_File_type;
+
+typedef ODBM_File_type * ODBM_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 odbm_FETCH(db,key)			fetch(key)
 #define odbm_STORE(db,key,value,flags)		store(key,value)
@@ -59,6 +89,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
 	CODE:
 	{
 	    char *tmpbuf;
+	    void * dbp ;
 	    if (dbmrefcnt++)
 		croak("Old dbm can only open one database");
 	    New(0, tmpbuf, strlen(filename) + 5, char);
@@ -75,7 +106,10 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
 		else
 		    croak("ODBM_FILE: Can't open %s", filename);
 	    }
-	    RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
+	    dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
+	    RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ;
+    	    Zero(RETVAL, 1, ODBM_File_type) ;
+	    RETVAL->dbp = dbp ;
 	    ST(0) = sv_mortalcopy(&PL_sv_undef);
 	    sv_setptrobj(ST(0), RETVAL, dbtype);
 	}
@@ -87,16 +121,16 @@ DESTROY(db)
 	dbmrefcnt--;
 	dbmclose();
 
-datum
+datum_key
 odbm_FETCH(db, key)
 	ODBM_File	db
-	datum		key
+	datum_key	key
 
 int
 odbm_STORE(db, key, value, flags = DBM_REPLACE)
 	ODBM_File	db
-	datum		key
-	datum		value
+	datum_key	key
+	datum_value	value
 	int		flags
     CLEANUP:
 	if (RETVAL) {
@@ -109,14 +143,73 @@ odbm_STORE(db, key, value, flags = DBM_REPLACE)
 int
 odbm_DELETE(db, key)
 	ODBM_File	db
-	datum		key
+	datum_key	key
 
-datum
+datum_key
 odbm_FIRSTKEY(db)
 	ODBM_File	db
 
-datum
+datum_key
 odbm_NEXTKEY(db, key)
 	ODBM_File	db
-	datum		key
+	datum_key	key
+
+
+#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)
+	ODBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_key(db, code)
+	ODBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_fetch_value(db, code)
+	ODBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_value(db, code)
+	ODBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
+	OUTPUT:
+	    RETVAL
 
diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap
index 5e12e73933..7c23815ec7 100644
--- a/ext/ODBM_File/typemap
+++ b/ext/ODBM_File/typemap
@@ -2,7 +2,8 @@
 #################################### DBM SECTION
 #
 
-datum			T_DATUM
+datum_key		T_DATUM_K
+datum_value		T_DATUM_V
 gdatum			T_GDATUM
 NDBM_File		T_PTROBJ
 GDBM_File		T_PTROBJ
@@ -13,13 +14,22 @@ DBZ_File		T_PTROBJ
 FATALFUNC		T_OPAQUEPTR
 
 INPUT
-T_DATUM
+T_DATUM_K
+	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\");
 	$var.dptr = SvPV($arg, PL_na);
 	$var.dsize = (int)PL_na;
 T_GDATUM
 	UNIMPLEMENTED
 OUTPUT
-T_DATUM
+T_DATUM_K
+	sv_setpvn($arg, $var.dptr, $var.dsize);
+	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\");
 T_GDATUM
 	sv_usepvn($arg, $var.dptr, $var.dsize);
diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm
index a2d4df8558..006bbbd17d 100644
--- a/ext/SDBM_File/SDBM_File.pm
+++ b/ext/SDBM_File/SDBM_File.pm
@@ -8,7 +8,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.00" ;
+$VERSION = "1.01" ;
 
 bootstrap SDBM_File $VERSION;
 
@@ -30,6 +30,6 @@ SDBM_File - Tied access to sdbm files
 
 =head1 DESCRIPTION
 
-See L<perlfunc/tie>
+See L<perlfunc/tie>, L<perldbmfilter>
 
 =cut
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index 789e5c80b8..681cf14696 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -3,14 +3,47 @@
 #include "XSUB.h"
 #include "sdbm/sdbm.h"
 
-typedef DBM* SDBM_File;
+typedef struct {
+	DBM * 	dbp ;
+	SV *    filter_fetch_key ;
+	SV *    filter_store_key ;
+	SV *    filter_fetch_value ;
+	SV *    filter_store_value ;
+	int     filtering ;
+	} SDBM_File_type;
+
+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 ;*/   /* 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) ;*/		\
+	}
+
 #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
-#define sdbm_FETCH(db,key)			sdbm_fetch(db,key)
-#define sdbm_STORE(db,key,value,flags)		sdbm_store(db,key,value,flags)
-#define sdbm_DELETE(db,key)			sdbm_delete(db,key)
-#define sdbm_EXISTS(db,key)			sdbm_exists(db,key)
-#define sdbm_FIRSTKEY(db)			sdbm_firstkey(db)
-#define sdbm_NEXTKEY(db,key)			sdbm_nextkey(db)
+#define sdbm_FETCH(db,key)			sdbm_fetch(db->dbp,key)
+#define sdbm_STORE(db,key,value,flags)		sdbm_store(db->dbp,key,value,flags)
+#define sdbm_DELETE(db,key)			sdbm_delete(db->dbp,key)
+#define sdbm_EXISTS(db,key)			sdbm_exists(db->dbp,key)
+#define sdbm_FIRSTKEY(db)			sdbm_firstkey(db->dbp)
+#define sdbm_NEXTKEY(db,key)			sdbm_nextkey(db->dbp)
 
 
 MODULE = SDBM_File	PACKAGE = SDBM_File	PREFIX = sdbm_
@@ -21,23 +54,46 @@ sdbm_TIEHASH(dbtype, filename, flags, mode)
 	char *		filename
 	int		flags
 	int		mode
+	CODE:
+	{
+	    DBM * 	dbp ;
+
+	    RETVAL = NULL ;
+	    if (dbp = sdbm_open(filename,flags,mode) ) {
+	        RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ;
+    	        Zero(RETVAL, 1, SDBM_File_type) ;
+		RETVAL->dbp = dbp ;
+	    }
+	    
+	}
+	OUTPUT:
+	  RETVAL
 
 void
 sdbm_DESTROY(db)
 	SDBM_File	db
 	CODE:
-	sdbm_close(db);
+	  sdbm_close(db->dbp);
+	  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) ;
+	  Safefree(db) ;	
 
-datum
+datum_value
 sdbm_FETCH(db, key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
 int
 sdbm_STORE(db, key, value, flags = DBM_REPLACE)
 	SDBM_File	db
-	datum		key
-	datum		value
+	datum_key	key
+	datum_value	value
 	int		flags
     CLEANUP:
 	if (RETVAL) {
@@ -45,7 +101,7 @@ sdbm_STORE(db, key, value, flags = DBM_REPLACE)
 		croak("No write permission to sdbm file");
 	    croak("sdbm store returned %d, errno %d, key \"%s\"",
 			RETVAL,errno,key.dptr);
-	    sdbm_clearerr(db);
+	    sdbm_clearerr(db->dbp);
 	}
 
 int
@@ -56,22 +112,89 @@ sdbm_DELETE(db, key)
 int
 sdbm_EXISTS(db,key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
-datum
+datum_key
 sdbm_FIRSTKEY(db)
 	SDBM_File	db
 
-datum
+datum_key
 sdbm_NEXTKEY(db, key)
 	SDBM_File	db
-	datum		key
+	datum_key	key
 
 int
 sdbm_error(db)
 	SDBM_File	db
+	CODE:
+	RETVAL = sdbm_error(db->dbp) ;
+	OUTPUT:
+	  RETVAL
 
 int
 sdbm_clearerr(db)
 	SDBM_File	db
+	CODE:
+	RETVAL = sdbm_clearerr(db->dbp) ;
+	OUTPUT:
+	  RETVAL
+
+
+#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)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL = &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_key(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_key) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_fetch_value(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_fetch_value) ;
+	OUTPUT:
+	    RETVAL
+
+SV *
+filter_store_value(db, code)
+	SDBM_File	db
+	SV *		code
+	SV *		RETVAL =  &PL_sv_undef ;
+	CODE:
+	    setFilter(filter_store_value) ;
+	OUTPUT:
+	    RETVAL
 
diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap
index 317a8f3886..eeb5d59027 100644
--- a/ext/SDBM_File/typemap
+++ b/ext/SDBM_File/typemap
@@ -2,7 +2,8 @@
 #################################### DBM SECTION
 #
 
-datum			T_DATUM
+datum_key		T_DATUM_K
+datum_value		T_DATUM_V
 gdatum			T_GDATUM
 NDBM_File		T_PTROBJ
 GDBM_File		T_PTROBJ
@@ -13,14 +14,23 @@ DBZ_File		T_PTROBJ
 FATALFUNC		T_OPAQUEPTR
 
 INPUT
-T_DATUM
+T_DATUM_K
+	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\");
 	$var.dptr = SvPV($arg, PL_na);
 	$var.dsize = (int)PL_na;
 T_GDATUM
 	UNIMPLEMENTED
 OUTPUT
-T_DATUM
+T_DATUM_K
+	sv_setpvn($arg, $var.dptr, $var.dsize);
+	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\");
 T_GDATUM
 	sv_usepvn($arg, $var.dptr, $var.dsize);
 T_PTROBJ
diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm
index aff3c7cdec..9cf9b31834 100644
--- a/lib/AnyDBM_File.pm
+++ b/lib/AnyDBM_File.pm
@@ -87,6 +87,6 @@ By default, but can be redefined.
 
 =head1 SEE ALSO
 
-dbm(3), ndbm(3), DB_File(3)
+dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
 
 =cut
diff --git a/pod/Makefile b/pod/Makefile
index f70c11b173..7db379ca90 100644
--- a/pod/Makefile
+++ b/pod/Makefile
@@ -43,6 +43,7 @@ POD = \
 	perlbot.pod	\
 	perlipc.pod	\
 	perlthrtut.pod	\
+	perldbmfilter.pod	\
 	perldebug.pod	\
 	perldiag.pod	\
 	perlsec.pod	\
@@ -100,6 +101,7 @@ MAN = \
 	perlbot.man	\
 	perlipc.man	\
 	perlthrtut.man	\
+	perldbmfilter.man	\
 	perldebug.man	\
 	perldiag.man	\
 	perlsec.man	\
@@ -157,6 +159,7 @@ HTML = \
 	perlbot.html	\
 	perlipc.html	\
 	perlthrtut.html	\
+	perldbmfilter.html	\
 	perldebug.html	\
 	perldiag.html	\
 	perlsec.html	\
@@ -214,6 +217,7 @@ TEX = \
 	perlbot.tex	\
 	perlipc.tex	\
 	perlthrtut.tex	\
+	perldbmfilter.tex	\
 	perldebug.tex	\
 	perldiag.tex	\
 	perlsec.tex	\
diff --git a/pod/buildtoc b/pod/buildtoc
index 8df5726771..62df02baba 100644
--- a/pod/buildtoc
+++ b/pod/buildtoc
@@ -10,7 +10,7 @@ sub output ($);
 	   perlsyn perlop perlre perlrun perlfunc perlvar perlsub
 	   perlmod perlmodlib perlmodinstall perlform perllocale 
 	   perlref perlreftut perldsc
-	   perllol perltoot perlobj perltie perlbot perlipc perldebug
+	   perllol perltoot perlobj perltie perlbot perlipc perldbmfilter perldebug
 	   perldiag perlsec perltrap perlport perlstyle perlpod perlbook
 	   perlembed perlapio perlxs perlxstut perlguts perlcall
 	   perlhist
diff --git a/pod/perl.pod b/pod/perl.pod
index 6605097689..8f688c72c4 100644
--- a/pod/perl.pod
+++ b/pod/perl.pod
@@ -50,6 +50,7 @@ of sections:
     perlbot		Perl OO tricks and examples
     perlipc		Perl interprocess communication
     perlthrtut		Perl threads tutorial
+    perldbmfilter	Perl DBM Filters
 
     perldebug		Perl debugging
     perldiag		Perl diagnostic messages
diff --git a/pod/perldbmfilter.pod b/pod/perldbmfilter.pod
new file mode 100644
index 0000000000..faed2d25d2
--- /dev/null
+++ b/pod/perldbmfilter.pod
@@ -0,0 +1,165 @@
+=head1 NAME
+
+perldbmfilter - Perl DBM Filters
+
+=head1 SYNOPSIS
+
+    $db = tie %hash, 'DBM', ...
+
+    $old_filter = $db->filter_store_key  ( sub { ... } ) ;
+    $old_filter = $db->filter_store_value( sub { ... } ) ;
+    $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;
+    $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
+=head1 DESCRIPTION
+
+The four C<filter_*> methods shown above are available in all the DBM
+modules that ship with Perl, namely DB_File, GDBM_File, NDBM_File,
+ODBM_File and SDBM_File.
+
+Each of the methods work identically, and are used to install (or
+uninstall) a single DBM Filter. The only difference between them is the
+place that the filter is installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods from none to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+DBM Filters are useful for a class of problems where you I<always>
+want to make the same transformation to all keys, all values or both.
+
+For example, consider the following scenario. You have a DBM database
+that you need to share with a third-party C application. The C application
+assumes that I<all> keys and values are NULL terminated. Unfortunately
+when Perl writes to DBM databases it doesn't use NULL termination, so
+your Perl application will have to manage NULL termination itself. When
+you write to the database you will have to use something like this:
+
+    $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+    use strict ;
+    use SDBM_File ;
+    use Fcntl ;
+
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+    my $db = tie(%hash, 'SDBM_File', $filename, O_RDWR|O_CREAT, 0640)
+      or die "Cannot open $filename: $!\n" ;
+
+    # Install DBM Filters
+    $db->filter_fetch_key  ( sub { s/\0$//    } ) ;
+    $db->filter_store_key  ( sub { $_ .= "\0" } ) ;
+    $db->filter_fetch_value( sub { s/\0$//    } ) ;
+    $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+    $hash{"abc"} = "def" ;
+    my $a = $hash{"ABC"} ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+The code above uses SDBM_File, but it will work with any of the DBM
+modules.
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+    $hash{12345} = "soemthing" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+    use strict ;
+    use DB_File ;
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+
+    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
+      or die "Cannot open $filename: $!\n" ;
+
+    $db->filter_fetch_key  ( sub { $_ = unpack("i", $_) } ) ;
+    $db->filter_store_key  ( sub { $_ = pack ("i", $_) } ) ;
+    $hash{123} = "def" ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+The code above uses DB_File, but again it will work with any of the
+DBM modules.
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
+=head1 SEE ALSO
+
+L<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File> and L<SDBM_File>.
+
+=head1 AUTHOR
+
+Paul Marquess
+
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index beb25c74f5..a7bbb2a400 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -386,6 +386,21 @@ pathname for FILENAME in scalar context. In list context it returns
 a two element list containing the fully qualified directory name and
 the filename.
 
+=item DBM Filters
+
+A new feature called "DBM Filters" has been added to all the
+DBM modules -- DB_File, GDBM_File, NDBM_File, ODBM_File and SDBM_File.
+DBM Filters add four new methods to each of the DBM modules 
+
+    filter_store_key
+    filter_store_value
+    filter_fetch_key
+    filter_fetch_value
+
+These can be used to filter the contents of keys/values before they are
+written to the database or just after they are read from the database.
+See L<perldbmfilter> for further information.
+
 =back
 
 =head2 Pragmata
diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t
index 1ebc64df35..7f982d6fd6 100755
--- a/t/lib/db-btree.t
+++ b/t/lib/db-btree.t
@@ -12,7 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..102\n";
+print "1..148\n";
 
 sub ok
 {
@@ -38,7 +38,7 @@ sub lexical
     return @a - @b ;
 }
 
-$Dfile = "dbbtree.tmp";
+my $Dfile = "dbbtree.tmp";
 unlink $Dfile;
 
 umask(0);
@@ -609,4 +609,191 @@ EOM
 
 }
 
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(104, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(105, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(106, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(107, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(108, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(109, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(110, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(111, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(112, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(113, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(114, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(115, $h{"fred"} eq "joe");
+   ok(116, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(117, $db->FIRSTKEY() eq "fred") ;
+   ok(118, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(119, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(120, $h{"fred"} eq "joe");
+   ok(121, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(122, $db->FIRSTKEY() eq "fred") ;
+   ok(123, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink $Dfile;
+    ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(125, $result{"store key"} eq "store key - 1: [fred]");
+    ok(126, $result{"store value"} eq "store value - 1: [joe]");
+    ok(127, ! defined $result{"fetch key"} );
+    ok(128, ! defined $result{"fetch value"} );
+    ok(129, $_ eq "original") ;
+
+    ok(130, $db->FIRSTKEY() eq "fred") ;
+    ok(131, $result{"store key"} eq "store key - 1: [fred]");
+    ok(132, $result{"store value"} eq "store value - 1: [joe]");
+    ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(134, ! defined $result{"fetch value"} );
+    ok(135, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(136, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(137, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(139, ! defined $result{"fetch value"} );
+    ok(140, $_ eq "original") ;
+
+    ok(141, $h{"fred"} eq "joe");
+    ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(143, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(146, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink $Dfile;
+
+   ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(148, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+
 exit ;
diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t
index 9f2456f7bb..21f2aadada 100755
--- a/t/lib/db-hash.t
+++ b/t/lib/db-hash.t
@@ -12,7 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..62\n";
+print "1..108\n";
 
 sub ok
 {
@@ -23,7 +23,7 @@ sub ok
     print "ok $no\n" ;
 }
 
-$Dfile = "dbhash.tmp";
+my $Dfile = "dbhash.tmp";
 unlink $Dfile;
 
 umask(0);
@@ -413,4 +413,191 @@ EOM
     unlink "SubDB.pm", "dbhash.tmp" ;
 
 }
+
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(64, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(65, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(66, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(67, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(68, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(69, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(70, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(72, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(73, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(74, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(75, $h{"fred"} eq "joe");
+   ok(76, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(77, $db->FIRSTKEY() eq "fred") ;
+   ok(78, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(79, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(80, $h{"fred"} eq "joe");
+   ok(81, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(82, $db->FIRSTKEY() eq "fred") ;
+   ok(83, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink $Dfile;
+    ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(85, $result{"store key"} eq "store key - 1: [fred]");
+    ok(86, $result{"store value"} eq "store value - 1: [joe]");
+    ok(87, ! defined $result{"fetch key"} );
+    ok(88, ! defined $result{"fetch value"} );
+    ok(89, $_ eq "original") ;
+
+    ok(90, $db->FIRSTKEY() eq "fred") ;
+    ok(91, $result{"store key"} eq "store key - 1: [fred]");
+    ok(92, $result{"store value"} eq "store value - 1: [joe]");
+    ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(94, ! defined $result{"fetch value"} );
+    ok(95, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(97, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(99, ! defined $result{"fetch value"} );
+    ok(100, $_ eq "original") ;
+
+    ok(101, $h{"fred"} eq "joe");
+    ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(103, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(106, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink $Dfile;
+
+   ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink $Dfile;
+}
+
 exit ;
diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t
index d5afeb0e0d..cb223b1bc8 100755
--- a/t/lib/db-recno.t
+++ b/t/lib/db-recno.t
@@ -56,7 +56,7 @@ sub bad_one
 EOM
 }
 
-print "1..78\n";
+print "1..124\n";
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -452,4 +452,190 @@ EOM
 
 }
 
+{
+   # DBM Filter tests
+   use strict ;
+   my (@h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   unlink $Dfile;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h[0] = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(80, checkOutput( "", 0, "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(81, $h[0] eq "joe");
+   #                   fk  sk  fv    sv
+   ok(82, checkOutput( "", 0, "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(83, $db->FIRSTKEY() == 0) ;
+   #                    fk     sk  fv  sv
+   ok(84, checkOutput( 0, "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { ++ $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ *= 2 ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[1] = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(85, checkOutput( "", 2, "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(86, $h[1] eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(87, checkOutput( "", 2, "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(88, $db->FIRSTKEY() == 1) ;
+   #                   fk   sk     fv    sv
+   ok(89, checkOutput( 1, "", "", "")) ;
+   
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[0] = "joe" ;
+   ok(90, checkOutput( "", 0, "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(91, $h[0] eq "joe");
+   ok(92, checkOutput( "", 0, "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(93, $db->FIRSTKEY() == 0) ;
+   ok(94, checkOutput( 0, "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h[0] = "joe" ;
+   ok(95, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(96, $h[0] eq "joe");
+   ok(97, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(98, $db->FIRSTKEY() == 0) ;
+   ok(99, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie @h;
+   unlink $Dfile;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (@h, $db) ;
+
+    unlink $Dfile;
+    ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h[0] = "joe" ;
+    ok(101, $result{"store key"} eq "store key - 1: [0]");
+    ok(102, $result{"store value"} eq "store value - 1: [joe]");
+    ok(103, ! defined $result{"fetch key"} );
+    ok(104, ! defined $result{"fetch value"} );
+    ok(105, $_ eq "original") ;
+
+    ok(106, $db->FIRSTKEY() == 0 ) ;
+    ok(107, $result{"store key"} eq "store key - 1: [0]");
+    ok(108, $result{"store value"} eq "store value - 1: [joe]");
+    ok(109, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(110, ! defined $result{"fetch value"} );
+    ok(111, $_ eq "original") ;
+
+    $h[7]  = "john" ;
+    ok(112, $result{"store key"} eq "store key - 2: [0 7]");
+    ok(113, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(114, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(115, ! defined $result{"fetch value"} );
+    ok(116, $_ eq "original") ;
+
+    ok(117, $h[0] eq "joe");
+    ok(118, $result{"store key"} eq "store key - 3: [0 7 0]");
+    ok(119, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(120, $result{"fetch key"} eq "fetch key - 1: [0]");
+    ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(122, $_ eq "original") ;
+
+    undef $db ;
+    untie @h;
+    unlink $Dfile;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (@h, $db) ;
+   unlink $Dfile;
+
+   ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );
+
+   $db->filter_store_key (sub { $_ = $h[0] }) ;
+
+   eval '$h[1] = 1234' ;
+   ok(124, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie @h;
+   unlink $Dfile;
+}
+
 exit ;
diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t
index f88d4708bb..d8c0ed29c3 100755
--- a/t/lib/gdbm.t
+++ b/t/lib/gdbm.t
@@ -13,7 +13,7 @@ BEGIN {
 
 use GDBM_File;
 
-print "1..20\n";
+print "1..66\n";
 
 unlink <Op.dbmx*>;
 
@@ -206,3 +206,189 @@ EOM
     unlink "SubDB.pm", <dbhash.tmp*> ;
 
 }
+
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   unlink <Op.dbmx*>;
+   ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(23, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(25, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(26, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(28, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(30, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(31, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(33, $h{"fred"} eq "joe");
+   ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(35, $db->FIRSTKEY() eq "fred") ;
+   ok(36, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(37, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(38, $h{"fred"} eq "joe");
+   ok(39, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(40, $db->FIRSTKEY() eq "fred") ;
+   ok(41, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink <Op.dbmx*>;
+    ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(43, $result{"store key"} eq "store key - 1: [fred]");
+    ok(44, $result{"store value"} eq "store value - 1: [joe]");
+    ok(45, !defined $result{"fetch key"} );
+    ok(46, !defined $result{"fetch value"} );
+    ok(47, $_ eq "original") ;
+
+    ok(48, $db->FIRSTKEY() eq "fred") ;
+    ok(49, $result{"store key"} eq "store key - 1: [fred]");
+    ok(50, $result{"store value"} eq "store value - 1: [joe]");
+    ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(52, ! defined $result{"fetch value"} );
+    ok(53, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(57, $result{"fetch value"} eq "");
+    ok(58, $_ eq "original") ;
+
+    ok(59, $h{"fred"} eq "joe");
+    ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(64, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink <Op.dbmx*>;
+}
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink <Op.dbmx*>;
+
+   ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t
index be122ff687..de42c0d990 100755
--- a/t/lib/ndbm.t
+++ b/t/lib/ndbm.t
@@ -16,7 +16,7 @@ require NDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..18\n";
+print "1..64\n";
 
 unlink <Op.dbmx*>;
 
@@ -205,3 +205,189 @@ EOM
     unlink "SubDB.pm", <dbhash.tmp*> ;
 
 }
+
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   unlink <Op.dbmx*>;
+   ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(21, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(23, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(24, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(26, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(28, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(29, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(31, $h{"fred"} eq "joe");
+   ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(33, $db->FIRSTKEY() eq "fred") ;
+   ok(34, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(35, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(36, $h{"fred"} eq "joe");
+   ok(37, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(38, $db->FIRSTKEY() eq "fred") ;
+   ok(39, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink <Op.dbmx*>;
+    ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(41, $result{"store key"} eq "store key - 1: [fred]");
+    ok(42, $result{"store value"} eq "store value - 1: [joe]");
+    ok(43, !defined $result{"fetch key"} );
+    ok(44, !defined $result{"fetch value"} );
+    ok(45, $_ eq "original") ;
+
+    ok(46, $db->FIRSTKEY() eq "fred") ;
+    ok(47, $result{"store key"} eq "store key - 1: [fred]");
+    ok(48, $result{"store value"} eq "store value - 1: [joe]");
+    ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(50, ! defined $result{"fetch value"} );
+    ok(51, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(55, $result{"fetch value"} eq "");
+    ok(56, $_ eq "original") ;
+
+    ok(57, $h{"fred"} eq "joe");
+    ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(62, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink <Op.dbmx*>;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink <Op.dbmx*>;
+
+   ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
diff --git a/t/lib/odbm.t b/t/lib/odbm.t
index 78d8593319..c5458d5e19 100755
--- a/t/lib/odbm.t
+++ b/t/lib/odbm.t
@@ -16,7 +16,7 @@ require ODBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..18\n";
+print "1..64\n";
 
 unlink <Op.dbmx*>;
 
@@ -205,3 +205,189 @@ EOM
     unlink "SubDB.pm", <dbhash.tmp*> ;
 
 }
+
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   unlink <Op.dbmx*>;
+   ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(21, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(23, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(24, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(26, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(28, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(29, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(31, $h{"fred"} eq "joe");
+   ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(33, $db->FIRSTKEY() eq "fred") ;
+   ok(34, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(35, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(36, $h{"fred"} eq "joe");
+   ok(37, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(38, $db->FIRSTKEY() eq "fred") ;
+   ok(39, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink <Op.dbmx*>;
+    ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(41, $result{"store key"} eq "store key - 1: [fred]");
+    ok(42, $result{"store value"} eq "store value - 1: [joe]");
+    ok(43, !defined $result{"fetch key"} );
+    ok(44, !defined $result{"fetch value"} );
+    ok(45, $_ eq "original") ;
+
+    ok(46, $db->FIRSTKEY() eq "fred") ;
+    ok(47, $result{"store key"} eq "store key - 1: [fred]");
+    ok(48, $result{"store value"} eq "store value - 1: [joe]");
+    ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(50, ! defined $result{"fetch value"} );
+    ok(51, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(55, $result{"fetch value"} eq "");
+    ok(56, $_ eq "original") ;
+
+    ok(57, $h{"fred"} eq "joe");
+    ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(62, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink <Op.dbmx*>;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink <Op.dbmx*>;
+
+   ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t
index af796c1b31..2689d1962e 100755
--- a/t/lib/sdbm.t
+++ b/t/lib/sdbm.t
@@ -15,7 +15,7 @@ require SDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..20\n";
+print "1..66\n";
 
 unlink <Op_dbmx.*>;
 
@@ -208,8 +208,191 @@ ok(19, !exists $h{'goner1'});
 ok(20, exists $h{'foo'});
 
 untie %h;
-if ($^O eq 'VMS') {
-  unlink 'Op_dbmx.sdbm_dir', $Dfile;
-} else {
-  unlink 'Op_dbmx.dir', $Dfile;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+   # DBM Filter tests
+   use strict ;
+   my (%h, $db) ;
+   my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+   sub checkOutput
+   {
+       my($fk, $sk, $fv, $sv) = @_ ;
+       return
+           $fetch_key eq $fk && $store_key eq $sk && 
+	   $fetch_value eq $fv && $store_value eq $sv &&
+	   $_ eq 'original' ;
+   }
+   
+   unlink <Op_dbmx*>;
+   ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
+   $db->filter_store_key   (sub { $store_key = $_ }) ;
+   $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+   $db->filter_store_value (sub { $store_value = $_ }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   #                   fk   sk     fv   sv
+   ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(23, $h{"fred"} eq "joe");
+   #                   fk    sk     fv    sv
+   ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(25, $db->FIRSTKEY() eq "fred") ;
+   #                    fk     sk  fv  sv
+   ok(26, checkOutput( "fred", "", "", "")) ;
+
+   # replace the filters, but remember the previous set
+   my ($old_fk) = $db->filter_fetch_key   
+   			(sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+   my ($old_sk) = $db->filter_store_key   
+   			(sub { $_ = lc $_ ; $store_key = $_ }) ;
+   my ($old_fv) = $db->filter_fetch_value 
+   			(sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+   my ($old_sv) = $db->filter_store_value 
+   			(sub { s/o/x/g; $store_value = $_ }) ;
+   
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"Fred"} = "Joe" ;
+   #                   fk   sk     fv    sv
+   ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(28, $h{"Fred"} eq "[Jxe]");
+   #                   fk   sk     fv    sv
+   ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(30, $db->FIRSTKEY() eq "FRED") ;
+   #                   fk   sk     fv    sv
+   ok(31, checkOutput( "FRED", "", "", "")) ;
+
+   # put the original filters back
+   $db->filter_fetch_key   ($old_fk);
+   $db->filter_store_key   ($old_sk);
+   $db->filter_fetch_value ($old_fv);
+   $db->filter_store_value ($old_sv);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(33, $h{"fred"} eq "joe");
+   ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(35, $db->FIRSTKEY() eq "fred") ;
+   ok(36, checkOutput( "fred", "", "", "")) ;
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   $h{"fred"} = "joe" ;
+   ok(37, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(38, $h{"fred"} eq "joe");
+   ok(39, checkOutput( "", "", "", "")) ;
+
+   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+   ok(40, $db->FIRSTKEY() eq "fred") ;
+   ok(41, checkOutput( "", "", "", "")) ;
+
+   undef $db ;
+   untie %h;
+   unlink <Op_dbmx*>;
+}
+
+{    
+    # DBM Filter with a closure
+
+    use strict ;
+    my (%h, $db) ;
+
+    unlink <Op_dbmx*>;
+    ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+    my %result = () ;
+
+    sub Closure
+    {
+        my ($name) = @_ ;
+	my $count = 0 ;
+	my @kept = () ;
+
+	return sub { ++$count ; 
+		     push @kept, $_ ; 
+		     $result{$name} = "$name - $count: [@kept]" ;
+		   }
+    }
+
+    $db->filter_store_key(Closure("store key")) ;
+    $db->filter_store_value(Closure("store value")) ;
+    $db->filter_fetch_key(Closure("fetch key")) ;
+    $db->filter_fetch_value(Closure("fetch value")) ;
+
+    $_ = "original" ;
+
+    $h{"fred"} = "joe" ;
+    ok(43, $result{"store key"} eq "store key - 1: [fred]");
+    ok(44, $result{"store value"} eq "store value - 1: [joe]");
+    ok(45, !defined $result{"fetch key"} );
+    ok(46, !defined $result{"fetch value"} );
+    ok(47, $_ eq "original") ;
+
+    ok(48, $db->FIRSTKEY() eq "fred") ;
+    ok(49, $result{"store key"} eq "store key - 1: [fred]");
+    ok(50, $result{"store value"} eq "store value - 1: [joe]");
+    ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(52, ! defined $result{"fetch value"} );
+    ok(53, $_ eq "original") ;
+
+    $h{"jim"}  = "john" ;
+    ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+    ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(57, $result{"fetch value"} eq "");
+    ok(58, $_ eq "original") ;
+
+    ok(59, $h{"fred"} eq "joe");
+    ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+    ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+    ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+    ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+    ok(64, $_ eq "original") ;
+
+    undef $db ;
+    untie %h;
+    unlink <Op_dbmx*>;
+}		
+
+{
+   # DBM Filter recursion detection
+   use strict ;
+   my (%h, $db) ;
+   unlink <Op_dbmx*>;
+
+   ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+   eval '$h{1} = 1234' ;
+   ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+   
+   undef $db ;
+   untie %h;
+   unlink <Op_dbmx*>;
 }
+
author	Paul Marquess <paul.marquess@btinternet.com>	1999-04-18 22:05:52 +0100
committer	Gurusamy Sarathy <gsar@cpan.org>	1999-05-07 04:18:11 +0000
commit	9fe6733ac5627eddc014ed5f2afb208fa4afd501 (patch)
tree	fdda517b5f127b50bec181cf6351e2957d9e27fc
parent	fdb068fae82a164ca46639e6b096f05aeb3dc5ea (diff)
download	perl-9fe6733ac5627eddc014ed5f2afb208fa4afd501.tar.gz