Join support, however something wierd seems to happen with filehandles that are passe...

p4raw-id: //depot/perl@14659

diff --git a/MANIFEST b/MANIFEST
index a793e26..eac56da 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -633,6 +633,7 @@ ext/threads/shared/t/sv_simple.t    thread shared variables
 ext/threads/shared/typemap     thread::shared types
 ext/threads/t/basic.t          ithreads
 ext/threads/t/libc.t            testing libc functions for threadsafetyness
+ext/threads/t/join.t           Testing the join function
 ext/threads/t/stress_cv.t      Test with multiple threads, coderef cv argument.
 ext/threads/t/stress_re.t      Test with multiple threads, string cv argument and regexes.
 ext/threads/t/stress_string.t  Test with multiple threads, string cv argument.

diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t
new file mode 100644 (file)
index 0000000..f2c88d5
--- /dev/null
+++ b/ext/threads/t/join.t
@@ -0,0 +1,89 @@
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+    unless ($Config{'useithreads'}) {
+        print "1..0 # Skip: no useithreads\n";
+        exit 0;
+    }
+}
+
+use ExtUtils::testlib;
+use strict;
+BEGIN { print "1..10\n" };
+use threads;
+use threads::shared;
+
+my $test_id = 1;
+share($test_id);
+use Devel::Peek qw(Dump);
+
+sub ok {
+    my ($ok, $name) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
+
+    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
+    $test_id++;
+    return $ok;
+}
+
+ok(1,"");
+
+
+{
+    my $retval = threads->create(sub { return ("hi") })->join();
+    ok($retval eq 'hi', "Check basic returnvalue");
+}
+{
+    my ($thread) = threads->create(sub { return (1,2,3) });
+    my @retval = $thread->join();
+    ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3);
+}
+{
+    my $retval = threads->create(sub { return [1] })->join();
+    ok($retval->[0] == 1,"Check that a array ref works");
+}
+{
+    my $retval = threads->create(sub { return { foo => "bar" }})->join();
+    ok($retval->{foo} eq 'bar',"Check that hash refs work");
+}
+{
+    my $retval = threads->create( sub {
+       open(my $fh, "+>threadtest") || die $!;
+       print $fh "test\n";
+       return $fh;
+    })->join();
+    ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
+    print $retval "test2\n";
+#    seek($retval,0,0);
+#    ok(<$retval> eq "test\n");
+    close($retval);
+    unlink("threadtest");
+}
+{
+    my $test = "hi";
+    my $retval = threads->create(sub { return $_[0]}, \$test)->join();
+    ok($$retval eq 'hi');
+}
+{
+    my $test = "hi";
+    share($test);
+    my $retval = threads->create(sub { return $_[0]}, \$test)->join();
+    ok($$retval eq 'hi');
+    $test = "foo";
+    ok($$retval eq 'foo');
+}
+{
+    my %foo;
+    share(%foo);
+    threads->create(sub { 
+       my $foo;
+       share($foo);
+       $foo = "thread1";
+       return $foo{bar} = \$foo;
+    })->join();
+    ok(1,"");
+}

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index db4ce24..0ba81db 100755 (executable)
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -206,8 +206,8 @@ Perl_ithread_run(void * arg) {
                len = call_sv(thread->init_function, thread->gimme|G_EVAL);
                SPAGAIN;
                for (i=len-1; i >= 0; i--) {
-                   SV *sv = POPs;
-                   av_store(params, i, SvREFCNT_inc(sv));
+                 SV *sv = POPs;
+                 av_store(params, i, SvREFCNT_inc(sv));
                }
                PUTBACK;
                if (SvTRUE(ERRSV)) {
@@ -376,7 +376,7 @@ Perl_ithread_self (pTHX_ SV *obj, char* Class)
 }
 
 /*
- * joins the thread this code needs to take the returnvalue from the
+ * Joins the thread this code needs to take the returnvalue from the
  * call_sv and send it back
  */
 
@@ -393,7 +393,7 @@ Perl_ithread_CLONE(pTHX_ SV *obj)
   }
 }
 
-void
+AV* 
 Perl_ithread_join(pTHX_ SV *obj)
 {
     ithread *thread = SV_to_ithread(aTHX_ obj);
@@ -407,6 +407,7 @@ Perl_ithread_join(pTHX_ SV *obj)
        Perl_croak(aTHX_ "Thread already joined");
     }
     else {
+        AV* retparam;
 #ifdef WIN32
        DWORD waitcode;
 #else
@@ -419,12 +420,26 @@ Perl_ithread_join(pTHX_ SV *obj)
        pthread_join(thread->thr,&retval);
 #endif
        MUTEX_LOCK(&thread->mutex);
+       
+       {
+         AV* params = (AV*) SvRV(thread->params);        
+         CLONE_PARAMS clone_params;
+         PL_ptr_table = ptr_table_new();
+         retparam = (AV*) sv_dup((SV*)params, &clone_params);
+         SvREFCNT_inc(retparam);
+         ptr_table_free(PL_ptr_table);
+         PL_ptr_table = NULL;
+
+       }
        /* sv_dup over the args */
        /* We have finished with it */
        thread->detached |= 2;
        MUTEX_UNLOCK(&thread->mutex);
        sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
+       Perl_ithread_destruct(aTHX_ thread);
+       return retparam;
     }
+    return (AV*)NULL;
 }
 
 void
@@ -451,6 +466,8 @@ Perl_ithread_DESTROY(pTHX_ SV *sv)
     sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
 }
 
+
+
 MODULE = threads               PACKAGE = threads       PREFIX = ithread_
 PROTOTYPES: DISABLE
 
@@ -484,6 +501,17 @@ ithread_tid(ithread *thread)
 
 void
 ithread_join(SV *obj)
+PPCODE:
+{
+  AV* params = Perl_ithread_join(aTHX_ obj);
+  int i;
+  I32 len = AvFILL(params);
+  for (i = 0; i <= len; i++) {
+    XPUSHs(av_shift(params));
+  }
+  SvREFCNT_dec(params);
+}
+
 
 void
 ithread_detach(ithread *thread)
@@ -494,6 +522,7 @@ ithread_DESTROY(SV *thread)
 BOOT:
 {
        ithread* thread;
+       PL_perl_destruct_level = 2;
        PERL_THREAD_ALLOC_SPECIFIC(self_key);
        MUTEX_INIT(&create_mutex);
        MUTEX_LOCK(&create_mutex);