X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDB_File%2FDB_File.xs;h=7cbe5e8d6c9b08401b59aad5e79da9a41171772e;hb=798b63bc924a07589315b3229311582adce06136;hp=c788b987fb0fb51d880ce21a58c8bf1de1485968;hpb=412e9c57bba27dca18d003a2be60e2d55b6d4866;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index c788b98..7cbe5e8 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 <Paul.Marquess@btinternet.com>
- last modified 26th Nov 2001
- version 1.801
+ written by Paul Marquess <pmqs@cpan.org>
+ last modified 11th November 2005
+ version 1.814
 
  All comments/suggestions/problems are welcome
 
-     Copyright (c) 1995-2001 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.
 
@@ -98,6 +98,22 @@
         1.800 - Moved backward compatability code into ppport.h.
                 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
 
 */
 
@@ -122,8 +138,6 @@
 #    undef __attribute__
 #endif
 
-
-
 #ifdef COMPAT185
 #    include <db_185.h>
 #else
@@ -161,7 +175,6 @@
 #include <fcntl.h> 
 
 /* #define TRACE */
-#define DBM_FILTERING
 
 #ifdef TRACE
 #    define Trace(x)        printf x
@@ -182,6 +195,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
@@ -326,16 +355,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)		\
@@ -343,7 +372,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)
@@ -357,8 +386,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 ;
@@ -366,63 +399,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") ; 	\
 	  } 								\
 	}
 
@@ -450,6 +463,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
@@ -512,6 +527,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
@@ -547,6 +568,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 ;
 
@@ -563,25 +590,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) ;
 
 }
@@ -619,6 +653,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 ;
 
@@ -635,6 +674,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) ;
@@ -646,8 +689,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 ;
  
@@ -694,9 +739,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 = "" ;
@@ -705,9 +755,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 ;
 
@@ -715,8 +770,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 ;
 
@@ -727,6 +784,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)
 
@@ -762,7 +840,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) ;
 }
@@ -836,8 +914,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 ;
     }
@@ -871,15 +951,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 ;
 
@@ -1149,11 +1230,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 ;
 
@@ -1171,6 +1250,9 @@ SV *   sv ;
     }	
     dbp = RETVAL->dbp ;
 
+#ifdef WANT_ERROR
+	    RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ;
+#endif
     if (sv)
     {
         if (! SvROK(sv) )
@@ -1365,14 +1447,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 ;
@@ -1394,6 +1489,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() ;
  
@@ -1423,8 +1524,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
@@ -1436,14 +1539,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)
@@ -1452,7 +1556,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)
@@ -1502,7 +1605,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)
@@ -1588,7 +1690,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 ;
@@ -1697,7 +1800,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 ;
@@ -1856,33 +1960,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)
@@ -1890,7 +1974,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)
@@ -1898,7 +1982,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)
@@ -1906,6 +1990,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 */