From bfb2cb3cddffa144b521bb5dff76af1e065288ad Mon Sep 17 00:00:00 2001

From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>

Date: Tue, 10 Jun 2014 14:28:09 +0200

Subject: [PATCH] Destroy DB_File objects only from original thread context

MIME-Version: 1.0

Content-Type: text/plain; charset=UTF-8

Content-Transfer-Encoding: 8bit

This patch fixes a crash when destroing a hash tied to a DB_File

database after spawning a thread:

use Fcntl;

use DB_File;

use threads;

tie(my %dbtest, 'DB_File', "test.db", O_RDWR|O_CREAT, 0666);

threads->new(sub {})->join;

This crashed or paniced depending on how perl was configured.

Closes RT#61912.

Signed-off-by: Petr Písař <ppisar@redhat.com>

---

 DB_File.xs     | 50 +++++++++++++++++++++++++++++++-------------------

 MANIFEST       |  1 +

 t/db-threads.t | 46 ++++++++++++++++++++++++++++++++++++++++++++++

 3 files changed, 78 insertions(+), 19 deletions(-)

 create mode 100644 t/db-threads.t

diff --git a/DB_File.xs b/DB_File.xs

index f417b22..ed6a904 100755

--- a/DB_File.xs

+++ b/DB_File.xs

@@ -407,6 +407,7 @@ typedef union INFO {

 typedef struct {

 	DBTYPE	type ;

+	tTHX    owner ;

 	DB * 	dbp ;

 	SV *	compare ;

 	bool	in_compare ;

@@ -1006,6 +1007,7 @@ SV *   sv ;

 		    name, flags, mode, sv == NULL) ;  

 #endif

     Zero(RETVAL, 1, DB_File_type) ;

+    RETVAL->owner = aTHX;

     /* Default to HASH */

     RETVAL->filtering = 0 ;

@@ -1278,6 +1280,7 @@ SV *   sv ;

 /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ;  */

     Zero(RETVAL, 1, DB_File_type) ;

+    RETVAL->owner = aTHX;

     /* Default to HASH */

     RETVAL->filtering = 0 ;

@@ -1597,27 +1600,36 @@ db_DESTROY(db)

 	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) ;

-	  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) ;

-	  safefree(db) ;

+	CODE:

+	  RETVAL = 0;

+	  if (db && db->owner == aTHX) {

+	    RETVAL = db_DESTROY(db);

 #ifdef DB_VERSION_MAJOR

-	  if (RETVAL > 0)

-	    RETVAL = -1 ;

+	    if (RETVAL > 0)

+		RETVAL = -1 ;

 #endif

+	  }

+	OUTPUT:

+	  RETVAL

+	CLEANUP:

+	  Trace(("DESTROY %p done\n", db));

+	  if (db && db->owner == aTHX) {

+	    if (db->hash)

+		SvREFCNT_dec(db->hash) ;

+	    if (db->compare)

+		SvREFCNT_dec(db->compare) ;

+	    if (db->prefix)

+		SvREFCNT_dec(db->prefix) ;

+	    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) ;

+	    safefree(db) ;

+	  }

 int

diff --git a/MANIFEST b/MANIFEST

index e460e81..47f43f7 100644

--- a/MANIFEST

+++ b/MANIFEST

@@ -27,6 +27,7 @@ t/db-btree.t

 t/db-hash.t

 t/db-recno.t

 t/pod.t

+t/db-threads.t

 typemap

 version.c

 META.yml                                 Module meta-data (added by MakeMaker)

diff --git a/t/db-threads.t b/t/db-threads.t

new file mode 100644

index 0000000..b9f69b6

--- /dev/null

+++ b/t/db-threads.t

@@ -0,0 +1,46 @@

+#!./perl

+

+use warnings;

+use strict;

+use Config;

+use Fcntl;

+use Test::More;

+use DB_File;

+

+if (-d "lib" && -f "TEST") {

+    if ($Config{'extensions'} !~ /\bDB_File\b/ ) {

+        plan skip_all => 'DB_File was not built';

+    }

+}

+plan skip_all => 'Threads are disabled'

+    unless $Config{usethreads};

+

+plan tests => 7;

+

+# Check DBM back-ends do not destroy objects from then-spawned threads.

+# RT#61912.

+use_ok('threads');

+

+my %h;

+unlink <threads*>;

+

+my $db = tie %h, 'DB_File', 'threads', O_RDWR|O_CREAT, 0640;

+isa_ok($db, 'DB_File');

+

+for (1 .. 2) {

+    ok(threads->create(

+        sub {

+            $SIG{'__WARN__'} = sub { fail(shift) }; # debugging perl panics

+                # report it by spurious TAP line

+            1;

+        }), "Thread $_ created");

+}

+for (threads->list) {

+    is($_->join, 1, "A thread exited successfully");

+}

+

+pass("Tied object survived exiting threads");

+

+undef $db;

+untie %h;

+unlink <threads*>;

-- 

2.5.5