X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2FDB_File.xs;h=8f16257a718ebc94ecdc2f453da597c30664f163;hb=05bc20f3049bc9fc0c4874ea91065f8f6d00d4b5;hp=26e2160f32ded05ab8496f015a764b215e0b6455;hpb=d63909e497678c98f7f710462c7feadb15b4cea5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 26e2160..8f16257 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -2,13 +2,13 @@ DB_File.xs -- Perl 5 interface to Berkeley DB - written by Paul Marquess - last modified 6th Jan 2002 - version 1.802 + written by Paul Marquess + 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. @@ -99,6 +99,22 @@ 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 + 1.812 - no change + 1.813 - no change + 1.814 - no change + 1.814 - C++ casting fixes */ @@ -123,8 +139,6 @@ # undef __attribute__ #endif - - #ifdef COMPAT185 # include #else @@ -162,7 +176,6 @@ #include /* #define TRACE */ -#define DBM_FILTERING #ifdef TRACE # define Trace(x) printf x @@ -183,6 +196,22 @@ # 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 @@ -327,16 +356,16 @@ typedef union INFO { -#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) \ @@ -344,7 +373,7 @@ typedef union INFO { #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) @@ -358,8 +387,12 @@ typedef struct { 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 ; @@ -367,63 +400,43 @@ 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 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) ; \ - ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + 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); \ - ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + TAINT; \ + SvTAINTED_on(arg); \ + SvUTF8_off(arg); \ + DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ } \ } @@ -451,6 +464,8 @@ START_MY_CXT #define CurrentDB (MY_CXT.x_CurrentDB) #define empty (MY_CXT.x_empty) +#define ERR_BUFF "DB_File::Error" + #ifdef DB_VERSION_MAJOR static int @@ -513,6 +528,12 @@ u_int flags ; #endif /* DB_VERSION_MAJOR */ +static void +tidyUp(DB_File db) +{ + db->aborted = TRUE ; +} + static int #ifdef AT_LEAST_DB_3_2 @@ -548,6 +569,12 @@ const DBT * key2 ; 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 ; @@ -564,25 +591,32 @@ const DBT * key2 ; 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 ; count = perl_call_sv(CurrentDB->compare, G_SCALAR); 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) ; } @@ -620,6 +654,11 @@ const DBT * key2 ; 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 ; @@ -636,6 +675,10 @@ const DBT * key2 ; ENTER ; SAVETMPS; + SAVESPTR(CurrentDB); + CurrentDB->in_prefix = FALSE; + SAVEINT(CurrentDB->in_prefix); + CurrentDB->in_prefix = TRUE; PUSHMARK(SP) ; EXTEND(SP,2) ; @@ -647,8 +690,10 @@ const DBT * key2 ; 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 ; @@ -695,9 +740,14 @@ HASH_CB_SIZE_TYPE size ; #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 = "" ; @@ -706,9 +756,14 @@ HASH_CB_SIZE_TYPE size ; /* 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 ; @@ -716,8 +771,10 @@ HASH_CB_SIZE_TYPE size ; 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 ; @@ -728,6 +785,27 @@ HASH_CB_SIZE_TYPE size ; return (retval) ; } +#ifdef WANT_ERROR + +static void +#ifdef AT_LEAST_DB_4_3 +db_errcall_cb(const DB_ENV* dbenv, const char * db_errpfx, const char * buffer) +#else +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_setpvf(sv, "%s: %s", db_errpfx, buffer) ; + else + sv_setpv(sv, buffer) ; + } +} +#endif #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) @@ -763,7 +841,7 @@ INFO * recno ; 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) ; } @@ -837,8 +915,10 @@ I32 value ; 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 ; } @@ -872,15 +952,16 @@ SV * sv ; 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 ; @@ -1111,7 +1192,7 @@ SV * sv ; 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) ; @@ -1150,11 +1231,9 @@ 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 ; @@ -1172,6 +1251,9 @@ SV * sv ; } dbp = RETVAL->dbp ; +#ifdef WANT_ERROR + RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; +#endif if (sv) { if (! SvROK(sv) ) @@ -1366,14 +1448,27 @@ SV * 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) ; +#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) { + 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 ; @@ -1395,6 +1490,12 @@ INCLUDE: constants.xs BOOT: { +#ifdef dTHX + dTHX; +#endif +#ifdef WANT_ERROR + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; +#endif MY_CXT_INIT; __getBerkeleyDBInfo() ; @@ -1424,8 +1525,10 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H 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 @@ -1437,14 +1540,15 @@ db_DESTROY(db) 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) @@ -1453,7 +1557,6 @@ db_DESTROY(db) 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) @@ -1503,7 +1606,6 @@ db_FETCH(db, key, flags=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) @@ -1589,7 +1691,8 @@ unshift(db, ...) #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 ; @@ -1698,7 +1801,8 @@ push(db, ...) 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 ; @@ -1857,33 +1961,13 @@ 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) ; + DBM_setFilter(db->filter_fetch_key, code) ; SV * filter_store_key(db, code) @@ -1891,7 +1975,7 @@ 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) @@ -1899,7 +1983,7 @@ 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) @@ -1907,6 +1991,5 @@ 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 */