ext/threads/t/blocks.t Test threads in special blocks
ext/threads/t/context.t Explicit thread context
ext/threads/t/end.t Test end functions
+ext/threads/t/err.t Test $thr->error()
ext/threads/t/exit.t Test exit and die in threads
ext/threads/t/free2.t More ithread destruction tests
ext/threads/t/free.t Test ithread destruction
Revision history for Perl extension threads.
+1.54 Thu Dec 14 14:12:30 EST 2006
+ - Added ->error() method
+
1.53 Mon Nov 27 12:08:27 EST 2006
- Fix for a thread cloning bug
- Fixes to test suite
-threads version 1.53
+threads version 1.54
====================
This module exposes interpreter threads to the Perl level.
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+
+ require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
+
+ use Config;
+ if (! $Config{'useithreads'}) {
+ skip_all(q/Perl not compiled with 'useithreads'/);
+ }
+
+ plan(10);
+}
+
+use ExtUtils::testlib;
+
+use_ok('threads');
+
+### Start of Testing ###
+
+no warnings 'threads';
+
+# Create a thread that generates an error
+my $thr = threads->create(sub { my $x = 5/0; });
+
+# Check that thread returns 'undef'
+my $result = $thr->join();
+ok(! defined($result), 'thread died');
+
+# Check error
+like($thr->error(), 'division by zero', 'thread error');
+
+
+# Create a thread that 'die's with an object
+$thr = threads->create(sub {
+ threads->yield();
+ sleep(1);
+ die(bless({ error => 'bogus' }, 'Err::Class'));
+ });
+
+my $err = $thr->error();
+ok(! defined($err), 'no error yet');
+
+# Check that thread returns 'undef'
+$result = $thr->join();
+ok(! defined($result), 'thread died');
+
+# Check that error object is retrieved
+$err = $thr->error();
+isa_ok($err, 'Err::Class', 'error object');
+is($err->{error}, 'bogus', 'error field');
+
+# Check that another thread can reference the error object
+my $thrx = threads->create(sub { die(bless($thr->error(), 'Foo')); });
+
+# Check that thread returns 'undef'
+$result = $thrx->join();
+ok(! defined($result), 'thread died');
+
+# Check that the rethrown error object is retrieved
+$err = $thrx->error();
+isa_ok($err, 'Foo', 'error object');
+is($err->{error}, 'bogus', 'error field');
+
+# EOF
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.53;' .
+run_perl(prog => 'use threads 1.54;' .
'threads->exit(86);' .
'exit(99);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
-run_perl(prog => 'use threads 1.53 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.54 qw(exit thread_only);' .
'threads->create(sub { exit(99); })->join();' .
'exit(86);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
-my $out = run_perl(prog => 'use threads 1.53;' .
+my $out = run_perl(prog => 'use threads 1.54;' .
'threads->create(sub {' .
' exit(99);' .
'})->join();' .
like($out, '1 finished and unjoined', "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.53 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.54 qw(exit thread_only);' .
'threads->create(sub {' .
' threads->set_thread_exit_only(0);' .
' exit(99);' .
like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.53;' .
+run_perl(prog => 'use threads 1.54;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
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;
-sub ok {
- my ($id, $ok, $name) = @_;
+ require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
- # 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]);
+ use Config;
+ if (! $Config{'useithreads'}) {
+ skip_all(q/Perl not compiled with 'useithreads'/);
}
- return ($ok);
+ plan(11);
}
-use threads;
-
-BEGIN {
- $| = 1;
- print("1..12\n"); ### Number of tests that will be run ###
-};
+use ExtUtils::testlib;
-ok(1, 1, 'Loaded');
+use_ok('threads');
### Start of Testing ###
my $y = 20000;
my %localtime;
-for (0..$i) {
+for (1..$i) {
$localtime{$_} = localtime($_);
};
my @threads;
-for (0..$i) {
- my $thread = threads->create(sub {
- my $arg = $_;
- my $localtime = $localtime{$arg};
- my $error = 0;
- for (0..$y) {
- my $lt = localtime($arg);
- if ($localtime ne $lt) {
- $error++;
+for (1..$i) {
+ $threads[$_] = threads->create(sub {
+ my $arg = shift;
+ my $localtime = $localtime{$arg};
+ my $error = 0;
+ for (1..$y) {
+ my $lt = localtime($arg);
+ if ($localtime ne $lt) {
+ $error++;
+ }
}
- }
- return $error;
- });
- push @threads, $thread;
+ return $error;
+ }, $_);
}
-for (0..$i) {
- my $result = $threads[$_]->join();
- ok($_ + 2, defined($result) && ("$result" eq '0'), 'localtime safe');
+for (1..$i) {
+ is($threads[$_]->join(), 0, 'localtime() thread-safe');
}
# EOF
# bugid #24165
-run_perl(prog => 'use threads 1.53;' .
+run_perl(prog => 'use threads 1.54;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
use strict;
use warnings;
-our $VERSION = '1.53';
+our $VERSION = '1.54';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads version 1.53
+This document describes threads version 1.54
=head1 SYNOPSIS
my $thr2 = async { foreach (@files) { ... } };
$thr2->join();
+ if (my $err = $thr2->error()) {
+ warn("Thread error: $err\n");
+ }
# Invoke thread in list context (implicit) so it can return a list
my ($thr) = threads->create(sub { return (qw/a b c/); });
semi-colon after the closing brace. Like C<threads->create()>, C<async>
returns a I<threads> object.
+=item $thr->error()
+
+Threads are executed in an C<eval> context. This method will return C<undef>
+if the thread terminates I<normally>. Otherwise, it returns the value of
+C<$@> associated with the thread's execution status in its C<eval> context.
+
=item $thr->_handle()
This I<private> method returns the memory location of the internal thread
=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 terminated using C<die>.
+point function, or by using C<threads-E<gt>exit()>. For example, the thread
+may have terminated because of a error, or by using C<die>.
=item Using minimum thread stack size of #
....
}
-If the module will only be used inside the I<main> thread, try modifying your
-application so that the module is loaded (again using C<require> and C<import>)
-after any threads are started, and in such a way that no other threads are
-started afterwards.
+If the module is needed inside the I<main> thread, try modifying your
+application so that the module is loaded (again using C<require> and
+C<import>) after any threads are started, and in such a way that no other
+threads are started afterwards.
If the above does not work, or is not adequate for your application, then file
a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
(apparently harmless) warnings of leaked scalar, or all the way up to crashing
of the Perl interpreter.
+=item Returning objects from threads
+
+Returning objects from threads does not work.
+
=item Perl Bugs and the CPAN Version of L<threads>
Support for threads extents beyond the code in this module (i.e.,
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.53/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.54/threads.pm>
L<threads::shared>, L<perlthrtut>
#define PERL_ITHR_THREAD_EXIT_ONLY 8
#define PERL_ITHR_NONVIABLE 16
#define PERL_ITHR_DESTROYED 32
+#define PERL_ITHR_DIED 64
typedef struct _ithread {
struct _ithread *next; /* Next thread in the list */
pthread_t thr; /* OS's handle for the thread */
#endif
IV stack_size;
+ SV *err; /* Error from abnormally terminated thread */
+ char *err_class; /* Error object's classname if applicable */
} ithread;
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
+ if (thread->err) {
+ SvREFCNT_dec(thread->err);
+ thread->err = Nullsv;
+ }
+
perl_destruct(interp);
perl_free(interp);
thread->interp = NULL;
ithread *thread = (ithread *)arg;
int jmp_rc = 0;
I32 oldscope;
- int exit_app = 0;
+ int exit_app = 0; /* Thread terminated using 'exit' */
int exit_code = 0;
+ int died = 0; /* Thread terminated abnormally */
dJMPENV;
FREETMPS;
LEAVE;
- /* Check for failure */
- if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
- oldscope = PL_scopestack_ix;
- JMPENV_PUSH(jmp_rc);
- if (jmp_rc == 0) {
- /* Warn that thread died */
- Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
- } else if (jmp_rc == 2) {
- /* Warn handler exited */
- exit_app = 1;
- exit_code = STATUS_CURRENT;
- while (PL_scopestack_ix > oldscope) {
- LEAVE;
+ /* Check for abnormal termination */
+ if (SvTRUE(ERRSV)) {
+ died = PERL_ITHR_DIED;
+ thread->err = newSVsv(ERRSV);
+ /* If ERRSV is an object, remember the classname and then
+ * rebless into 'main' so it will survive 'cloning'
+ */
+ if (sv_isobject(thread->err)) {
+ thread->err_class = HvNAME(SvSTASH(SvRV(thread->err)));
+ sv_bless(thread->err, gv_stashpv("main", 0));
+ }
+
+ if (ckWARN_d(WARN_THREADS)) {
+ oldscope = PL_scopestack_ix;
+ JMPENV_PUSH(jmp_rc);
+ if (jmp_rc == 0) {
+ /* Warn that thread died */
+ Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
+ } else if (jmp_rc == 2) {
+ /* Warn handler exited */
+ exit_app = 1;
+ exit_code = STATUS_CURRENT;
+ while (PL_scopestack_ix > oldscope) {
+ LEAVE;
+ }
}
+ JMPENV_POP;
}
- JMPENV_POP;
}
/* Release function ref */
MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
MUTEX_LOCK(&thread->mutex);
/* Mark as finished */
- thread->state |= PERL_ITHR_FINISHED;
+ thread->state |= (PERL_ITHR_FINISHED | died);
/* Clear exit flag if required */
if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) {
exit_app = 0;
thread->state |= PERL_ITHR_JOINED;
/* Get the return value from the call_sv */
+ /* Objects do not survive this process - FIXME */
{
AV *params_copy;
PerlInterpreter *other_perl;
PL_ptr_table = NULL;
}
- /* We are finished with the thread */
- S_ithread_clear(aTHX_ thread);
+ /* If thread didn't die, then we can free its interpreter */
+ if (! (thread->state & PERL_ITHR_DIED)) {
+ S_ithread_clear(aTHX_ thread);
+ }
MUTEX_UNLOCK(&thread->mutex);
MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
}
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+ /* Try to cleanup thread */
+ S_ithread_destruct(aTHX_ thread);
+
/* If no return values, then just return */
if (! params) {
XSRETURN_UNDEF;
#else
PERL_THREAD_DETACH(thread->thr);
#endif
-
if (thread->state & PERL_ITHR_FINISHED) {
MY_POOL.joinable_threads--;
} else {
MUTEX_UNLOCK(&thread->mutex);
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+ /* If thread is finished and didn't die,
+ * then we can free its interpreter */
+ MUTEX_LOCK(&thread->mutex);
+ if ((thread->state & PERL_ITHR_FINISHED) &&
+ ! (thread->state & PERL_ITHR_DIED))
+ {
+ S_ithread_clear(aTHX_ thread);
+ }
+ MUTEX_UNLOCK(&thread->mutex);
+
/* Try to cleanup thread */
S_ithread_destruct(aTHX_ thread);
}
MUTEX_UNLOCK(&thread->mutex);
+
+void
+ithread_error(...)
+ PREINIT:
+ ithread *thread;
+ SV *err = NULL;
+ CODE:
+ /* Object method only */
+ if ((items != 1) || ! sv_isobject(ST(0))) {
+ Perl_croak(aTHX_ "Usage: $thr->err()");
+ }
+
+ thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
+ MUTEX_LOCK(&thread->mutex);
+
+ /* If thread died, then clone the error into the calling thread */
+ if (thread->state & PERL_ITHR_DIED) {
+ PerlInterpreter *other_perl;
+ CLONE_PARAMS clone_params;
+ ithread *current_thread;
+
+ other_perl = thread->interp;
+ clone_params.stashes = newAV();
+ clone_params.flags = CLONEf_JOIN_IN;
+ PL_ptr_table = ptr_table_new();
+ current_thread = S_ithread_get(aTHX);
+ S_ithread_set(aTHX_ thread);
+ /* Ensure 'meaningful' addresses retain their meaning */
+ ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+ ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+ ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
+ err = sv_dup(thread->err, &clone_params);
+ S_ithread_set(aTHX_ current_thread);
+ SvREFCNT_dec(clone_params.stashes);
+ SvREFCNT_inc_void(err);
+ /* If error was an object, bless it into the correct class */
+ if (thread->err_class) {
+ sv_bless(err, gv_stashpv(thread->err_class, 1));
+ }
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+ }
+
+ MUTEX_UNLOCK(&thread->mutex);
+
+ if (! err) {
+ XSRETURN_UNDEF;
+ }
+
+ ST(0) = sv_2mortal(err);
+ /* XSRETURN(1); - implied */
+
+
#endif /* USE_ITHREADS */
projects / platform / upstream / perl.git / commitdiff