1*f3efcd01Safresh1#!./perl 2*f3efcd01Safresh1 3*f3efcd01Safresh1use warnings; 4*f3efcd01Safresh1use strict; 5*f3efcd01Safresh1use Config; 6*f3efcd01Safresh1use Fcntl; 7*f3efcd01Safresh1use Test::More; 8*f3efcd01Safresh1use DB_File; 9*f3efcd01Safresh1use File::Temp qw(tempdir) ; 10*f3efcd01Safresh1 11*f3efcd01Safresh1if (-d "lib" && -f "TEST") { 12*f3efcd01Safresh1 if ($Config{'extensions'} !~ /\bDB_File\b/ ) { 13*f3efcd01Safresh1 plan skip_all => 'DB_File was not built'; 14*f3efcd01Safresh1 } 15*f3efcd01Safresh1} 16*f3efcd01Safresh1plan skip_all => 'Threads are disabled' 17*f3efcd01Safresh1 unless $Config{usethreads}; 18*f3efcd01Safresh1 19*f3efcd01Safresh1plan skip_all => 'Thread test needs Perl 5.8.7 or greater' 20*f3efcd01Safresh1 unless $] >= 5.008007; 21*f3efcd01Safresh1 22*f3efcd01Safresh1plan tests => 7; 23*f3efcd01Safresh1 24*f3efcd01Safresh1# Check DBM back-ends do not destroy objects from then-spawned threads. 25*f3efcd01Safresh1# RT#61912. 26*f3efcd01Safresh1use_ok('threads'); 27*f3efcd01Safresh1 28*f3efcd01Safresh1my $TEMPDIR = tempdir( CLEANUP => 1 ); 29*f3efcd01Safresh1chdir $TEMPDIR; 30*f3efcd01Safresh1 31*f3efcd01Safresh1my %h; 32*f3efcd01Safresh1unlink <threads*>; 33*f3efcd01Safresh1 34*f3efcd01Safresh1my $db = tie %h, 'DB_File', 'threads', O_RDWR|O_CREAT, 0640; 35*f3efcd01Safresh1isa_ok($db, 'DB_File'); 36*f3efcd01Safresh1 37*f3efcd01Safresh1for (1 .. 2) { 38*f3efcd01Safresh1 ok(threads->create( 39*f3efcd01Safresh1 sub { 40*f3efcd01Safresh1 $SIG{'__WARN__'} = sub { fail(shift) }; # debugging perl panics 41*f3efcd01Safresh1 # report it by spurious TAP line 42*f3efcd01Safresh1 1; 43*f3efcd01Safresh1 }), "Thread $_ created"); 44*f3efcd01Safresh1} 45*f3efcd01Safresh1for (threads->list) { 46*f3efcd01Safresh1 is($_->join, 1, "A thread exited successfully"); 47*f3efcd01Safresh1} 48*f3efcd01Safresh1 49*f3efcd01Safresh1pass("Tied object survived exiting threads"); 50*f3efcd01Safresh1 51*f3efcd01Safresh1undef $db; 52*f3efcd01Safresh1untie %h; 53*f3efcd01Safresh1unlink <threads*>; 54