diff options
Diffstat (limited to 'contrib/perl5/ext/NDBM_File')
-rw-r--r-- | contrib/perl5/ext/NDBM_File/NDBM_File.pm | 12 | ||||
-rw-r--r-- | contrib/perl5/ext/NDBM_File/NDBM_File.xs | 152 | ||||
-rw-r--r-- | contrib/perl5/ext/NDBM_File/hints/cygwin.pl | 2 | ||||
-rw-r--r-- | contrib/perl5/ext/NDBM_File/hints/sco.pl | 4 | ||||
-rw-r--r-- | contrib/perl5/ext/NDBM_File/typemap | 16 |
5 files changed, 149 insertions, 37 deletions
diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm index ed4fe2b..f98669f 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.pm +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.pm @@ -5,16 +5,14 @@ BEGIN { 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.03"; -$VERSION = "1.01"; - -bootstrap NDBM_File $VERSION; +XSLoader::load 'NDBM_File', $VERSION; 1; @@ -35,6 +33,6 @@ NDBM_File - Tied access to ndbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs index d129a9c..49a1db5 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.xs +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.xs @@ -3,39 +3,80 @@ #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; -MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ +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 -dbm_TIEHASH(dbtype, filename, flags, mode) +ndbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype 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_DESTROY(db) NDBM_File db CODE: - dbm_close(db); + dbm_close(db->dbp); + safefree(db); -datum -dbm_FETCH(db, key) +#define ndbm_FETCH(db,key) dbm_fetch(db->dbp,key) +datum_value +ndbm_FETCH(db, key) NDBM_File db - datum key + datum_key key +#define ndbm_STORE(db,key,value,flags) dbm_store(db->dbp,key,value,flags) int -dbm_STORE(db, key, value, flags = DBM_REPLACE) +ndbm_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 +84,85 @@ 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 ndbm_DELETE(db,key) dbm_delete(db->dbp,key) int -dbm_DELETE(db, key) +ndbm_DELETE(db, key) NDBM_File db - datum key + datum_key key -datum -dbm_FIRSTKEY(db) +#define ndbm_FIRSTKEY(db) dbm_firstkey(db->dbp) +datum_key +ndbm_FIRSTKEY(db) NDBM_File db -datum -dbm_NEXTKEY(db, key) +#define ndbm_NEXTKEY(db,key) dbm_nextkey(db->dbp) +datum_key +ndbm_NEXTKEY(db, key) NDBM_File db - datum key + datum_key key +#define ndbm_error(db) dbm_error(db->dbp) int -dbm_error(db) +ndbm_error(db) NDBM_File db +#define ndbm_clearerr(db) dbm_clearerr(db->dbp) void -dbm_clearerr(db) +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) ; + +SV * +filter_store_key(db, code) + NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/contrib/perl5/ext/NDBM_File/hints/cygwin.pl b/contrib/perl5/ext/NDBM_File/hints/cygwin.pl new file mode 100644 index 0000000..0a4b762 --- /dev/null +++ b/contrib/perl5/ext/NDBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM ndbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/NDBM_File/hints/sco.pl b/contrib/perl5/ext/NDBM_File/hints/sco.pl new file mode 100644 index 0000000..f551578 --- /dev/null +++ b/contrib/perl5/ext/NDBM_File/hints/sco.pl @@ -0,0 +1,4 @@ +# 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/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap index 317a8f3..eeb5d59 100644 --- a/contrib/perl5/ext/NDBM_File/typemap +++ b/contrib/perl5/ext/NDBM_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,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 |