+use strict;
+use warnings;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- unless ($Config{'useithreads'}) {
- print "1..0 # Skip: no useithreads\n";
- exit 0;
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+ use Config;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
}
+
+ require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
}
use ExtUtils::testlib;
-use strict;
-BEGIN { $| = 1; print "1..22\n" };
+
use threads;
-use threads::shared;
-print "ok 1\n";
+BEGIN {
+ eval {
+ require threads::shared;
+ import threads::shared;
+ };
+ if ($@ || ! $threads::shared::threads_shared) {
+ print("1..0 # Skip: threads::shared not available\n");
+ exit(0);
+ }
+
+ $| = 1;
+ print("1..31\n"); ### Number of tests that will be run ###
+};
+
+print("ok 1 - Loaded\n");
+
+### Start of Testing ###
sub content {
print shift;
return shift;
}
{
- my $t = threads->new(\&content, "ok 2\n", "ok 3\n", 1..1000);
+ my $t = threads->create(\&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";
+ lock($lock);
+ $t = threads->create(sub { lock($lock); print "ok 5\n"});
+ print "ok 4\n";
}
$t->join();
}
my $ret;
print $val;
if(@_) {
- $ret = threads->new(\&dorecurse, @_);
- $ret->join;
+ $ret = threads->create(\&dorecurse, @_);
+ $ret->join;
}
}
{
- my $t = threads->new(\&dorecurse, map { "ok $_\n" } 6..10);
+ my $t = threads->create(\&dorecurse, map { "ok $_\n" } 6..10);
$t->join();
}
{
# test that sleep lets other thread run
- my $t = threads->new(\&dorecurse, "ok 11\n");
+ my $t = threads->create(\&dorecurse, "ok 11\n");
+ threads->yield; # help out non-preemptive thread implementations
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;
+ lock($lock);
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_) {
+ $ret = threads->create(\&islocked, shift);
+ }
+ return $ret;
}
-my $t = threads->new(\&islocked, "ok 13\n", "ok 14\n");
+my $t = threads->create(\&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";
- }
+ return $testno eq $same;
}
sub threaded {
- my ($string, $string_end, $testno) = @_;
+ my ($string, $string_end) = @_;
# 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";
- }
+ return $3 eq $string_end;
}
{
- my $thr1 = threads->new(\&testsprintf, 15);
- my $thr2 = threads->new(\&testsprintf, 16);
+ curr_test(15);
+
+ my $thr1 = threads->create(\&testsprintf, 15);
+ my $thr2 = threads->create(\&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 $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";
+ my $thr3 = new threads \&threaded, $short, $shorte;
+ my $thr4 = new threads \&threaded, $long, $longe;
+ my $thr5 = new threads \&testsprintf, 19;
+ my $thr6 = new threads \&testsprintf, 20;
+ my $thr7 = new threads \&threaded, $foo, $fooe;
-
+ ok($thr1->join());
+ ok($thr2->join());
+ ok($thr3->join());
+ ok($thr4->join());
+ ok($thr5->join());
+ ok($thr6->join());
+ ok($thr7->join());
+}
+
+# test that 'yield' is importable
+
+package Test1;
+
+use threads 'yield';
+yield;
+main::ok(1);
+
+package main;
- $thr1->join();
- $thr2->join();
- $thr3->join();
- $thr4->join();
- $thr5->join();
- $thr6->join();
- $thr7->join();
- print "ok 22\n";
+
+# test async
+
+{
+ my $th = async {return 1 };
+ ok($th);
+ ok($th->join());
}
+{
+ # There is a miniscule chance this test case may falsely fail
+ # since it tests using rand()
+ my %rand : shared;
+ rand(10);
+ threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25;
+ $_->join foreach threads->list;
+ ok((keys %rand >= 23), "Check that rand() is randomized in new threads");
+}
+
+# bugid #24165
+run_perl(prog => 'use threads 1.58;' .
+ 'sub a{threads->create(shift)} $t = a sub{};' .
+ '$t->tid; $t->join; $t->tid',
+ nolib => ($ENV{PERL_CORE}) ? 0 : 1,
+ switches => ($ENV{PERL_CORE}) ? [] : [ '-Mblib' ]);
+is($?, 0, 'coredump in global destruction');
+
+# test CLONE_SKIP() functionality
+if ($] >= 5.008007) {
+ my %c : shared;
+ my %d : shared;
+
+ # ---
+
+ package A;
+ sub CLONE_SKIP { $c{"A-$_[0]"}++; 1; }
+ sub DESTROY { $d{"A-". ref $_[0]}++ }
+
+ package A1;
+ our @ISA = qw(A);
+ sub CLONE_SKIP { $c{"A1-$_[0]"}++; 1; }
+ sub DESTROY { $d{"A1-". ref $_[0]}++ }
+
+ package A2;
+ our @ISA = qw(A1);
+
+ # ---
+
+ package B;
+ sub CLONE_SKIP { $c{"B-$_[0]"}++; 0; }
+ sub DESTROY { $d{"B-" . ref $_[0]}++ }
+
+ package B1;
+ our @ISA = qw(B);
+ sub CLONE_SKIP { $c{"B1-$_[0]"}++; 1; }
+ sub DESTROY { $d{"B1-" . ref $_[0]}++ }
+
+ package B2;
+ our @ISA = qw(B1);
+
+ # ---
+
+ package C;
+ sub CLONE_SKIP { $c{"C-$_[0]"}++; 1; }
+ sub DESTROY { $d{"C-" . ref $_[0]}++ }
+
+ package C1;
+ our @ISA = qw(C);
+ sub CLONE_SKIP { $c{"C1-$_[0]"}++; 0; }
+ sub DESTROY { $d{"C1-" . ref $_[0]}++ }
+
+ package C2;
+ our @ISA = qw(C1);
+
+ # ---
+
+ package D;
+ sub DESTROY { $d{"D-" . ref $_[0]}++ }
+
+ package D1;
+ our @ISA = qw(D);
+
+ package main;
+
+ {
+ my @objs;
+ for my $class (qw(A A1 A2 B B1 B2 C C1 C2 D D1)) {
+ push @objs, bless [], $class;
+ }
+
+ sub f {
+ my $depth = shift;
+ my $cloned = ""; # XXX due to recursion, doesn't get initialized
+ $cloned .= "$_" =~ /ARRAY/ ? '1' : '0' for @objs;
+ is($cloned, ($depth ? '00010001111' : '11111111111'),
+ "objs clone skip at depth $depth");
+ threads->create( \&f, $depth+1)->join if $depth < 2;
+ @objs = ();
+ }
+ f(0);
+ }
+
+ curr_test(curr_test()+2);
+ ok(eq_hash(\%c,
+ {
+ qw(
+ A-A 2
+ A1-A1 2
+ A1-A2 2
+ B-B 2
+ B1-B1 2
+ B1-B2 2
+ C-C 2
+ C1-C1 2
+ C1-C2 2
+ )
+ }),
+ "counts of calls to CLONE_SKIP");
+ ok(eq_hash(\%d,
+ {
+ qw(
+ A-A 1
+ A1-A1 1
+ A1-A2 1
+ B-B 3
+ B1-B1 1
+ B1-B2 1
+ C-C 1
+ C1-C1 3
+ C1-C2 3
+ D-D 3
+ D-D1 3
+ )
+ }),
+ "counts of calls to DESTROY");
+
+} else {
+ print("ok 27 # Skip objs clone skip at depth 0\n");
+ print("ok 28 # Skip objs clone skip at depth 1\n");
+ print("ok 29 # Skip objs clone skip at depth 2\n");
+ print("ok 30 # Skip counts of calls to CLONE_SKIP\n");
+ print("ok 31 # Skip counts of calls to DESTROY\n");
+}
+# EOF
projects / p5sagit/p5-mst-13.2.git / blobdiff