Preferred bug tracker

Please visit the preferred bug tracker to report your issue.

This queue is for tickets about the DB_File CPAN distribution.

Report information
The Basics
Id:
96357
Status:
resolved
Priority:
Low/Low
Queue:

People
Owner:
Nobody in particular
Requestors:
ppisar [...] redhat.com
Cc:
AdminCc:

BugTracker
Severity:
(no value)
Broken in:
1.831
Fixed in:
1.842



Subject: DB_File destructor is not thread-safe
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.
From: ppisar@redhat.com
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
Subject: 0001-Destroy-DB_File-objects-only-from-original-thread-co.patch
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
From: ppisar@redhat.com
Dne Út 10.čen.2014 09:15:46, ppisar napsal(a):
Show quoted text
> Dne Út 10.čen.2014 07:34:07, ppisar napsal(a):
> > 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. >
The patch forgot to initialize return value from DESTROY() which leads to a compiler warning. Now attached patch fixes this small glitch, although I think the return value has not semantics and could be drop completely. -- Petr
Subject: 0001-Destroy-DB_File-objects-only-from-original-thread-co.patch
From d4499d6a6f8007df03fe5292aab4ba0367499dd0 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 679c416..762f4ed 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,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*>; -- 1.9.3
After switching from Perl 5.16.2 (openSUSE 12.3) to Perl 5.18.2 (SLES 12) (each with the included DB_File) our application started dumping cores. The C++ application uses an embedded perl interpreter and clones interpreter instances for the actual execution of the Perl code. Stacktraces seemed to indicate that the problem existed in XS_DB_File_DESTROY. That´s why I considered your bug report and patch applicable to our situation. Anyway - updating to the latest DB_File from CPAN (1.835) did not help, but after applying your patch to DB_File 1.835 (succeeded with some line offsets) our application stopped crashing I´d therefore recommend applying this patch to DB_File and releasing a new version to CPAN! Petr - thanks for the patch!
Intend dealing with this issue by adding a CLONE_SKIP into DB_File.pm to deal with this issue. See perlmod for the details.
Dne St 11.dub.2018 18:21:33, PMQS napsal(a):
Show quoted text
> Intend dealing with this issue by adding a CLONE_SKIP into DB_File.pm > to deal with this issue. See perlmod for the details.
Yes, that's much simpler. I confirm 1.842 also works for me.


This service runs on Request Tracker, is sponsored by The Perl Foundation, and maintained by Best Practical Solutions.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.