diff options
Diffstat (limited to 'contrib/perl5/ext/GDBM_File')
-rw-r--r-- | contrib/perl5/ext/GDBM_File/GDBM_File.pm | 14 | ||||
-rw-r--r-- | contrib/perl5/ext/GDBM_File/GDBM_File.xs | 154 | ||||
-rw-r--r-- | contrib/perl5/ext/GDBM_File/typemap | 23 |
3 files changed, 154 insertions, 37 deletions
diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm index 09df437..ab866ee 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.pm +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm @@ -33,21 +33,21 @@ The available functions and the gdbm/perl interface need to be documented. =head1 SEE ALSO -L<perl(1)>, L<DB_File(3)>. +L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. =cut package GDBM_File; use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); +our($VERSION, @ISA, @EXPORT, $AUTOLOAD); require Carp; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Tie::Hash Exporter); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST @@ -59,14 +59,14 @@ require DynaLoader; GDBM_WRITER ); -$VERSION = "1.00"; +$VERSION = "1.03"; sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -78,7 +78,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap GDBM_File $VERSION; +XSLoader::load 'GDBM_File', $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs index ac1ca8c..870f056 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.xs +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs @@ -5,20 +5,40 @@ #include <gdbm.h> #include <fcntl.h> -typedef GDBM_FILE GDBM_File; +typedef struct { + GDBM_FILE dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } GDBM_File_type; + +typedef GDBM_File_type * GDBM_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 GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ -#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \ - gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func) -#define gdbm_FETCH(db,key) gdbm_fetch(db,key) -#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags) -#define gdbm_DELETE(db,key) gdbm_delete(db,key) -#define gdbm_FIRSTKEY(db) gdbm_firstkey(db) -#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) -#define gdbm_EXISTS(db,key) gdbm_exists(db,key) -typedef datum gdatum; +#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ typedef void (*FATALFUNC)(); @@ -29,6 +49,21 @@ not_here(char *s) return -1; } +/* GDBM allocates the datum with system malloc() and expects the user + * to free() it. So we either have to free() it immediately, or have + * perl free() it when it deallocates the SV, depending on whether + * perl uses malloc()/free() or not. */ +static void +output_datum(pTHX_ SV *arg, char *str, int size) +{ +#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC)) + sv_usepvn(arg, str, size); +#else + sv_setpvn(arg, str, size); + safesysfree(str); +#endif +} + /* Versions of gdbm prior to 1.7x might not have the gdbm_sync, gdbm_exists, and gdbm_setopt functions. Apparently Slackware (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991). @@ -174,7 +209,23 @@ gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) int read_write int mode FATALFUNC fatal_func + CODE: + { + GDBM_FILE dbp ; + RETVAL = NULL ; + if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) { + RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ; + Zero(RETVAL, 1, GDBM_File_type) ; + RETVAL->dbp = dbp ; + } + + } + OUTPUT: + RETVAL + + +#define gdbm_close(db) gdbm_close(db->dbp) void gdbm_close(db) GDBM_File db @@ -185,17 +236,20 @@ gdbm_DESTROY(db) GDBM_File db CODE: gdbm_close(db); + safefree(db); -gdatum +#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key) +datum_value gdbm_FETCH(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags) int gdbm_STORE(db, key, value, flags = GDBM_REPLACE) GDBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -203,37 +257,43 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE) croak("No write permission to gdbm file"); croak("gdbm store returned %d, errno %d, key \"%.*s\"", RETVAL,errno,key.dsize,key.dptr); - /* gdbm_clearerr(db); */ } +#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key) int gdbm_DELETE(db, key) GDBM_File db - datum key + datum_key key -gdatum +#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp) +datum_key gdbm_FIRSTKEY(db) GDBM_File db -gdatum +#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key) +datum_key gdbm_NEXTKEY(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_reorganize(db) gdbm_reorganize(db->dbp) int gdbm_reorganize(db) GDBM_File db +#define gdbm_sync(db) gdbm_sync(db->dbp) void gdbm_sync(db) GDBM_File db +#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) int gdbm_EXISTS(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen) int gdbm_setopt (db, optflag, optval, optlen) GDBM_File db @@ -241,3 +301,55 @@ gdbm_setopt (db, optflag, optval, optlen) int &optval 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) ; + +SV * +filter_store_key(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap index 317a8f3..4f79ae3 100644 --- a/contrib/perl5/ext/GDBM_File/typemap +++ b/contrib/perl5/ext/GDBM_File/typemap @@ -2,8 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM -gdatum T_GDATUM +datum_key T_DATUM_K +datum_value T_DATUM_V NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ @@ -13,15 +13,20 @@ 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 - sv_setpvn($arg, $var.dptr, $var.dsize); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); +T_DATUM_K + output_datum(aTHX_ $arg, $var.dptr, $var.dsize); + 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\"); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); |