perl/perl-5.34.0-Destroy-GDBM-NDBM-ODBM-SDBM-_File-objects-only-from-.patch

From 8067179e65a28d91f00df7d36778229a07514471 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
Date: Thu, 29 Apr 2021 12:21:18 +0200
Subject: [PATCH] Destroy {GDBM,NDBM,ODBM,SDBM}_File objects only from original

This patch fixes a crash when destroing a hash tied to a *_File
database after spawning a thread:

use Fcntl;
use SDBM_File;
use threads;
tie(my %dbtest, 'SDBM_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.

Updated original ppisar's patch for perl 5.18.2
---
 ext/GDBM_File/GDBM_File.xs | 20 ++++++++++++--------
 ext/NDBM_File/NDBM_File.xs | 16 ++++++++++------
 ext/ODBM_File/ODBM_File.xs | 18 +++++++++++-------
 ext/SDBM_File/SDBM_File.xs |  4 +++-
 t/lib/dbmt_common.pl       | 35 +++++++++++++++++++++++++++++++++++
 5 files changed, 71 insertions(+), 22 deletions(-)

diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index cd0bb6f..0c395ac 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -13,6 +13,7 @@
 #define store_value 3
 
 typedef struct {
+	tTHX    owner;
 	GDBM_FILE 	dbp ;
 	SV *    filter[4];
 	int     filtering ;
@@ -276,6 +277,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode)
 	}
 	if (dbp) {
 	    RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type));
+	    RETVAL->owner = aTHX;
 	    RETVAL->dbp = dbp;
 	} else {
 	    RETVAL = NULL;
@@ -289,15 +291,17 @@ gdbm_DESTROY(db)
 	PREINIT:
 	int i = store_value;
     CODE:
-        if (gdbm_file_close(db)) {
-            croak("gdbm_close: %s; %s", gdbm_strerror(gdbm_errno),
-                  strerror(errno));
+        if (db && db->owner == aTHX) {
+            if (gdbm_file_close(db)) {
+                croak("gdbm_close: %s; %s", gdbm_strerror(gdbm_errno),
+                      strerror(errno));
+	    }
+	    do {
+	        if (db->filter[i])
+		    SvREFCNT_dec(db->filter[i]);
+	    } while (i-- > 0);
+	    safefree(db);
 	}
-	do {
-	    if (db->filter[i])
-		SvREFCNT_dec(db->filter[i]);
-	} while (i-- > 0);
-	safefree(db);
 
 void
 gdbm_UNTIE(db, count)
diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index eed671a..651fe0f 100644
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -33,6 +33,7 @@ END_EXTERN_C
 #define store_value 3
 
 typedef struct {
+	tTHX    owner;
 	DBM * 	dbp ;
 	SV *    filter[4];
 	int     filtering ;
@@ -71,6 +72,7 @@ ndbm_TIEHASH(dbtype, filename, flags, mode)
 	    RETVAL = NULL ;
 	    if ((dbp =  dbm_open(filename, flags, mode))) {
 	        RETVAL = (NDBM_File)safecalloc(1, sizeof(NDBM_File_type));
+		RETVAL->owner = aTHX;
 		RETVAL->dbp = dbp ;
 	    }
 	    
@@ -84,12 +86,14 @@ ndbm_DESTROY(db)
 	PREINIT:
 	int i = store_value;
 	CODE:
-	dbm_close(db->dbp);
-	do {
-	    if (db->filter[i])
-		SvREFCNT_dec(db->filter[i]);
-	} while (i-- > 0);
-	safefree(db);
+	if (db && db->owner == aTHX) {
+	    dbm_close(db->dbp);
+	    do {
+	        if (db->filter[i])
+		    SvREFCNT_dec(db->filter[i]);
+	    } while (i-- > 0);
+	    safefree(db);
+	}
 
 #define ndbm_FETCH(db,key)			dbm_fetch(db->dbp,key)
 datum_value
diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index 38e6dbf..4b15a42 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -49,6 +49,7 @@ datum	nextkey(datum key);
 #define store_value 3
 
 typedef struct {
+	tTHX    owner;
 	void * 	dbp ;
 	SV *    filter[4];
 	int     filtering ;
@@ -137,6 +138,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
 	    }
 	    dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
 	    RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type));
+	    RETVAL->owner = aTHX;
 	    RETVAL->dbp = dbp ;
 	}
 	OUTPUT:
@@ -149,13 +151,15 @@ DESTROY(db)
 	dMY_CXT;
 	int i = store_value;
 	CODE:
-	dbmrefcnt--;
-	dbmclose();
-	do {
-	    if (db->filter[i])
-		SvREFCNT_dec(db->filter[i]);
-	} while (i-- > 0);
-	safefree(db);
+	if (db && db->owner == aTHX) {
+	    dbmrefcnt--;
+	    dbmclose();
+	    do {
+	        if (db->filter[i])
+		    SvREFCNT_dec(db->filter[i]);
+	    } while (i-- > 0);
+	    safefree(db);
+	}
 
 datum_value
 odbm_FETCH(db, key)
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index 0df2855..0e2bd58 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -10,6 +10,7 @@
 #define store_value 3
 
 typedef struct {
+	tTHX    owner;
 	DBM * 	dbp ;
 	SV *    filter[4];
 	int     filtering ;
@@ -51,6 +52,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL)
 	    }
 	    if (dbp) {
 	        RETVAL = (SDBM_File)safecalloc(1, sizeof(SDBM_File_type));
+		RETVAL->owner = aTHX;
 		RETVAL->dbp = dbp ;
 	    }
 	    
@@ -62,7 +64,7 @@ void
 sdbm_DESTROY(db)
 	SDBM_File	db
 	CODE:
-	if (db) {
+	if (db && db->owner == aTHX) {
 	    int i = store_value;
 	    sdbm_close(db->dbp);
 	    do {
diff --git a/t/lib/dbmt_common.pl b/t/lib/dbmt_common.pl
index 60c66ae..a7f81fe 100644
--- a/t/lib/dbmt_common.pl
+++ b/t/lib/dbmt_common.pl
@@ -510,5 +510,40 @@ unlink <Op_dbmx*>, $Dfile;
    unlink <Op1_dbmx*>;
 }
 
+{
+   # Check DBM back-ends do not destroy objects from then-spawned threads.
+   # RT#61912.
+   SKIP: {
+      my $threads_count = 2;
+      skip 'Threads are disabled', 3 + 2 * $threads_count
+        unless $Config{usethreads};
+      use_ok('threads');
+
+      my %h;
+      unlink <Op1_dbmx*>;
+
+      my $db = tie %h, $DBM_Class, 'Op1_dbmx', $create, 0640;
+      isa_ok($db, $DBM_Class);
+
+      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 <Op1_dbmx*>;
+   }
+}
+
 done_testing();
 1;
-- 
2.26.3