DB_File.xs -- Perl 5 interface to Berkeley DB
- written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 6th Jan 2002
- version 1.802
+ written by Paul Marquess <pmqs@cpan.org>
+ last modified 12th March 2005
+ version 1.811
All comments/suggestions/problems are welcome
- Copyright (c) 1995-2002 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-2005 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.
Use the new constants code.
1.801 - No change to DB_File.xs
1.802 - No change to DB_File.xs
+ 1.803 - FETCH, STORE & DELETE don't map the flags parameter
+ into the equivalent Berkeley DB function anymore.
+ 1.804 - no change.
+ 1.805 - recursion detection added to the callbacks
+ Support for 4.1.X added.
+ Filter code can now cope with read-only $_
+ 1.806 - recursion detection beefed up.
+ 1.807 - no change
+ 1.808 - leak fixed in ParseOpenInfo
+ 1.809 - no change
+ 1.810 - no change
+ 1.811 - no change
*/
# undef __attribute__
#endif
-
-
#ifdef COMPAT185
# include <db_185.h>
#else
#include <fcntl.h>
/* #define TRACE */
-#define DBM_FILTERING
#ifdef TRACE
# define Trace(x) printf x
# define AT_LEAST_DB_3_2
#endif
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
+# define AT_LEAST_DB_4_1
+#endif
+
/* map version 2 features & constants onto their version 1 equivalent */
#ifdef DB_Prefix_t
-#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags)
-#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags)
-#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
+#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, 0)
+#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, 0)
+#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, 0)
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
#ifdef DB_VERSION_MAJOR
-#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\
- (db->dbp->close)(db->dbp, 0) )
+#define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\
+ (db->dbp->close)(db->dbp, 0) ))
#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
? ((db->cursor)->c_del)(db->cursor, 0) \
#else /* ! DB_VERSION_MAJOR */
-#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
+#define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp))
#define db_close(db) ((db->dbp)->close)(db->dbp)
#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
DBTYPE type ;
DB * dbp ;
SV * compare ;
+ bool in_compare ;
SV * prefix ;
+ bool in_prefix ;
SV * hash ;
+ bool in_hash ;
+ bool aborted ;
int in_memory ;
#ifdef BERKELEY_DB_1_OR_2
INFO info ;
#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) { \
+ SvGETMAGIC(arg) ; \
my_sv_setpvn(arg, name.data, name.size) ; \
- ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
+ TAINT; \
+ SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
+ DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \
} \
}
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
+ SvGETMAGIC(arg) ; \
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") ; \
+ TAINT; \
+ SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
+ DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
} \
}
#define CurrentDB (MY_CXT.x_CurrentDB)
#define empty (MY_CXT.x_empty)
+#define ERR_BUFF "DB_File::Error"
+
#ifdef DB_VERSION_MAJOR
static int
#endif /* DB_VERSION_MAJOR */
+static void
+tidyUp(DB_File db)
+{
+ db->aborted = TRUE ;
+}
+
static int
#ifdef AT_LEAST_DB_3_2
int retval ;
int count ;
+
+ if (CurrentDB->in_compare) {
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_compare: recursion detected\n") ;
+ }
+
data1 = (char *) key1->data ;
data2 = (char *) key2->data ;
ENTER ;
SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_compare = FALSE;
+ SAVEINT(CurrentDB->in_compare);
+ CurrentDB->in_compare = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
SPAGAIN ;
- if (count != 1)
+ if (count != 1){
+ tidyUp(CurrentDB);
croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
+ }
retval = POPi ;
PUTBACK ;
FREETMPS ;
LEAVE ;
+
return (retval) ;
}
int retval ;
int count ;
+ if (CurrentDB->in_prefix){
+ tidyUp(CurrentDB);
+ croak ("DB_File btree_prefix: recursion detected\n") ;
+ }
+
data1 = (char *) key1->data ;
data2 = (char *) key2->data ;
ENTER ;
SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_prefix = FALSE;
+ SAVEINT(CurrentDB->in_prefix);
+ CurrentDB->in_prefix = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
SPAGAIN ;
- if (count != 1)
+ if (count != 1){
+ tidyUp(CurrentDB);
croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
+ }
retval = POPi ;
#endif
dSP ;
dMY_CXT;
- int retval ;
+ int retval = 0;
int count ;
+ if (CurrentDB->in_hash){
+ tidyUp(CurrentDB);
+ croak ("DB_File hash callback: recursion detected\n") ;
+ }
+
#ifndef newSVpvn
if (size == 0)
data = "" ;
/* DGH - Next two lines added to fix corrupted stack problem */
ENTER ;
SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_hash = FALSE;
+ SAVEINT(CurrentDB->in_hash);
+ CurrentDB->in_hash = TRUE;
PUSHMARK(SP) ;
+
XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
PUTBACK ;
SPAGAIN ;
- if (count != 1)
+ if (count != 1){
+ tidyUp(CurrentDB);
croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
+ }
retval = POPi ;
return (retval) ;
}
+#if 0
+static void
+#ifdef CAN_PROTOTYPE
+db_errcall_cb(const char * db_errpfx, char * buffer)
+#else
+db_errcall_cb(db_errpfx, buffer)
+const char * db_errpfx;
+char * buffer;
+#endif
+{
+#ifdef dTHX
+ dTHX;
+#endif
+ SV * sv = perl_get_sv(ERR_BUFF, FALSE) ;
+ if (sv) {
+ if (db_errpfx)
+ sv_setpvf(sv, "%s: %s", db_errpfx, buffer) ;
+ else
+ sv_setpv(sv, buffer) ;
+ }
+}
+#endif
#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2)
printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
printf (" psize = %d\n", recno->db_RE_psize) ;
printf (" lorder = %d\n", recno->db_RE_lorder) ;
- printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ;
+ printf (" reclen = %lu\n", (unsigned long)recno->db_RE_reclen) ;
printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
}
I32 length = GetArrayLength(aTHX_ db) ;
/* check for attempt to write before start of array */
- if (length + value + 1 <= 0)
+ if (length + value + 1 <= 0) {
+ tidyUp(db);
croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
+ }
value = length + value + 1 ;
}
STRLEN n_a;
dMY_CXT;
-/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
+#ifdef TRACE
+ printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",
+ name, flags, mode, sv == NULL) ;
+#endif
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 ;
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 ;
Flags |= DB_TRUNCATE ;
#endif
+#ifdef AT_LEAST_DB_4_1
+ status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
+ Flags, mode) ;
+#else
status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type,
Flags, mode) ;
+#endif
/* printf("open returned %d %s\n", status, db_strerror(status)) ; */
- if (status == 0)
+ if (status == 0) {
+ /* RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;*/
+
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
0) ;
- /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
+ /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */
+ }
if (status)
RETVAL->dbp = NULL ;
BOOT:
{
+#ifdef dTHX
+ dTHX;
+#endif
+ /* SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; */
MY_CXT_INIT;
__getBerkeleyDBInfo() ;
sv = ST(5) ;
RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ;
- if (RETVAL->dbp == NULL)
+ if (RETVAL->dbp == NULL) {
+ Safefree(RETVAL);
RETVAL = NULL ;
+ }
}
OUTPUT:
RETVAL
dMY_CXT;
INIT:
CurrentDB = db ;
+ Trace(("DESTROY %p\n", db));
CLEANUP:
+ Trace(("DESTROY %p done\n", db));
if (db->hash)
SvREFCNT_dec(db->hash) ;
if (db->compare)
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_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)
DBT_clear(value) ;
CurrentDB = db ;
- /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
RETVAL = db_get(db, key, value, flags) ;
ST(0) = sv_newmortal();
OutputValue(ST(0), value)
#endif
for (i = items-1 ; i > 0 ; --i)
{
- value.data = SvPV(ST(i), n_a) ;
+ DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+ value.data = SvPVbyte(ST(i), n_a) ;
value.size = n_a ;
One = 1 ;
key.data = &One ;
keyval = 0 ;
for (i = 1 ; i < items ; ++i)
{
- value.data = SvPV(ST(i), n_a) ;
+ DBM_ckFilter(ST(i), filter_store_value, "filter_store_value");
+ value.data = SvPVbyte(ST(i), n_a) ;
value.size = n_a ;
++ keyval ;
key.data = &keyval ;
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) ;
+ DBM_setFilter(db->filter_fetch_key, code) ;
SV *
filter_store_key(db, code)
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_key) ;
+ DBM_setFilter(db->filter_store_key, code) ;
SV *
filter_fetch_value(db, code)
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_fetch_value) ;
+ DBM_setFilter(db->filter_fetch_value, code) ;
SV *
filter_store_value(db, code)
SV * code
SV * RETVAL = &PL_sv_undef ;
CODE:
- setFilter(filter_store_value) ;
+ DBM_setFilter(db->filter_store_value, code) ;
-#endif /* DBM_FILTERING */
https://perl5.git.perl.org / perl5.git / blobdiff