This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
DBM Filters (via private mail)
authorPaul Marquess <paul.marquess@btinternet.com>
Sun, 18 Apr 1999 21:05:52 +0000 (22:05 +0100)
committerGurusamy Sarathy <gsar@cpan.org>
Fri, 7 May 1999 04:18:11 +0000 (04:18 +0000)
Message-Id: <199904182009.NAA19152@activestate.com>
Subject: DBM Filters

p4raw-id: //depot/perl@3317

30 files changed:
MANIFEST
ext/DB_File/Changes
ext/DB_File/DB_File.pm
ext/DB_File/DB_File.xs
ext/DB_File/typemap
ext/GDBM_File/GDBM_File.pm
ext/GDBM_File/GDBM_File.xs
ext/GDBM_File/typemap
ext/NDBM_File/NDBM_File.pm
ext/NDBM_File/NDBM_File.xs
ext/NDBM_File/typemap
ext/ODBM_File/ODBM_File.pm
ext/ODBM_File/ODBM_File.xs
ext/ODBM_File/typemap
ext/SDBM_File/SDBM_File.pm
ext/SDBM_File/SDBM_File.xs
ext/SDBM_File/typemap
lib/AnyDBM_File.pm
pod/Makefile
pod/buildtoc
pod/perl.pod
pod/perldbmfilter.pod [new file with mode: 0644]
pod/perldelta.pod
t/lib/db-btree.t
t/lib/db-hash.t
t/lib/db-recno.t
t/lib/gdbm.t
t/lib/ndbm.t
t/lib/odbm.t
t/lib/sdbm.t

index 60612f2..bb9cb4b 100644 (file)
--- 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
index 2fab919..82d9af5 100644 (file)
    * 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
index e5759ff..7e6c907 100644 (file)
@@ -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
 
index 3f6c094..cdadf29 100644 (file)
@@ -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
 
 
 
 #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 */
index 994ba27..29dc778 100644 (file)
@@ -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);
index af9a5dc..42bb6d2 100644 (file)
@@ -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);
index 808850d..275c509 100644 (file)
@@ -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
+
index d122d07..20d5cd9 100644 (file)
@@ -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);
index ed4fe2b..cad800a 100644 (file)
@@ -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
index d129a9c..f5bc0f9 100644 (file)
@@ -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
+
index 317a8f3..eeb5d59 100644 (file)
@@ -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
index 923640f..572318b 100644 (file)
@@ -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
index 892c038..0ab06ef 100644 (file)
 
 #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
 
index 5e12e73..7c23815 100644 (file)
@@ -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);
index a2d4df8..006bbbd 100644 (file)
@@ -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
index 789e5c8..681cf14 100644 (file)
@@ -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
 
index 317a8f3..eeb5d59 100644 (file)
@@ -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
index aff3c7c..9cf9b31 100644 (file)
@@ -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
index f70c11b..7db379c 100644 (file)
@@ -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     \
index 8df5726..62df02b 100644 (file)
@@ -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
index 6605097..8f688c7 100644 (file)
@@ -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 (file)
index 0000000..faed2d2
--- /dev/null
@@ -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
+
index beb25c7..a7bbb2a 100644 (file)
@@ -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
index 1ebc64d..7f982d6 100755 (executable)
@@ -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 ;
index 9f2456f..21f2aad 100755 (executable)
@@ -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 ;
index d5afeb0..cb223b1 100755 (executable)
@@ -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 ;
index f88d470..d8c0ed2 100755 (executable)
@@ -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*>;
+}
index be122ff..de42c0d 100755 (executable)
@@ -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*>;
+}
index 78d8593..c5458d5 100755 (executable)
@@ -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*>;
+}
index af796c1..2689d19 100755 (executable)
@@ -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*>;
 }
+