Dne Út 10.čen.2014 07:34:07, ppisar napsal(a):
Show quoted text> This code segfaults:
>
> #!/usr/bin/perl
> use strict;
> use warnings;
> use Fcntl;
> use DB_File;
> use threads;
>
> my $db = tie(my %dbtest, 'DB_File', "file", O_RDWR|O_CREAT, 0666);
>
> for (1 .. 2) {
> threads->new(sub {});
> }
>
> for (threads->list) {
> $_->join;
> }
>
> undef $db;
> untie %dbtest;
>
>
> See <
https://rt.perl.org/Ticket/Display.html?id=61912> for more details.
Attached patch should fix it. Although I'm not sure I have covered all the preprocessor branches.
-- Petr
From d96d40d46bca3c523b1d4d2b580691dc7d8e9802 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 | 49 ++++++++++++++++++++++++++++++-------------------
MANIFEST | 1 +
t/db-threads.t | 46 ++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 77 insertions(+), 19 deletions(-)
create mode 100644 t/db-threads.t
diff --git a/DB_File.xs b/DB_File.xs
index 679c416..685888e 100755
--- a/DB_File.xs
+++ b/DB_File.xs
@@ -397,6 +397,7 @@ typedef union INFO {
typedef struct {
DBTYPE type ;
+ tTHX owner ;
DB * dbp ;
SV * compare ;
bool in_compare ;
@@ -983,6 +984,7 @@ SV * sv ;
name, flags, mode, sv == NULL) ;
#endif
Zero(RETVAL, 1, DB_File_type) ;
+ RETVAL->owner = aTHX;
/* Default to HASH */
RETVAL->filtering = 0 ;
@@ -1255,6 +1257,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 ;
@@ -1571,27 +1574,35 @@ 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:
+ 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..8987e64
--- /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*>;
--
1.9.3
