In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/414fa04cdda19d4646d695b14dd909e515b70524?hp=7b301413cce02b9a948a0e223b4f6a6c0112f1c1>
- Log ----------------------------------------------------------------- commit 414fa04cdda19d4646d695b14dd909e515b70524 Author: Jerry D. Hedden <[email protected]> Date: Fri Sep 24 21:42:04 2010 +0100 [perl #78000] [PATCH] Upgrade to threads 1.79 Attached is a revised patch to upgrade to v1.79. I needed to fix the tests in the newly added t/kill2.t file. The blead version will be 1.79_01. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + Porting/Maintainers.pl | 2 +- dist/threads/lib/threads.pm | 12 ++++- dist/threads/t/exit.t | 10 ++-- dist/threads/t/kill2.t | 91 +++++++++++++++++++++++++++++++++++++++++++ dist/threads/t/thread.t | 2 +- dist/threads/threads.xs | 15 ++++++- 7 files changed, 121 insertions(+), 12 deletions(-) create mode 100644 dist/threads/t/kill2.t diff --git a/MANIFEST b/MANIFEST index c935b4e..9a20b90 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2984,6 +2984,7 @@ dist/threads/t/free2.t More ithread destruction tests dist/threads/t/free.t Test ithread destruction dist/threads/threads.xs ithreads dist/threads/t/join.t Testing the join function +dist/threads/t/kill2.t Tests thread signalling dist/threads/t/kill.t Tests thread signalling dist/threads/t/libc.t testing libc functions for threadsafety dist/threads/t/list.t Test threads->list() diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index fb65347..46171f3 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1436,7 +1436,7 @@ use File::Glob qw(:case); 'threads' => { 'MAINTAINER' => 'jdhedden', - 'DISTRIBUTION' => 'JDHEDDEN/threads-1.77.tar.gz', + 'DISTRIBUTION' => 'JDHEDDEN/threads-1.79.tar.gz', 'FILES' => q[dist/threads], 'EXCLUDED' => [ qr{^examples/}, qw(t/pod.t diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index 8654f9f..175b8df 100644 --- a/dist/threads/lib/threads.pm +++ b/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.77_03'; +our $VERSION = '1.79_01'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.77 +This document describes threads version 1.79 =head1 SYNOPSIS @@ -1005,6 +1005,12 @@ mutexes that are needed to control functionality within the L<threads> module. For this reason, the use of C<END> blocks in threads is B<strongly> discouraged. +=item Open directory handles + +Spawning threads with open directory handles (see +L<opendir|perlfunc/"opendir DIRHANDLE,EXPR">) will crash the interpreter. +L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154> + =item Perl Bugs and the CPAN Version of L<threads> Support for threads extends beyond the code in this module (i.e., @@ -1034,7 +1040,7 @@ L<threads> Discussion Forum on CPAN: L<http://www.cpanforum.com/dist/threads> Annotated POD for L<threads>: -L<http://annocpan.org/~JDHEDDEN/threads-1.77/threads.pm> +L<http://annocpan.org/~JDHEDDEN/threads-1.79/threads.pm> Source repository: L<http://code.google.com/p/threads-shared/> diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t index 29c3dca..208f7b3 100644 --- a/dist/threads/t/exit.t +++ b/dist/threads/t/exit.t @@ -48,7 +48,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.77;' . +run_perl(prog => 'use threads 1.79;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -98,7 +98,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.79 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); } -my $out = run_perl(prog => 'use threads 1.77;' . +my $out = run_perl(prog => 'use threads 1.79;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.77;' . like($out, '1 finished and unjoined', "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.79 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.77 qw(exit thread_only);' . like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 1.77;' . +run_perl(prog => 'use threads 1.79;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/dist/threads/t/kill2.t b/dist/threads/t/kill2.t new file mode 100644 index 0000000..8eac55b --- /dev/null +++ b/dist/threads/t/kill2.t @@ -0,0 +1,91 @@ +use strict; +use warnings; + +BEGIN { + require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl'); + + use Config; + if (! $Config{'useithreads'}) { + skip_all(q/Perl not compiled with 'useithreads'/); + } +} + +use ExtUtils::testlib; + +use threads; + +BEGIN { + if (! eval 'use threads::shared; 1') { + skip_all('threads::shared not available'); + } + + local $SIG{'HUP'} = sub {}; + my $thr = threads->create(sub {}); + eval { $thr->kill('HUP') }; + $thr->join(); + if ($@ && $@ =~ /safe signals/) { + skip_all('Not using safe signals'); + } + + plan(3); +}; + +fresh_perl_is(<<'EOI', 'ok', { }, 'No signal handler in thread'); + use threads; + use Thread::Semaphore; + my $sema = Thread::Semaphore->new(0); + my $test = sub { + my $sema = shift; + $sema->up(); + while(1) { sleep(1); } + }; + my $thr = threads->create($test, $sema); + $sema->down(); + $thr->detach(); + eval { + $thr->kill('STOP'); + }; + print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok'); +EOI + +fresh_perl_is(<<'EOI', 'ok', { }, 'Handler to signal mismatch'); + use threads; + use Thread::Semaphore; + my $sema = Thread::Semaphore->new(0); + my $test = sub { + my $sema = shift; + $SIG{'TERM'} = sub { threads->exit() }; + $sema->up(); + while(1) { sleep(1); } + }; + my $thr = threads->create($test, $sema); + $sema->down(); + $thr->detach(); + eval { + $thr->kill('STOP'); + }; + print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok'); +EOI + +fresh_perl_is(<<'EOI', 'ok', { }, 'Handler and signal match'); + use threads; + use Thread::Semaphore; + my $sema = Thread::Semaphore->new(0); + my $test = sub { + my $sema = shift; + $SIG{'STOP'} = sub { threads->exit() }; + $sema->up(); + while(1) { sleep(1); } + }; + my $thr = threads->create($test, $sema); + $sema->down(); + $thr->detach(); + eval { + $thr->kill('STOP'); + }; + print((! $@) ? 'ok' : 'not ok'); +EOI + +exit(0); + +# EOF diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t index b390215..32c50b8 100644 --- a/dist/threads/t/thread.t +++ b/dist/threads/t/thread.t @@ -161,7 +161,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.77;' . +run_perl(prog => 'use threads 1.79;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index f4e6946..6c38bdc 100644 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -1342,6 +1342,7 @@ ithread_kill(...) ithread *thread; char *sig_name; IV signal; + int no_handler = 1; CODE: /* Must have safe signals */ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { @@ -1371,11 +1372,21 @@ ithread_kill(...) MUTEX_LOCK(&thread->mutex); if (thread->interp) { dTHXa(thread->interp); - PL_psig_pend[signal]++; - PL_sig_pending = 1; + if (PL_psig_pend && PL_psig_ptr[signal]) { + PL_psig_pend[signal]++; + PL_sig_pending = 1; + no_handler = 0; + } + } else { + /* Ignore signal to terminated thread */ + no_handler = 0; } MUTEX_UNLOCK(&thread->mutex); + if (no_handler) { + Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid); + } + /* Return the thread to allow for method chaining */ ST(0) = ST(0); /* XSRETURN(1); - implied */ -- Perl5 Master Repository
