Change 17750 by [EMAIL PROTECTED] on 2002/08/22 10:46:19
Subject: [PATCH] Fix DBM filters
From: "Paul Marquess" <[EMAIL PROTECTED]>
Date: Wed, 21 Aug 2002 11:40:49 +0100
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/XSUB.h#67 edit
.... //depot/perl/ext/DB_File/DB_File.xs#58 edit
.... //depot/perl/ext/DB_File/typemap#19 edit
.... //depot/perl/ext/GDBM_File/GDBM_File.xs#24 edit
.... //depot/perl/ext/GDBM_File/gdbm.t#4 edit
.... //depot/perl/ext/GDBM_File/typemap#14 edit
.... //depot/perl/ext/NDBM_File/NDBM_File.xs#13 edit
.... //depot/perl/ext/NDBM_File/ndbm.t#4 edit
.... //depot/perl/ext/NDBM_File/typemap#11 edit
.... //depot/perl/ext/ODBM_File/ODBM_File.xs#22 edit
.... //depot/perl/ext/ODBM_File/odbm.t#3 edit
.... //depot/perl/ext/ODBM_File/typemap#11 edit
.... //depot/perl/ext/SDBM_File/SDBM_File.xs#15 edit
.... //depot/perl/ext/SDBM_File/sdbm.t#5 edit
.... //depot/perl/ext/SDBM_File/typemap#11 edit
Differences ...
==== //depot/perl/XSUB.h#67 (text) ====
Index: perl/XSUB.h
--- perl/XSUB.h#66~16973~ Sat Jun 1 14:19:50 2002
+++ perl/XSUB.h Thu Aug 22 03:46:19 2002
@@ -228,6 +228,49 @@
# 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
==== //depot/perl/ext/DB_File/DB_File.xs#58 (text) ====
Index: perl/ext/DB_File/DB_File.xs
--- perl/ext/DB_File/DB_File.xs#57~14944~ Sat Mar 2 05:54:35 2002
+++ perl/ext/DB_File/DB_File.xs Thu Aug 22 03:46:19 2002
@@ -162,7 +162,6 @@
#include <fcntl.h>
/* #define TRACE */
-#define DBM_FILTERING
#ifdef TRACE
# define Trace(x) printf x
@@ -367,51 +366,23 @@
#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 @@
} \
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
-#endif /* DBM_FILTERING */
==== //depot/perl/ext/DB_File/typemap#19 (text) ====
Index: perl/ext/DB_File/typemap
--- perl/ext/DB_File/typemap#18~8094~ Tue Dec 12 11:48:26 2000
+++ perl/ext/DB_File/typemap Thu Aug 22 03:46:19 2002
@@ -15,7 +15,7 @@
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 @@
$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);
==== //depot/perl/ext/GDBM_File/GDBM_File.xs#24 (text) ====
Index: perl/ext/GDBM_File/GDBM_File.xs
--- perl/ext/GDBM_File/GDBM_File.xs#23~15023~ Mon Mar 4 14:17:56 2002
+++ perl/ext/GDBM_File/GDBM_File.xs Thu Aug 22 03:46:19 2002
@@ -19,26 +19,6 @@
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 @@
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 @@
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 @@
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 @@
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
==== //depot/perl/ext/GDBM_File/gdbm.t#4 (xtext) ====
Index: perl/ext/GDBM_File/gdbm.t
--- perl/ext/GDBM_File/gdbm.t#3~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/GDBM_File/gdbm.t Thu Aug 22 03:46:19 2002
@@ -18,7 +18,7 @@
use GDBM_File;
-print "1..74\n";
+print "1..80\n";
unlink <Op.dbmx*>;
@@ -467,4 +467,47 @@
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 ;
==== //depot/perl/ext/GDBM_File/typemap#14 (text) ====
Index: perl/ext/GDBM_File/typemap
--- perl/ext/GDBM_File/typemap#13~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/GDBM_File/typemap Thu Aug 22 03:46:19 2002
@@ -15,7 +15,7 @@
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 @@
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 @@
$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 @@
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);
==== //depot/perl/ext/NDBM_File/NDBM_File.xs#13 (text) ====
Index: perl/ext/NDBM_File/NDBM_File.xs
--- perl/ext/NDBM_File/NDBM_File.xs#12~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/NDBM_File/NDBM_File.xs Thu Aug 22 03:46:19 2002
@@ -5,7 +5,6 @@
* by DB3 and Perl. We drop the Perl definition now.
* See also INSTALL section on DB3.
* -- Stanislav Brabec <[EMAIL PROTECTED]> */
-#undef ENTER
#include <ndbm.h>
typedef struct {
@@ -21,25 +20,6 @@
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_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 @@
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 @@
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 @@
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
==== //depot/perl/ext/NDBM_File/ndbm.t#4 (xtext) ====
Index: perl/ext/NDBM_File/ndbm.t
--- perl/ext/NDBM_File/ndbm.t#3~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/NDBM_File/ndbm.t Thu Aug 22 03:46:19 2002
@@ -28,7 +28,7 @@
#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 @@
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 ;
==== //depot/perl/ext/NDBM_File/typemap#11 (text) ====
Index: perl/ext/NDBM_File/typemap
--- perl/ext/NDBM_File/typemap#10~8068~ Sat Dec 9 20:17:36 2000
+++ perl/ext/NDBM_File/typemap Thu Aug 22 03:46:19 2002
@@ -15,11 +15,11 @@
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 @@
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
==== //depot/perl/ext/ODBM_File/ODBM_File.xs#22 (text) ====
Index: perl/ext/ODBM_File/ODBM_File.xs
--- perl/ext/ODBM_File/ODBM_File.xs#21~12705~ Sat Oct 27 08:23:15 2001
+++ perl/ext/ODBM_File/ODBM_File.xs Thu Aug 22 03:46:19 2002
@@ -56,25 +56,6 @@
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 @@
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 @@
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 @@
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 @@
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
==== //depot/perl/ext/ODBM_File/odbm.t#3 (xtext) ====
Index: perl/ext/ODBM_File/odbm.t
--- perl/ext/ODBM_File/odbm.t#2~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/ODBM_File/odbm.t Thu Aug 22 03:46:19 2002
@@ -28,7 +28,7 @@
#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 @@
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;
==== //depot/perl/ext/ODBM_File/typemap#11 (text) ====
Index: perl/ext/ODBM_File/typemap
--- perl/ext/ODBM_File/typemap#10~12564~ Mon Oct 22 05:17:00 2001
+++ perl/ext/ODBM_File/typemap Thu Aug 22 03:46:19 2002
@@ -16,7 +16,7 @@
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 @@
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 @@
$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 @@
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);
==== //depot/perl/ext/SDBM_File/SDBM_File.xs#15 (text) ====
Index: perl/ext/SDBM_File/SDBM_File.xs
--- perl/ext/SDBM_File/SDBM_File.xs#14~16726~ Tue May 21 15:57:09 2002
+++ perl/ext/SDBM_File/SDBM_File.xs Thu Aug 22 03:46:19 2002
@@ -17,24 +17,6 @@
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 @@
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 @@
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 @@
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 @@
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
==== //depot/perl/ext/SDBM_File/sdbm.t#5 (text) ====
Index: perl/ext/SDBM_File/sdbm.t
--- perl/ext/SDBM_File/sdbm.t#4~14347~ Sat Jan 19 09:57:08 2002
+++ perl/ext/SDBM_File/sdbm.t Thu Aug 22 03:46:19 2002
@@ -28,7 +28,7 @@
#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*>;
}
+
+{
+ # 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 ;
==== //depot/perl/ext/SDBM_File/typemap#11 (text) ====
Index: perl/ext/SDBM_File/typemap
--- perl/ext/SDBM_File/typemap#10~8068~ Sat Dec 9 20:17:36 2000
+++ perl/ext/SDBM_File/typemap Thu Aug 22 03:46:19 2002
@@ -15,11 +15,11 @@
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 @@
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
End of Patch.
