Fix DBM filters

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

p4raw-id: //depot/perl@17750

diff --git a/XSUB.h b/XSUB.h
index 2d1b8ed..a2826ea 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -228,6 +228,49 @@ C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
 #  define XS_VERSION_BOOTCHECK
 #endif
 
+/* 
+   The DBM_setFilter & DBM_ckFilter macros are only used by 
+   the *DB*_File modules 
+*/
+
+#define DBM_setFilter(db_type,code)                            \
+       {                                                       \
+           if (db_type)                                        \
+               RETVAL = sv_mortalcopy(db_type) ;               \
+           ST(0) = RETVAL ;                                    \
+           if (db_type && (code == &PL_sv_undef)) {            \
+                SvREFCNT_dec(db_type) ;                                \
+               db_type = NULL ;                                \
+           }                                                   \
+           else if (code) {                                    \
+               if (db_type)                                    \
+                   sv_setsv(db_type, code) ;                   \
+               else                                            \
+                   db_type = newSVsv(code) ;                   \
+           }                                                   \
+       }
+
+#define DBM_ckFilter(arg,type,name)                            \
+       if (db->type) {                                         \
+           if (db->filtering) {                                \
+               croak("recursion detected in %s", name) ;       \
+           }                                                   \
+           ENTER ;                                             \
+           SAVETMPS ;                                          \
+           SAVEINT(db->filtering) ;                            \
+           db->filtering = TRUE ;                              \
+           SAVESPTR(DEFSV) ;                                   \
+           DEFSV = arg ;                                       \
+           SvTEMP_off(arg) ;                                   \
+           PUSHMARK(SP) ;                                      \
+           PUTBACK ;                                           \
+           (void) perl_call_sv(db->type, G_DISCARD);           \
+           SPAGAIN ;                                           \
+           PUTBACK ;                                           \
+           FREETMPS ;                                          \
+           LEAVE ;                                             \
+       }
+
 #if 1          /* for compatibility */
 #  define VTBL_sv              &PL_vtbl_sv
 #  define VTBL_env             &PL_vtbl_env

diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index fc2f63e..489ba96 100644 (file)
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -162,7 +162,6 @@
 #include <fcntl.h> 
 
 /* #define TRACE */
-#define DBM_FILTERING
 
 #ifdef TRACE
 #    define Trace(x)        printf x
@@ -367,51 +366,23 @@ typedef struct {
 #ifdef DB_VERSION_MAJOR
        DBC *   cursor ;
 #endif
-#ifdef DBM_FILTERING
        SV *    filter_fetch_key ;
        SV *    filter_store_key ;
        SV *    filter_fetch_value ;
        SV *    filter_store_value ;
        int     filtering ;
-#endif /* DBM_FILTERING */
 
        } DB_File_type;
 
 typedef DB_File_type * DB_File ;
 typedef DBT DBTKEY ;
 
-#ifdef DBM_FILTERING
-
-#define ckFilter(arg,type,name)                                        \
-       if (db->type) {                                         \
-           SV * save_defsv ;                                   \
-            /* printf("filtering %s\n", name) ; */             \
-           if (db->filtering)                                  \
-               croak("recursion detected in %s", name) ;       \
-           db->filtering = TRUE ;                              \
-           save_defsv = newSVsv(DEFSV) ;                       \
-           sv_setsv(DEFSV, arg) ;                              \
-           PUSHMARK(sp) ;                                      \
-           (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                       \
-           SvREFCNT_dec(save_defsv) ;                          \
-           db->filtering = FALSE ;                             \
-           /* printf("end of filtering %s\n", name) ; */       \
-       }
-
-#else
-
-#define ckFilter(arg,type, name)
-
-#endif /* DBM_FILTERING */
-
 #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
 
 #define OutputValue(arg, name)                                         \
        { if (RETVAL == 0) {                                            \
              my_sv_setpvn(arg, name.data, name.size) ;                 \
-             ckFilter(arg, filter_fetch_value,"filter_fetch_value") ;  \
+             DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ;      \
          }                                                             \
        }
 
@@ -423,7 +394,7 @@ typedef DBT DBTKEY ;
                }                                                       \
                else                                                    \
                    sv_setiv(arg, (I32)*(I32*)name.data - 1);           \
-             ckFilter(arg, filter_fetch_key,"filter_fetch_key") ;      \
+             DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ;  \
          }                                                             \
        }
 
@@ -876,11 +847,9 @@ SV *   sv ;
     Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
-#ifdef DBM_FILTERING
     RETVAL->filtering = 0 ;
     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
-#endif /* DBM_FILTERING */
     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
     RETVAL->type = DB_HASH ;
 
@@ -1150,11 +1119,9 @@ SV *   sv ;
     Zero(RETVAL, 1, DB_File_type) ;
 
     /* Default to HASH */
-#ifdef DBM_FILTERING
     RETVAL->filtering = 0 ;
     RETVAL->filter_fetch_key = RETVAL->filter_store_key = 
     RETVAL->filter_fetch_value = RETVAL->filter_store_value =
-#endif /* DBM_FILTERING */
     RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
     RETVAL->type = DB_HASH ;
 
@@ -1444,7 +1411,6 @@ db_DESTROY(db)
            SvREFCNT_dec(db->compare) ;
          if (db->prefix)
            SvREFCNT_dec(db->prefix) ;
-#ifdef DBM_FILTERING
          if (db->filter_fetch_key)
            SvREFCNT_dec(db->filter_fetch_key) ;
          if (db->filter_store_key)
@@ -1453,7 +1419,6 @@ db_DESTROY(db)
            SvREFCNT_dec(db->filter_fetch_value) ;
          if (db->filter_store_value)
            SvREFCNT_dec(db->filter_store_value) ;
-#endif /* DBM_FILTERING */
          safefree(db) ;
 #ifdef DB_VERSION_MAJOR
          if (RETVAL > 0)
@@ -1857,33 +1822,13 @@ db_seq(db, key, value, flags)
          key
          value
 
-#ifdef DBM_FILTERING
-
-#define setFilter(type)                                        \
-       {                                               \
-           if (db->type)                               \
-               RETVAL = sv_mortalcopy(db->type) ;      \
-           ST(0) = RETVAL ;                            \
-           if (db->type && (code == &PL_sv_undef)) {   \
-                SvREFCNT_dec(db->type) ;               \
-               db->type = NULL ;                       \
-           }                                           \
-           else if (code) {                            \
-               if (db->type)                           \
-                   sv_setsv(db->type, code) ;          \
-               else                                    \
-                   db->type = newSVsv(code) ;          \
-           }                                           \
-       }
-
-
 SV *
 filter_fetch_key(db, code)
        DB_File         db
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_key) ;
+           DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -1891,7 +1836,7 @@ filter_store_key(db, code)
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_key) ;
+           DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -1899,7 +1844,7 @@ filter_fetch_value(db, code)
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_value) ;
+           DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -1907,6 +1852,5 @@ filter_store_value(db, code)
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_value) ;
+           DBM_setFilter(db->filter_store_value, code) ;
 
-#endif /* DBM_FILTERING */

diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 55439ee..ecd3785 100644 (file)
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -15,7 +15,7 @@ DBTKEY                        T_dbtkeydatum
 
 INPUT
 T_dbtkeydatum
-       ckFilter($arg, filter_store_key, \"filter_store_key\");
+       DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
        DBT_clear($var) ;
        if (db->type != DB_RECNO) {
            $var.data = SvPV($arg, PL_na);
@@ -27,7 +27,7 @@ T_dbtkeydatum
            $var.size = (int)sizeof(recno_t);
        }
 T_dbtdatum
-       ckFilter($arg, filter_store_value, \"filter_store_value\");
+       DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        DBT_clear($var) ;
        if (SvOK($arg)) {
            $var.data = SvPV($arg, PL_na);

diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index 5684a96..22350fd 100644 (file)
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -19,26 +19,6 @@ typedef datum datum_key ;
 typedef datum datum_value ;
 typedef datum datum_key_copy;
 
-#define ckFilter(arg,type,name)                                        \
-       if (db->type) {                                         \
-           SV * save_defsv ;                                   \
-            /* printf("filtering %s\n", name) ;*/              \
-           if (db->filtering)                                  \
-               croak("recursion detected in %s", name) ;       \
-           db->filtering = TRUE ;                              \
-           save_defsv = newSVsv(DEFSV) ;                       \
-           sv_setsv(DEFSV, arg) ;                              \
-           PUSHMARK(sp) ;                                      \
-           (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                       \
-           SvREFCNT_dec(save_defsv) ;                          \
-           db->filtering = FALSE ;                             \
-           /*printf("end of filtering %s\n", name) ;*/         \
-       }
-
-
-
 #define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
 
 typedef void (*FATALFUNC)();
@@ -183,32 +163,13 @@ gdbm_setopt (db, optflag, optval, optlen)
        int             optlen
 
 
-#define setFilter(type)                                        \
-       {                                               \
-           if (db->type)                               \
-               RETVAL = sv_mortalcopy(db->type) ;      \
-           ST(0) = RETVAL ;                            \
-           if (db->type && (code == &PL_sv_undef)) {   \
-                SvREFCNT_dec(db->type) ;               \
-               db->type = NULL ;                       \
-           }                                           \
-           else if (code) {                            \
-               if (db->type)                           \
-                   sv_setsv(db->type, code) ;          \
-               else                                    \
-                   db->type = newSVsv(code) ;          \
-           }                                           \
-       }
-
-
-
 SV *
 filter_fetch_key(db, code)
        GDBM_File       db
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_key) ;
+           DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -216,7 +177,7 @@ filter_store_key(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_key) ;
+           DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -224,7 +185,7 @@ filter_fetch_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_value) ;
+           DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -232,5 +193,5 @@ filter_store_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_value) ;
+           DBM_setFilter(db->filter_store_value, code) ;
 

diff --git a/ext/GDBM_File/gdbm.t b/ext/GDBM_File/gdbm.t
index 7c26893..87e30d0 100755 (executable)
--- a/ext/GDBM_File/gdbm.t
+++ b/ext/GDBM_File/gdbm.t
@@ -18,7 +18,7 @@ use warnings;
 
 use GDBM_File;
 
-print "1..74\n";
+print "1..80\n";
 
 unlink <Op.dbmx*>;
 
@@ -467,4 +467,47 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(75, my $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640));
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(76, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(78, $h{"fred"} eq "joe");
+
+   ok(79, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (80, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;

diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap
index 8952938..048f0dd 100644 (file)
--- a/ext/GDBM_File/typemap
+++ b/ext/GDBM_File/typemap
@@ -15,7 +15,7 @@ FATALFUNC             T_OPAQUEPTR
 
 INPUT
 T_DATUM_K
-       ckFilter($arg, filter_store_key, \"filter_store_key\");
+       DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
        $var.dptr = SvPV($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_K_C
@@ -23,7 +23,7 @@ T_DATUM_K_C
            SV * tmpSV;
            if (db->filter_store_key) {
                tmpSV = sv_2mortal(newSVsv($arg)); 
-               ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
+               DBM_ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
             }
             else
                 tmpSV = $arg;
@@ -31,7 +31,7 @@ T_DATUM_K_C
            $var.dsize = (int)PL_na;
        }
 T_DATUM_V
-        ckFilter($arg, filter_store_value, \"filter_store_value\");
+        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
            $var.dptr = SvPV($arg, PL_na);
            $var.dsize = (int)PL_na;
@@ -43,9 +43,9 @@ T_DATUM_V
 OUTPUT
 T_DATUM_K
        output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+       DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
 T_DATUM_V
        output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+       DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_PTROBJ
         sv_setref_pv($arg, dbtype, (void*)$var);

diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index 78a56cb..201ab6c 100644 (file)
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -5,7 +5,6 @@
  * by DB3 and Perl.  We drop the Perl definition now.
  * See also INSTALL section on DB3.
  * -- Stanislav Brabec <utx@penguin.cz> */
-#undef ENTER
 #include <ndbm.h>
 
 typedef struct {
@@ -21,25 +20,6 @@ typedef NDBM_File_type * NDBM_File ;
 typedef datum datum_key ;
 typedef datum datum_value ;
 
-#define ckFilter(arg,type,name)                                        \
-       if (db->type) {                                         \
-           SV * save_defsv ;                                   \
-            /* printf("filtering %s\n", name) ;*/              \
-           if (db->filtering)                                  \
-               croak("recursion detected in %s", name) ;       \
-           db->filtering = TRUE ;                              \
-           save_defsv = newSVsv(DEFSV) ;                       \
-           sv_setsv(DEFSV, arg) ;                              \
-           PUSHMARK(sp) ;                                      \
-           (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                       \
-           SvREFCNT_dec(save_defsv) ;                          \
-           db->filtering = FALSE ;                             \
-           /*printf("end of filtering %s\n", name) ;*/         \
-       }
-
-
 MODULE = NDBM_File     PACKAGE = NDBM_File     PREFIX = ndbm_
 
 NDBM_File
@@ -120,32 +100,13 @@ ndbm_clearerr(db)
        NDBM_File       db
 
 
-#define setFilter(type)                                        \
-       {                                               \
-           if (db->type)                               \
-               RETVAL = sv_mortalcopy(db->type) ;      \
-           ST(0) = RETVAL ;                            \
-           if (db->type && (code == &PL_sv_undef)) {   \
-                SvREFCNT_dec(db->type) ;               \
-               db->type = NULL ;                       \
-           }                                           \
-           else if (code) {                            \
-               if (db->type)                           \
-                   sv_setsv(db->type, code) ;          \
-               else                                    \
-                   db->type = newSVsv(code) ;          \
-           }                                           \
-       }
-
-
-
 SV *
 filter_fetch_key(db, code)
        NDBM_File       db
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_key) ;
+           DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -153,7 +114,7 @@ filter_store_key(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_key) ;
+           DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -161,7 +122,7 @@ filter_fetch_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_value) ;
+           DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -169,5 +130,5 @@ filter_store_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_value) ;
+           DBM_setFilter(db->filter_store_value, code) ;
 

diff --git a/ext/NDBM_File/ndbm.t b/ext/NDBM_File/ndbm.t
index a340e33..a7e49b8 100755 (executable)
--- a/ext/NDBM_File/ndbm.t
+++ b/ext/NDBM_File/ndbm.t
@@ -28,7 +28,7 @@ require NDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..71\n";
+print "1..77\n";
 
 unlink <Op.dbmx*>;
 
@@ -460,4 +460,48 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(72, my $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(73, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (74, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(75, $h{"fred"} eq "joe");
+
+   ok(76, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;

diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap
index 40b95f2..093c426 100644 (file)
--- a/ext/NDBM_File/typemap
+++ b/ext/NDBM_File/typemap
@@ -15,11 +15,11 @@ FATALFUNC           T_OPAQUEPTR
 
 INPUT
 T_DATUM_K
-       ckFilter($arg, filter_store_key, \"filter_store_key\");
+       DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
        $var.dptr = SvPV($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_V
-        ckFilter($arg, filter_store_value, \"filter_store_value\");
+        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
            $var.dptr = SvPV($arg, PL_na);
            $var.dsize = (int)PL_na;
@@ -33,10 +33,10 @@ T_GDATUM
 OUTPUT
 T_DATUM_K
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+       DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
 T_DATUM_V
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+       DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);
 T_PTROBJ

diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index 3bc94fe..376af1f 100644 (file)
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -56,25 +56,6 @@ typedef datum datum_key ;
 typedef datum datum_key_copy ;
 typedef datum datum_value ;
 
-#define ckFilter(arg,type,name)                                        \
-       if (db->type) {                                         \
-           SV * save_defsv ;                                   \
-            /* printf("filtering %s\n", name) ;*/              \
-           if (db->filtering)                                  \
-               croak("recursion detected in %s", name) ;       \
-           db->filtering = TRUE ;                              \
-           save_defsv = newSVsv(DEFSV) ;                       \
-           sv_setsv(DEFSV, arg) ;                              \
-           PUSHMARK(sp) ;                                      \
-           (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                       \
-           SvREFCNT_dec(save_defsv) ;                          \
-           db->filtering = FALSE ;                             \
-           /*printf("end of filtering %s\n", name) ;*/         \
-       }
-
-
 #define odbm_FETCH(db,key)                     fetch(key)
 #define odbm_STORE(db,key,value,flags)         store(key,value)
 #define odbm_DELETE(db,key)                    delete(key)
@@ -207,7 +188,7 @@ filter_fetch_key(db, code)
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_key) ;
+           DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -215,7 +196,7 @@ filter_store_key(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_key) ;
+           DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -223,7 +204,7 @@ filter_fetch_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_value) ;
+           DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -231,5 +212,5 @@ filter_store_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_value) ;
+           DBM_setFilter(db->filter_store_value, code) ;
 

diff --git a/ext/ODBM_File/odbm.t b/ext/ODBM_File/odbm.t
index ecffffd..c4df3d8 100755 (executable)
--- a/ext/ODBM_File/odbm.t
+++ b/ext/ODBM_File/odbm.t
@@ -28,7 +28,7 @@ require ODBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..72\n";
+print "1..78\n";
 
 unlink <Op.dbmx*>;
 
@@ -466,6 +466,50 @@ EOM
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op.dbmx*>;
+
+   ok(73, my $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(74, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (75, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(76, $h{"fred"} eq "joe");
+
+   ok(77, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (78, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op.dbmx*>;
+}
 exit ;
 if ($^O eq 'hpux') {
     print <<EOM;

diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap
index 62b8622..4f4802c 100644 (file)
--- a/ext/ODBM_File/typemap
+++ b/ext/ODBM_File/typemap
@@ -16,7 +16,7 @@ FATALFUNC             T_OPAQUEPTR
 
 INPUT
 T_DATUM_K
-       ckFilter($arg, filter_store_key, \"filter_store_key\");
+       DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
        $var.dptr = SvPV($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_K_C
@@ -24,7 +24,7 @@ T_DATUM_K_C
            SV * tmpSV ;
            if (db->filter_store_key){
                tmpSV = sv_2mortal(newSVsv($arg));
-               ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
+               DBM_ckFilter(tmpSV, filter_store_key, \"filter_store_key\");
            }
            else
                tmpSV = $arg;
@@ -32,7 +32,7 @@ T_DATUM_K_C
            $var.dsize = (int)PL_na;
        }
 T_DATUM_V
-        ckFilter($arg, filter_store_value, \"filter_store_value\");
+        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
            $var.dptr = SvPV($arg, PL_na);
            $var.dsize = (int)PL_na;
@@ -46,9 +46,9 @@ T_GDATUM
 OUTPUT
 T_DATUM_K
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+       DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
 T_DATUM_V
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+       DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);

diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index b454d59..3bf3c2b 100644 (file)
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -17,24 +17,6 @@ typedef SDBM_File_type * SDBM_File ;
 typedef datum datum_key ;
 typedef datum datum_value ;
 
-#define ckFilter(arg,type,name)                                        \
-       if (db->type) {                                         \
-           SV * save_defsv ;                                   \
-            /* printf("filtering %s\n", name) ;*/              \
-           if (db->filtering)                                  \
-               croak("recursion detected in %s", name) ;       \
-           db->filtering = TRUE ;                              \
-           save_defsv = newSVsv(DEFSV) ;                       \
-           sv_setsv(DEFSV, arg) ;                              \
-           PUSHMARK(sp) ;                                      \
-           (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                               \
-           SvREFCNT_dec(save_defsv) ;                          \
-           db->filtering = FALSE ;                             \
-           /*printf("end of filtering %s\n", name) ;*/         \
-       }
-
 #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
 #define sdbm_FETCH(db,key)                     sdbm_fetch(db->dbp,key)
 #define sdbm_STORE(db,key,value,flags)         sdbm_store(db->dbp,key,value,flags)
@@ -138,32 +120,13 @@ sdbm_clearerr(db)
          RETVAL
 
 
-#define setFilter(type)                                        \
-       {                                               \
-           if (db->type)                               \
-               RETVAL = sv_mortalcopy(db->type) ;      \
-           ST(0) = RETVAL ;                            \
-           if (db->type && (code == &PL_sv_undef)) {   \
-                SvREFCNT_dec(db->type) ;               \
-               db->type = NULL ;                       \
-           }                                           \
-           else if (code) {                            \
-               if (db->type)                           \
-                   sv_setsv(db->type, code) ;          \
-               else                                    \
-                   db->type = newSVsv(code) ;          \
-           }                                           \
-       }
-
-
-
 SV *
 filter_fetch_key(db, code)
        SDBM_File       db
        SV *            code
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_key) ;
+           DBM_setFilter(db->filter_fetch_key, code) ;
 
 SV *
 filter_store_key(db, code)
@@ -171,7 +134,7 @@ filter_store_key(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_key) ;
+           DBM_setFilter(db->filter_store_key, code) ;
 
 SV *
 filter_fetch_value(db, code)
@@ -179,7 +142,7 @@ filter_fetch_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_fetch_value) ;
+           DBM_setFilter(db->filter_fetch_value, code) ;
 
 SV *
 filter_store_value(db, code)
@@ -187,5 +150,5 @@ filter_store_value(db, code)
        SV *            code
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
-           setFilter(filter_store_value) ;
+           DBM_setFilter(db->filter_store_value, code) ;
 

diff --git a/ext/SDBM_File/sdbm.t b/ext/SDBM_File/sdbm.t
index f942b97..d1e2b4a 100644 (file)
--- a/ext/SDBM_File/sdbm.t
+++ b/ext/SDBM_File/sdbm.t
@@ -28,7 +28,7 @@ require SDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..74\n";
+print "1..80\n";
 
 unlink <Op_dbmx.*>;
 
@@ -469,4 +469,48 @@ unlink <Op_dbmx*>, $Dfile;
     unlink <Op.dbmx*>;
 }
 
+
+{
+   # Check that DBM Filter can cope with read-only $_
+
+   use warnings ;
+   use strict ;
+   my %h ;
+   unlink <Op1.dbmx*>;
+
+   ok(75, my $db = tie(%h, 'SDBM_File','Op1_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+   $db->filter_fetch_key   (sub { }) ;
+   $db->filter_store_key   (sub { }) ;
+   $db->filter_fetch_value (sub { }) ;
+   $db->filter_store_value (sub { }) ;
+
+   $_ = "original" ;
+
+   $h{"fred"} = "joe" ;
+   ok(76, $h{"fred"} eq "joe");
+
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (77, ! $@);
+
+
+   # delete the filters
+   $db->filter_fetch_key   (undef);
+   $db->filter_store_key   (undef);
+   $db->filter_fetch_value (undef);
+   $db->filter_store_value (undef);
+
+   $h{"fred"} = "joe" ;
+
+   ok(78, $h{"fred"} eq "joe");
+
+   ok(79, $db->FIRSTKEY() eq "fred") ;
+   
+   eval { grep { $h{$_} } (1, 2, 3) };
+   ok (80, ! $@);
+
+   undef $db ;
+   untie %h;
+   unlink <Op1.dbmx*>;
+}
 exit ;

diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap
index 40b95f2..093c426 100644 (file)
--- a/ext/SDBM_File/typemap
+++ b/ext/SDBM_File/typemap
@@ -15,11 +15,11 @@ FATALFUNC           T_OPAQUEPTR
 
 INPUT
 T_DATUM_K
-       ckFilter($arg, filter_store_key, \"filter_store_key\");
+       DBM_ckFilter($arg, filter_store_key, \"filter_store_key\");
        $var.dptr = SvPV($arg, PL_na);
        $var.dsize = (int)PL_na;
 T_DATUM_V
-        ckFilter($arg, filter_store_value, \"filter_store_value\");
+        DBM_ckFilter($arg, filter_store_value, \"filter_store_value\");
        if (SvOK($arg)) {
            $var.dptr = SvPV($arg, PL_na);
            $var.dsize = (int)PL_na;
@@ -33,10 +33,10 @@ T_GDATUM
 OUTPUT
 T_DATUM_K
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
+       DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\");
 T_DATUM_V
        sv_setpvn($arg, $var.dptr, $var.dsize);
-       ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
+       DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\");
 T_GDATUM
        sv_usepvn($arg, $var.dptr, $var.dsize);
 T_PTROBJ