From: Artur Bergman <sky@nanisky.com>
Date: Thu, 18 Apr 2002 09:18:14 +0000 (+0000)
Subject: Port testcases from thr5005 tests so we don't fail on same things.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f9dff5f55ec825f87c6c90807ed1007e15860d92;p=p5sagit%2Fp5-mst-13.2.git

Port testcases from thr5005 tests so we don't fail on same things.
Added yield support using threads->yield().

p4raw-id: //depot/perl@15991
---

diff --git a/MANIFEST b/MANIFEST
index 148317f..7c58789 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -660,6 +660,7 @@ ext/threads/t/libc.t            testing libc functions for threadsafetyness
 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.
+ext/threads/t/thread.t		General ithread tests from thr5005
 ext/threads/threads.pm          ithreads
 ext/threads/threads.xs		ithreads
 ext/threads/typemap		ithreads
diff --git a/ext/threads/t/thread.t b/ext/threads/t/thread.t
new file mode 100644
index 0000000..bb374ee
--- /dev/null
+++ b/ext/threads/t/thread.t
@@ -0,0 +1,139 @@
+
+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 { $| = 1; print "1..22\n" };
+use threads;
+use threads::shared;
+
+print "ok 1\n";
+
+sub content {
+    print shift;
+    return shift;
+}
+{
+    my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000);
+    print $t->join();
+}
+{
+    my $lock : shared;
+    my $t;
+    {
+	lock($lock);
+	$t = threads->new(sub { lock($lock); print "ok 5\n"});
+	print "ok 4\n";
+    }
+    $t->join();
+}
+
+sub dorecurse {
+    my $val = shift;
+    my $ret;
+    print $val;
+    if(@_) {
+	$ret = threads->new(\&dorecurse, @_);
+	$ret->join;
+    }
+}
+{
+    my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10);
+    $t->join();
+}
+
+{
+    # test that sleep lets other thread run
+    my $t = threads->new(\&dorecurse, "ok 11\n");
+    sleep 1;
+    print "ok 12\n";
+    $t->join();
+}
+{
+    my $lock : shared;
+    sub islocked {
+	lock($lock);
+	my $val = shift;
+	my $ret;
+	print $val;
+	if (@_) {
+	    $ret = threads->new(\&islocked, shift);
+	}
+	return $ret;
+    }
+my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n");
+$t->join->join;
+}
+
+
+
+sub testsprintf {
+    my $testno = shift;
+    my $same = sprintf( "%0.f", $testno);
+    if($testno eq $same) {
+	print "ok $testno\n";
+    } else {
+	print "not ok $testno\t# '$testno' ne '$same'\n";
+    }
+}
+
+sub threaded {
+    my ($string, $string_end, $testno) = @_;
+
+  # Do the match, saving the output in appropriate variables
+    $string =~ /(.*)(is)(.*)/;
+  # Yield control, allowing the other thread to fill in the match variables
+    threads->yield();
+  # Examine the match variable contents; on broken perls this fails
+    if ($3 eq $string_end) {
+	print "ok $testno\n";
+    }
+    else {
+	warn <<EOT;
+#
+# This is a 5005thread failure that should be gone in ithreads
+# $3 - $string_end
+
+EOT
+   print "not ok $testno # other thread filled in match variables\n";
+   }
+}
+
+
+{ 
+    my $thr1 = threads->new(\&testsprintf, 15);
+    my $thr2 = threads->new(\&testsprintf, 16);
+    
+    my $short = "This is a long string that goes on and on.";
+    my $shorte = " a long string that goes on and on.";
+    my $long  = "This is short.";
+    my $longe  = " short.";
+    my $foo = "This is bar bar bar.";
+    my $fooe = " bar bar bar.";
+    my $thr3 = new threads \&threaded, $short, $shorte, "17";
+    my $thr4 = new threads \&threaded, $long, $longe, "18";
+    my $thr5 = new threads \&testsprintf, "19";
+    my $thr6 = threads->new(\&testsprintf, 20);
+    my $thr7 = new threads \&threaded, $foo, $fooe, "21";
+
+    
+
+    $thr1->join();
+    $thr2->join();
+    $thr3->join();
+    $thr4->join();
+    $thr5->join();
+    $thr6->join();
+    $thr7->join();
+    print "ok 22\n";
+}
+
+
diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm
index 11878eb..c6f7875 100755
--- a/ext/threads/threads.pm
+++ b/ext/threads/threads.pm
@@ -99,6 +99,8 @@ threads->self->tid();
 
 $thread->tid();
 
+threads->yield();
+
 =head1 DESCRIPTION
 
 Perl 5.6 introduced something called interpreter threads.  Interpreter
@@ -149,6 +151,11 @@ This will return the object for the current thread.
 This will return the id of the thread.  threads->self->tid() is a
 quick way to get current thread id.
 
+=item threads->yield();
+
+This will tell the OS to let this thread yield CPU time to other threads.
+However this is highly depending on the underlying thread implmentation.
+
 =back
 
 =head1 WARNINGS
diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index db76082..acba4cc 100755
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -76,6 +76,7 @@ ithread *threads;
 #define ithread_CLONE(thread)		Perl_ithread_CLONE(aTHX_ thread)
 #define ithread_detach(thread)		Perl_ithread_detach(aTHX_ thread)
 #define ithread_tid(thread)		((thread)->tid)
+#define ithread_yield(thread)		(YIELD);
 
 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
 
@@ -566,6 +567,8 @@ PPCODE:
   SvREFCNT_dec(params);
 }
 
+void
+ithread_yield(ithread *thread)
 
 void
 ithread_detach(ithread *thread)