Join support, however something wierd seems to happen with filehandles that are passed along threads...

p4raw-id: //depot/perl@14659

2 files changed, 122 insertions, 4 deletions

diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t
new file mode 100644
index 0000000000..f2c88d524b
--- /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 db4ce24a16..0ba81dbd12 100755
--- 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);