DB_File.xs -- Perl 5 interface to Berkeley DB
- written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 1st September 2002
- version 1.805
+ written by Paul Marquess <pmqs@cpan.org>
+ last modified 4th February 2007
+ version 1.817
All comments/suggestions/problems are welcome
- Copyright (c) 1995-2002 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-2008 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.
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
+ 1.812 - no change
+ 1.813 - no change
+ 1.814 - no change
+ 1.814 - C++ casting fixes
*/
# define AT_LEAST_DB_3_2
#endif
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_3_3
+#endif
+
#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 1)
# define AT_LEAST_DB_4_1
#endif
+#if DB_VERSION_MAJOR > 4 || (DB_VERSION_MAJOR == 4 && DB_VERSION_MINOR >= 3)
+# define AT_LEAST_DB_4_3
+#endif
+
+#ifdef AT_LEAST_DB_3_3
+# define WANT_ERROR
+#endif
+
/* map version 2 features & constants onto their version 1 equivalent */
#ifdef DB_Prefix_t
typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;
-#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (const char *)""), s)
#define OutputValue(arg, name) \
{ if (RETVAL == 0) { \
- my_sv_setpvn(arg, name.data, name.size) ; \
- TAINT; \
+ SvGETMAGIC(arg) ; \
+ my_sv_setpvn(arg, (const char *)name.data, name.size) ; \
+ 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); \
+ my_sv_setpvn(arg, (const char *)name.data, name.size); \
} \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
- TAINT; \
+ TAINT; \
SvTAINTED_on(arg); \
+ SvUTF8_off(arg); \
DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \
} \
}
static void
tidyUp(DB_File db)
{
- /* db_DESTROY(db); */
db->aborted = TRUE ;
}
void * data1, * data2 ;
int retval ;
int count ;
- DB_File keep_CurrentDB = CurrentDB;
if (CurrentDB->in_compare) {
ENTER ;
SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_compare = FALSE;
+ SAVEINT(CurrentDB->in_compare);
+ CurrentDB->in_compare = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
- PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
- PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+ PUSHs(sv_2mortal(newSVpvn((const char*)data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size)));
PUTBACK ;
- CurrentDB->in_compare = TRUE;
-
count = perl_call_sv(CurrentDB->compare, G_SCALAR);
- CurrentDB = keep_CurrentDB;
- CurrentDB->in_compare = FALSE;
-
SPAGAIN ;
if (count != 1){
char * data1, * data2 ;
int retval ;
int count ;
- DB_File keep_CurrentDB = CurrentDB;
if (CurrentDB->in_prefix){
tidyUp(CurrentDB);
ENTER ;
SAVETMPS;
+ SAVESPTR(CurrentDB);
+ CurrentDB->in_prefix = FALSE;
+ SAVEINT(CurrentDB->in_prefix);
+ CurrentDB->in_prefix = TRUE;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
PUTBACK ;
- CurrentDB->in_prefix = TRUE;
-
count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
- CurrentDB = keep_CurrentDB;
- CurrentDB->in_prefix = FALSE;
-
SPAGAIN ;
if (count != 1){
#endif
dSP ;
dMY_CXT;
- int retval ;
+ int retval = 0;
int count ;
- DB_File keep_CurrentDB = CurrentDB;
if (CurrentDB->in_hash){
tidyUp(CurrentDB);
/* 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 ;
- keep_CurrentDB->in_hash = TRUE;
-
count = perl_call_sv(CurrentDB->hash, G_SCALAR);
- CurrentDB = keep_CurrentDB;
- CurrentDB->in_hash = FALSE;
-
SPAGAIN ;
if (count != 1){
return (retval) ;
}
+#ifdef WANT_ERROR
+
static void
-#ifdef CAN_PROTOTYPE
-db_errcall_cb(const char * db_errpfx, char * buffer)
+#ifdef AT_LEAST_DB_4_3
+db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer)
#else
-db_errcall_cb(db_errpfx, buffer)
-const char * db_errpfx;
-char * buffer;
+db_errcall_cb(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_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) ;
}
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 */
Flags |= DB_TRUNCATE ;
#endif
- status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
+ status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ;
if (status == 0)
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
}
dbp = RETVAL->dbp ;
+#ifdef WANT_ERROR
+ RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
+#endif
if (sv)
{
if (! SvROK(sv) )
Flags |= DB_TRUNCATE ;
#endif
+#ifdef AT_LEAST_DB_4_4
+ /* need this for recno */
+ if ((flags & O_TRUNC) == O_TRUNC)
+ Flags |= DB_CREATE ;
+#endif
+
#ifdef AT_LEAST_DB_4_1
status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type,
Flags, mode) ;
/* printf("open returned %d %s\n", status, db_strerror(status)) ; */
if (status == 0) {
- RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
0) ;
BOOT:
{
- SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
+#ifdef dTHX
+ dTHX;
+#endif
+#ifdef WANT_ERROR
+ SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ;
+#endif
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
#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 ;