diff options
Diffstat (limited to 'contrib/perl5/ext/GDBM_File/GDBM_File.xs')
| -rw-r--r-- | contrib/perl5/ext/GDBM_File/GDBM_File.xs | 154 |
1 files changed, 133 insertions, 21 deletions
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) ; + |
