Skip to content

Commit

Permalink
Fix DBM filters
Browse files Browse the repository at this point in the history 
From: "Paul Marquess" <Paul.Marquess@btinternet.com>
Message-ID: <AIEAJICLCBDNAAOLLOKLAEHCFEAA.Paul.Marquess@btinternet.com>

p4raw-id: //depot/perl@17750
  • Loading branch information
@hvds
Paul Marquess authored and hvds committed Aug 22, 2002
1 parent 3a131ab commit 6a31061
Show file tree
Hide file tree
Showing 15 changed files with 264 additions and 236 deletions.
43 changes: 43 additions & 0 deletions XSUB.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
68 changes: 6 additions & 62 deletions ext/DB_File/DB_File.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -162,7 +162,6 @@
#include <fcntl.h>

/* #define TRACE */
#define DBM_FILTERING

#ifdef TRACE
# define Trace(x) printf x
Expand Down Expand Up @@ -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") ; \
} \
}

Expand All @@ -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") ; \
} \
}

Expand Down Expand Up @@ -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 ;

Expand Down Expand Up @@ -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 ;

Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -1857,56 +1822,35 @@ 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)
DB_File db
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)
DB_File db
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)
DB_File db
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
DBM_setFilter(db->filter_store_value, code) ;

#endif /* DBM_FILTERING */
4 changes: 2 additions & 2 deletions ext/DB_File/typemap
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand All @@ -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);
Expand Down
47 changes: 4 additions & 43 deletions ext/GDBM_File/GDBM_File.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)();
Expand Down Expand Up @@ -183,54 +163,35 @@ 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)
GDBM_File db
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)
GDBM_File db
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)
GDBM_File db
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
DBM_setFilter(db->filter_store_value, code) ;

45 changes: 44 additions & 1 deletion ext/GDBM_File/gdbm.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@ use warnings;

use GDBM_File;

print "1..74\n";
print "1..80\n";

unlink <Op.dbmx*>;

Expand Down Expand Up @@ -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 ;
Loading

0 comments on commit 6a31061

Please sign in to comment.