This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads 1.54 - Adds ->error() method
authorJerry D. Hedden <jdhedden@cpan.org>
Thu, 14 Dec 2006 11:17:47 +0000 (03:17 -0800)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Fri, 15 Dec 2006 10:14:16 +0000 (10:14 +0000)
From: "Jerry D. Hedden" <jdhedden@yahoo.com>
Message-ID: <20061214191748.98286.qmail@web30209.mail.mud.yahoo.com>

p4raw-id: //depot/perl@29557

MANIFEST
ext/threads/Changes
ext/threads/README
ext/threads/t/err.t [new file with mode: 0644]
ext/threads/t/exit.t
ext/threads/t/libc.t
ext/threads/t/thread.t
ext/threads/threads.pm
ext/threads/threads.xs

index cd23a03..390e026 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1136,6 +1136,7 @@ ext/threads/t/basic.t             ithreads
 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
index 9e70741..698f337 100755 (executable)
@@ -1,5 +1,8 @@
 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
index 9fa2903..3803a26 100755 (executable)
@@ -1,4 +1,4 @@
-threads version 1.53
+threads version 1.54
 ====================
 
 This module exposes interpreter threads to the Perl level.
diff --git a/ext/threads/t/err.t b/ext/threads/t/err.t
new file mode 100644 (file)
index 0000000..a0df7a5
--- /dev/null
@@ -0,0 +1,70 @@
+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
index 95a7610..25fba99 100644 (file)
@@ -56,7 +56,7 @@ my $rc = $thr->join();
 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,
@@ -104,7 +104,7 @@ $rc = $thr->join();
 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,
@@ -112,7 +112,7 @@ run_perl(prog => 'use threads 1.53 qw(exit thread_only);' .
 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();' .
@@ -124,7 +124,7 @@ is($?>>8, 99, "exit(status) in thread");
 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);' .
@@ -137,7 +137,7 @@ is($?>>8, 99, "set_thread_exit_only(0)");
 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();' .
index af6cc32..740588a 100644 (file)
@@ -6,37 +6,20 @@ BEGIN {
         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 ###
 
@@ -44,30 +27,28 @@ my $i = 10;
 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
index 67882bd..cf3a232 100644 (file)
@@ -171,7 +171,7 @@ package main;
 
 # 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,
index ce74727..a718dcf 100755 (executable)
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '1.53';
+our $VERSION = '1.54';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -133,7 +133,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 1.53
+This document describes threads version 1.54
 
 =head1 SYNOPSIS
 
@@ -153,6 +153,9 @@ This document describes threads version 1.53
 
     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/); });
@@ -398,6 +401,12 @@ it.  This block is treated as an anonymous subroutine, and so must have a
 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
@@ -781,7 +790,8 @@ 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 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 #
 
@@ -858,10 +868,10 @@ C<import> if needed):
         ....
     }
 
-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.
@@ -918,6 +928,10 @@ Perl version and the application code, results may range from success, to
 (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.,
@@ -938,7 +952,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.53/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.54/threads.pm>
 
 L<threads::shared>, L<perlthrtut>
 
index 65588b4..cc4e7c9 100755 (executable)
@@ -51,6 +51,7 @@ typedef perl_os_thread pthread_t;
 #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 */
@@ -70,6 +71,8 @@ typedef struct _ithread {
     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;
 
 
@@ -149,6 +152,11 @@ S_ithread_clear(pTHX_ ithread *thread)
         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;
@@ -381,8 +389,9 @@ S_ithread_run(void * arg)
     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;
 
@@ -442,22 +451,34 @@ S_ithread_run(void * arg)
         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 */
@@ -470,7 +491,7 @@ S_ithread_run(void * arg)
     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;
@@ -1056,6 +1077,7 @@ ithread_join(...)
         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;
@@ -1081,8 +1103,10 @@ ithread_join(...)
             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);
@@ -1091,6 +1115,9 @@ ithread_join(...)
         }
         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;
@@ -1142,7 +1169,6 @@ ithread_detach(...)
 #else
         PERL_THREAD_DETACH(thread->thr);
 #endif
-
         if (thread->state & PERL_ITHR_FINISHED) {
             MY_POOL.joinable_threads--;
         } else {
@@ -1152,6 +1178,16 @@ ithread_detach(...)
         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);
 
@@ -1405,6 +1441,59 @@ ithread_set_thread_exit_only(...)
         }
         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 */