4 require Config; import Config;
5 unless ($Config{'useithreads'}) {
6 print "1..0 # Skip: no useithreads\n";
9 if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
10 print "1..0 # Skip: Devel::Peek was not built\n";
15 use ExtUtils::testlib;
17 BEGIN { print "1..14\n" };
23 use Devel::Peek qw(Dump);
28 # You have to do it this way or VMS will get confused.
29 print $ok ? "ok $test_id - $name\n" : "not ok $test_id - $name\n";
31 printf "# Failed test at line %d\n", (caller)[2] unless $ok;
37 ok(1, "# Skipped: @_");
44 my $retval = threads->create(sub { return ("hi") })->join();
45 ok($retval eq 'hi', "Check basic returnvalue");
48 my ($thread) = threads->create(sub { return (1,2,3) });
49 my @retval = $thread->join();
50 ok($retval[0] == 1 && $retval[1] == 2 && $retval[2] == 3,'');
53 my $retval = threads->create(sub { return [1] })->join();
54 ok($retval->[0] == 1,"Check that a array ref works",);
57 my $retval = threads->create(sub { return { foo => "bar" }})->join();
58 ok($retval->{foo} eq 'bar',"Check that hash refs work");
61 my $retval = threads->create( sub {
62 open(my $fh, "+>threadtest") || die $!;
66 ok(ref($retval) eq 'GLOB', "Check that we can return FH $retval");
67 print $retval "test2\n";
69 # ok(<$retval> eq "test\n");
75 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
76 ok($$retval eq 'hi','');
81 my $retval = threads->create(sub { return $_[0]}, \$test)->join();
82 ok($$retval eq 'hi','');
84 ok($$retval eq 'foo','');
93 return $foo{bar} = \$foo;
98 # We parse ps output so this is OS-dependent.
100 # First modify $0 in a subthread.
101 print "# mainthread: \$0 = $0\n";
103 print "# subthread: \$0 = $0\n";
105 print "# subthread: \$0 = $0\n" } )->join;
106 print "# mainthread: \$0 = $0\n";
107 print "# pid = $$\n";
108 if (open PS, "ps -f |") { # Note: must work in (all) systems.
109 my ($sawpid, $sawexe);
115 if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
123 ok($sawpid && $sawexe, 'altering $0 is effective');
125 skip("\$0 check: did not see pid $$ in 'ps -f |'");
128 skip("\$0 check: opening 'ps -f |' failed: $!");
131 skip("\$0 check: only on Linux");
135 my $t = threads->new(sub {});
137 my $x = threads->new(sub {});
143 $ok++ if($@ =~/Thread already joined/);
144 ok($ok, "Double join works");
148 # The "use IO::File" is not actually used for anything; its only
149 # purpose is to incite a lot of calls to newCONSTSUB. See the p5p
150 # archives for the thread "maint@20974 or before broke mp2 ithreads test".
152 $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;