X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2FDB_File.xs;h=ed3a7fa3e044f780dbf1e74f53123b73ec7525ba;hb=3e3318e754fa4289ad1c682811dbe6a31cd59e26;hp=33f4b690f3768d78725ccea68564001439d98731;hpb=cceca5ed003bac658cb0392a14bb2f26d434bd78;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 33f4b69..ed3a7fa 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,12 +3,12 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess - last modified 19th November 1998 - version 1.63 + last modified 6th June 1999 + version 1.67 All comments/suggestions/problems are welcome - Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved. + Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -60,7 +60,15 @@ fixed typo in O_RDONLY test. 1.62 - No change to DB_File.xs 1.63 - Fix to alllow DB 2.6.x to build. - + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. @@ -72,7 +80,21 @@ #ifndef PERL_VERSION #include "patchlevel.h" -#define PERL_VERSION PATCHLEVEL +#define PERL_REVISION 5 +#define PERL_VERSION PATCHLEVEL +#define PERL_SUBVERSION SUBVERSION +#endif + +#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) + +# define PL_sv_undef sv_undef +# define PL_na na + +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +#define DEFSV GvSV(defgv) #endif /* Being the Berkeley DB we prefer the (which will be @@ -92,6 +114,7 @@ #include /* #define TRACE */ +#define DBM_FILTERING @@ -264,28 +287,64 @@ 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) ; \ - } \ +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ } -#define OutputKey(arg, name) \ - { if (RETVAL == 0) \ - { \ - if (db->type != DB_RECNO) { \ - my_sv_setpvn(arg, name.data, name.size); \ - } \ - else \ - sv_setiv(arg, (I32)*(I32*)name.data - 1); \ - } \ +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ } @@ -298,12 +357,7 @@ static DBTKEY empty ; #ifdef DB_VERSION_MAJOR static int -db_put(db, key, value, flags) -DB_File db ; -DBTKEY key ; -DBT value ; -u_int flags ; - +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) { int status ; @@ -327,7 +381,7 @@ u_int flags ; #endif /* DB_VERSION_MAJOR */ static void -GetVersionInfo() +GetVersionInfo(pTHX) { SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ; #ifdef DB_VERSION_MAJOR @@ -335,9 +389,9 @@ GetVersionInfo() (void)db_version(&Major, &Minor, &Patch) ; - /* check that libdb is recent enough */ - if (Major == 2 && Minor == 0 && Patch < 5) - croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n", + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", Major, Minor, Patch) ; #if PERL_VERSION > 3 @@ -358,10 +412,9 @@ GetVersionInfo() static int -btree_compare(key1, key2) -const DBT * key1 ; -const DBT * key2 ; +btree_compare(const DBT *key1, const DBT *key2) { + dTHX; dSP ; void * data1, * data2 ; int retval ; @@ -405,10 +458,9 @@ const DBT * key2 ; } static DB_Prefix_t -btree_prefix(key1, key2) -const DBT * key1 ; -const DBT * key2 ; +btree_prefix(const DBT *key1, const DBT *key2) { + dTHX; dSP ; void * data1, * data2 ; int retval ; @@ -452,10 +504,9 @@ const DBT * key2 ; } static DB_Hash_t -hash_cb(data, size) -const void * data ; -size_t size ; +hash_cb(const void *data, size_t size) { + dTHX; dSP ; int retval ; int count ; @@ -492,8 +543,7 @@ size_t size ; #ifdef TRACE static void -PrintHash(hash) -INFO * hash ; +PrintHash(INFO *hash) { printf ("HASH Info\n") ; printf (" hash = %s\n", @@ -507,8 +557,7 @@ INFO * hash ; } static void -PrintRecno(recno) -INFO * recno ; +PrintRecno(INFO *recno) { printf ("RECNO Info\n") ; printf (" flags = %d\n", recno->db_RE_flags) ; @@ -521,8 +570,7 @@ INFO * recno ; } static void -PrintBtree(btree) -INFO * btree ; +PrintBtree(INFO *btree) { printf ("BTREE Info\n") ; printf (" compare = %s\n", @@ -549,8 +597,7 @@ INFO * btree ; static I32 -GetArrayLength(db) -DB_File db ; +GetArrayLength(pTHX_ DB_File db) { DBT key ; DBT value ; @@ -568,13 +615,11 @@ DB_File db ; } static recno_t -GetRecnoKey(db, value) -DB_File db ; -I32 value ; +GetRecnoKey(pTHX_ DB_File db, I32 value) { if (value < 0) { /* Get the length of the array */ - I32 length = GetArrayLength(db) ; + I32 length = GetArrayLength(aTHX_ db) ; /* check for attempt to write before start of array */ if (length + value + 1 <= 0) @@ -589,12 +634,7 @@ I32 value ; } static DB_File -ParseOpenInfo(isHASH, name, flags, mode, sv) -int isHASH ; -char * name ; -int flags ; -int mode ; -SV * sv ; +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) { SV ** svp; HV * action ; @@ -607,6 +647,11 @@ 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 ; @@ -825,19 +870,14 @@ SV * sv ; if ((flags & O_CREAT) == O_CREAT) Flags |= DB_CREATE ; -#ifdef O_NONBLOCK - if ((flags & O_NONBLOCK) == O_NONBLOCK) - Flags |= DB_EXCL ; -#endif - #if O_RDONLY == 0 if (flags == O_RDONLY) #else - if ((flags & O_RDONLY) == O_RDONLY) + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) #endif Flags |= DB_RDONLY ; -#ifdef O_NONBLOCK +#ifdef O_TRUNC if ((flags & O_TRUNC) == O_TRUNC) Flags |= DB_TRUNCATE ; #endif @@ -863,18 +903,8 @@ SV * sv ; } -static int -not_here(s) -char *s; -{ - croak("DB_File::%s not implemented on this architecture", s); - return -1; -} - static double -constant(name, arg) -char *name; -int arg; +constant(char *name, int arg) { errno = 0; switch (*name) { @@ -1107,7 +1137,7 @@ MODULE = DB_File PACKAGE = DB_File PREFIX = db_ BOOT: { - GetVersionInfo() ; + GetVersionInfo(aTHX) ; empty.data = &zero ; empty.size = sizeof(recno_t) ; @@ -1138,7 +1168,7 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H if (items == 6) sv = ST(5) ; - RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } @@ -1157,6 +1187,16 @@ 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) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + 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) @@ -1222,7 +1262,6 @@ db_FIRSTKEY(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1239,7 +1278,6 @@ db_NEXTKEY(db, key) CODE: { DBT value ; - DB * Db = db->dbp ; DBT_flags(value) ; CurrentDB = db ; @@ -1302,7 +1340,6 @@ pop(db) { DBTKEY key ; DBT value ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1330,7 +1367,6 @@ shift(db) { DBT value ; DBTKEY key ; - DB * Db = db->dbp ; DBT_flags(key) ; DBT_flags(value) ; @@ -1357,7 +1393,6 @@ push(db, ...) CODE: { DBTKEY key ; - DBTKEY * keyptr = &key ; DBT value ; DB * Db = db->dbp ; int i ; @@ -1366,34 +1401,35 @@ push(db, ...) DBT_flags(key) ; DBT_flags(value) ; CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; - if (RETVAL >= 0) - { - if (RETVAL == 1) - keyptr = &empty ; #ifdef DB_VERSION_MAJOR + RETVAL = 0 ; + key = empty ; for (i = 1 ; i < items ; ++i) { - - ++ (* (int*)key.data) ; value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ; + RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ; if (RETVAL != 0) break; } -#else +#else + + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + if (RETVAL >= 0) + { + if (RETVAL == 1) + key = empty ; for (i = items - 1 ; i > 0 ; --i) { value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ; + RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ; if (RETVAL != 0) break; } -#endif } +#endif } OUTPUT: RETVAL @@ -1405,7 +1441,7 @@ length(db) ALIAS: FETCHSIZE = 1 CODE: CurrentDB = db ; - RETVAL = GetArrayLength(db) ; + RETVAL = GetArrayLength(aTHX_ db) ; OUTPUT: RETVAL @@ -1528,3 +1564,56 @@ 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) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + +#endif /* DBM_FILTERING */