ext/threads/threads.pm ithreads
ext/threads/threads.xs ithreads
ext/threads/t/join.t Testing the join function
+ext/threads/t/kill.t Tests thread signalling
ext/threads/t/libc.t testing libc functions for threadsafety
ext/threads/t/list.t Test threads->list()
ext/threads/t/problems.t Test various memory problems
Revision history for Perl extension threads.
+1.27 Wed May 10 14:01:17 EDT 2006
+ - Added $thr->kill() method for thread signalling
+ - Check for 'C' compiler when building module
+
1.26 Mon May 8 13:18:29 EDT 2006
- Fix for Win32 build WRT page size
use ExtUtils::MakeMaker;
+# Used to check for a 'C' compiler
+sub check_cc
+{
+ require File::Spec;
+
+ my $cmd = $_[0];
+ if (-x $cmd or MM->maybe_command($cmd)) {
+ return (1); # CC command found
+ }
+ for my $dir (File::Spec->path(), '.') {
+ my $abs = File::Spec->catfile($dir, $cmd);
+ if (-x $abs or MM->maybe_command($abs)) {
+ return (1); # CC command found
+ }
+ }
+ return;
+}
+
+sub have_cc
+{
+ eval { require Config_m; }; # ExtUtils::FakeConfig (+ ActivePerl)
+ if ($@) {
+ eval { require Config; }; # Everyone else
+ }
+ my @chunks = split(/ /, $Config::Config{cc});
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ if (check_cc("@chunks")) {
+ return (1); # CC command found
+ }
+ pop(@chunks);
+ }
+ return;
+}
+
+
# Build options for different environments
my @conditional_params;
if (grep { $_ eq 'PERL_CORE=1' } @ARGV) {
'NORECURS' => 1);
} else {
# CPAN
- push(@conditional_params, 'DEFINE' => '-DHAS_PPPORT_H');
+
+ # Verify that a 'C' compiler is available
+ if (! have_cc()) {
+ die("No 'C' compiler found to build 'threads'\n");
+ }
+
+ push(@conditional_params, 'DEFINE' => '-DHAS_PPPORT_H');
}
+# Create Makefile
WriteMakefile(
'NAME' => 'threads',
'AUTHOR' => 'Artur Bergman <sky AT crucially DOT net>',
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+ use Config;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+}
+
+use ExtUtils::testlib;
+
+use threads;
+use threads::shared;
+
+{
+ package Thread::Semaphore;
+ use threads::shared;
+
+ sub new {
+ my $class = shift;
+ my $val : shared = @_ ? shift : 1;
+ bless \$val, $class;
+ }
+
+ sub down {
+ my $s = shift;
+ lock($$s);
+ my $inc = @_ ? shift : 1;
+ cond_wait $$s until $$s >= $inc;
+ $$s -= $inc;
+ }
+
+ sub up {
+ my $s = shift;
+ lock($$s);
+ my $inc = @_ ? shift : 1;
+ ($$s += $inc) > 0 and cond_broadcast $$s;
+ }
+}
+
+BEGIN {
+ $| = 1;
+ print("1..18\n"); ### Number of tests that will be run ###
+};
+
+my $TEST = 1;
+share($TEST);
+
+ok(1, 'Loaded');
+
+sub ok {
+ my ($ok, $name) = @_;
+
+ lock($TEST);
+ my $id = $TEST++;
+
+ # You have to do it this way or VMS will get confused.
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+
+ return ($ok);
+}
+
+
+### Start of Testing ###
+
+### Thread cancel ###
+
+# Set up to capture warning when thread terminates
+my @errs :shared;
+$SIG{__WARN__} = sub { push(@errs, @_); };
+
+
+sub thr_func {
+ # Thread 'cancellation' signal handler
+ $SIG{'KILL'} = sub {
+ ok(1, 'Thread received signal');
+ die("Thread killed\n");
+ };
+
+ # Thread sleeps until signalled
+ ok(1, 'Thread sleeping');
+ sleep(5);
+ # Should not go past here
+ ok(0, 'Thread terminated normally');
+ return ('ERROR');
+}
+
+
+# Create thread
+my $thr = threads->create('thr_func');
+ok($thr && $thr->tid() == 1, 'Created thread');
+threads->yield();
+sleep(1);
+
+# Signal thread
+ok($thr->kill('KILL'), 'Signalled thread');
+threads->yield();
+
+# Interrupt thread's sleep call
+{
+ local $SIG{'INT'} = sub {};
+ ok(kill('INT', $$) || $^O eq 'MSWin32', q/Interrupt thread's sleep call/);
+}
+
+# Cleanup
+my $rc = $thr->join();
+ok(! $rc, 'No thread return value');
+
+# Check for thread termination message
+ok(@errs && $errs[0] =~ /Thread killed/, 'Thread termination warning');
+
+
+### Thread suspend/resume ###
+
+sub thr_func2
+{
+ my $sema = shift;
+ ok($sema, 'Thread received semaphore');
+
+ # Set up the signal handler for suspension/resumption
+ $SIG{'STOP'} = sub {
+ ok(1, 'Thread suspending');
+ $sema->down();
+ ok(1, 'Thread resuming');
+ $sema->up();
+ };
+
+ # Set up the signal handler for graceful termination
+ my $term = 0;
+ $SIG{'TERM'} = sub {
+ ok(1, 'Thread caught termination signal');
+ $term = 1;
+ };
+
+ # Do work until signalled to terminate
+ while (! $term) {
+ sleep(1);
+ }
+
+ ok(1, 'Thread done');
+ return ('OKAY');
+}
+
+
+# Create a semaphore for use in suspending the thread
+my $sema = Thread::Semaphore->new();
+ok($sema, 'Semaphore created');
+
+# Create a thread and send it the semaphore
+$thr = threads->create('thr_func2', $sema);
+ok($thr && $thr->tid() == 2, 'Created thread');
+threads->yield();
+sleep(1);
+
+# Suspend the thread
+$sema->down();
+ok($thr->kill('STOP'), 'Suspended thread');
+
+threads->yield();
+sleep(1);
+
+# Allow the thread to continue
+$sema->up();
+
+threads->yield();
+sleep(1);
+
+# Terminate the thread
+ok($thr->kill('TERM'), 'Signalled thread to terminate');
+
+$rc = $thr->join();
+ok($rc eq 'OKAY', 'Thread return value');
+
+# EOF
use strict;
use warnings;
-our $VERSION = '1.26';
+our $VERSION = '1.27';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads version 1.26
+This document describes threads version 1.27
=head1 SYNOPSIS
$stack_size = threads->get_stack_size();
$old_size = threads->set_stack_size(32*4096);
+ $thr->kill('SIGUSR1');
+
=head1 DESCRIPTION
Perl 5.6 introduced something called interpreter threads. Interpreter threads
=back
+=head1 THREAD SIGNALLING
+
+If Perl has been compiled to use safe signals (i.e., was not built with
+C<PERL_OLD_SIGNALS> - see C<perl -V>), then signals may be sent and acted upon
+by individual threads.
+
+=over 4
+
+=item $thr->kill('SIG...');
+
+Sends the specified signal to the thread. Signal names and (positive) signal
+numbers are the same as those supported by
+L<kill()|perlfunc/"kill SIGNAL, LIST">. For example, 'SIGTERM', 'TERM' and
+(depending on the OS) 15 are all valid arguments to C<-E<gt>kill()>.
+
+Returns the thread object to allow for method chaining:
+
+ $thr->kill('SIG...')->join();
+
+=back
+
+Signal handlers need to be set up in the threads for the signals they are
+expected to act upon. Here's an example for I<cancelling> a thread:
+
+ use threads;
+
+ # Suppress warning message when thread is 'killed'
+ no warnings 'threads';
+
+ sub thr_func
+ {
+ # Thread 'cancellation' signal handler
+ $SIG{'KILL'} = sub { die("Thread killed\n"); };
+
+ ...
+ }
+
+ # Create a thread
+ my $thr = threads->create('thr_func');
+
+ ...
+
+ # Signal the thread to terminate, and then detach
+ # it so that it will get cleaned up automatically
+ $thr->kill('KILL')->detach();
+
+Here's another example that uses a semaphore to provide I<suspend> and
+I<resume> capabilities:
+
+ use threads;
+ use Thread::Semaphore;
+
+ sub thr_func
+ {
+ my $sema = shift;
+
+ # Thread 'suspend/resume' signal handler
+ $SIG{'STOP'} = sub {
+ $sema->down(); # Thread suspended
+ $sema->up(); # Thread resumes
+ };
+
+ ...
+ }
+
+ # Create a semaphore and send it to a thread
+ my $sema = Thread::Semaphore->new();
+ my $thr = threads->create('thr_func', $sema);
+
+ # Suspend the thread
+ $sema->down();
+ $thr->kill('STOP');
+
+ ...
+
+ # Allow the thread to continue
+ $sema->up();
+
+CAVEAT: Sending a signal to a thread does not disrupt the operation the
+thread is currently working on: The signal will be acted upon after the
+current operation has completed. For instance, if the thread is I<stuck> on
+an I/O call, sending it a signal will not cause the I/O call to be interrupted
+such that the signal is acted up immediately.
+
=head1 WARNINGS
=over 4
of the created threads by joining them, and only then exit from the main
thread.
+=item Thread creation failed: pthread_create returned #
+
+See the appropriate I<man> page for C<pthread_create> to determine the actual
+cause for the failure.
+
+=item Thread # terminated abnormally: ...
+
+A thread terminated in some manner other than just returning from its entry
+point function. For example, the thread may have exited via C<die>.
+
=item Using minimum thread stack size of #
Some platforms have a minimum thread stack size. Trying to set the stack size
below this value will result in the above warning, and the stack size will be
set to the minimum.
+=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+
+The specified I<SIZE> exceeds the system's maximum stack size. Use a smaller
+value for the stack size.
+
=back
+If needed, thread warnings can be suppressed by using:
+
+ no warnings 'threads';
+
+in the appropriate scope.
+
=head1 ERRORS
=over 4
$thr->set_stack_size($size);
-=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+=item Cannot signal other threads without safe signals
-The specified I<SIZE> exceeds the system's maximum stack size. Use a smaller
-value for the stack size.
+The particular copy of Perl that you're trying to use was built using
+C<PERL_OLD_SIGNALS>. As a result, the C<-E<gt>kill()> signalling method
+cannot be used.
+
+=item Unrecognized signal name: ...
+
+The particular copy of Perl that you're trying to use does not support the
+specified signal being used in a C<-E<gt>kill()> call.
=back
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.26/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.27/shared.pm>
L<threads::shared>, L<perlthrtut>
/* Check for failure */
if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
- Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
+ Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
}
FREETMPS;
void
+ithread_kill(...)
+ PREINIT:
+ ithread *thread;
+ char *sig_name;
+ IV signal;
+ CODE:
+ /* Must have safe signals */
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ Perl_croak(aTHX_ "Cannot signal other threads without safe signals");
+
+ /* Object method only */
+ if (! sv_isobject(ST(0)))
+ Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
+
+ /* Get thread */
+ thread = SV_to_ithread(aTHX_ ST(0));
+
+ /* Get signal */
+ sig_name = SvPV_nolen(ST(1));
+ if (isALPHA(*sig_name)) {
+ if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G')
+ sig_name += 3;
+ if ((signal = Perl_whichsig(aTHX_ sig_name)) < 0)
+ Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
+ } else
+ signal = SvIV(ST(1));
+
+ /* Set the signal for the thread */
+ {
+ dTHXa(thread->interp);
+ PL_psig_pend[signal]++;
+ PL_sig_pending = 1;
+ }
+
+ /* Return the thread to allow for method chaining */
+ ST(0) = ST(0);
+ /* XSRETURN(1); - implied */
+
+
+void
ithread_DESTROY(...)
CODE:
sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
projects / p5sagit/p5-mst-13.2.git / commitdiff