diff options
Diffstat (limited to 'contrib/perl5/ext/ODBM_File')
-rw-r--r-- | contrib/perl5/ext/ODBM_File/ODBM_File.pm | 12 | ||||
-rw-r--r-- | contrib/perl5/ext/ODBM_File/ODBM_File.xs | 114 | ||||
-rw-r--r-- | contrib/perl5/ext/ODBM_File/hints/cygwin.pl | 2 | ||||
-rw-r--r-- | contrib/perl5/ext/ODBM_File/hints/sco.pl | 8 | ||||
-rw-r--r-- | contrib/perl5/ext/ODBM_File/typemap | 16 |
5 files changed, 121 insertions, 31 deletions
diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm index 923640f..57fe4c3 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.pm +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.pm @@ -1,16 +1,14 @@ package ODBM_File; use strict; -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.02"; -$VERSION = "1.00"; - -bootstrap ODBM_File $VERSION; +XSLoader::load 'ODBM_File', $VERSION; 1; @@ -30,6 +28,6 @@ ODBM_File - Tied access to odbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs index 892c038..150f2ef 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.xs +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.xs @@ -2,9 +2,6 @@ #include "perl.h" #include "XSUB.h" -#ifdef NULL -#undef NULL /* XXX Why? */ -#endif #ifdef I_DBM # include <dbm.h> #else @@ -30,7 +27,37 @@ #include <fcntl.h> -typedef void* ODBM_File; +typedef struct { + void * dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } ODBM_File_type; + +typedef ODBM_File_type * ODBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + #define odbm_FETCH(db,key) fetch(key) #define odbm_STORE(db,key,value,flags) store(key,value) @@ -46,10 +73,6 @@ static int dbmrefcnt; MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ -#ifndef NULL -# define NULL 0 -#endif - ODBM_File odbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype @@ -59,6 +82,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 +99,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); } @@ -86,17 +113,18 @@ DESTROY(db) CODE: dbmrefcnt--; dbmclose(); + safefree(db); -datum +datum_value 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 +137,66 @@ 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 = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = Nullsv ; \ + } \ + 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) ; + +SV * +filter_store_key(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/contrib/perl5/ext/ODBM_File/hints/cygwin.pl b/contrib/perl5/ext/ODBM_File/hints/cygwin.pl new file mode 100644 index 0000000..a0d33c8 --- /dev/null +++ b/contrib/perl5/ext/ODBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM dbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/sco.pl b/contrib/perl5/ext/ODBM_File/hints/sco.pl index 4664f2b..f551578 100644 --- a/contrib/perl5/ext/ODBM_File/hints/sco.pl +++ b/contrib/perl5/ext/ODBM_File/hints/sco.pl @@ -1,4 +1,4 @@ -# Some versions of SCO contain a broken -ldbm library that is missing -# dbmclose. Some of those might have a fixed library installed as -# -ldbm.nfs. -$self->{LIBS} = ['-ldbm.nfs', '-ldbm']; +# SCO ODT 3.2v4.2 has a -ldbm library that is missing dbmclose. +# This system should have a complete library installed as -ldbm.nfs which +# should be used instead (Probably need the networking product add-on) +$self->{LIBS} = ['-lndbm',-e "/usr/lib/libdbm.nfs.a"?'-ldbm.nfs':'-ldbm']; diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap index 5e12e73..7c23815 100644 --- a/contrib/perl5/ext/ODBM_File/typemap +++ b/contrib/perl5/ext/ODBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,13 +14,22 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); |