-#!./perl
+#!perl
+
BEGIN {
chdir 't' if -d 't';
- unshift @INC, '../lib';
- require './test.pl'; # for which_perl() etc
-}
-
-use strict;
-use Config;
+ @INC = '../lib';
+ require './test.pl';
+ $| = 1;
-BEGIN {
- if (!$Config{useithreads}) {
- print "1..0 # Skip: no ithreads\n";
- exit 0;
+ require Config;
+ if (!$Config::Config{useithreads}) {
+ print "1..0 # Skip: no ithreads\n";
+ exit 0;
}
- eval 'use threads';
- if ($@ =~ /dynamic loading not available/) {
- print "1..0 # Skip: miniperl can't load threads\n";
- exit 0;
+ if ($ENV{PERL_CORE_MINITEST}) {
+ print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+ exit 0;
}
- plan(3);
+
+ plan(9);
}
+use strict;
+use warnings;
+use threads;
+
# test that we don't get:
# Attempt to free unreferenced scalar: SV 0x40173f3c
fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
use threads;
-threads->new(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
+threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
print "ok";
EOI
my $obj = \$data;
my $copy = $obj;
Scalar::Util::weaken($copy);
-threads->new(sub { 1 })->join for (1..1);
+threads->create(sub { 1 })->join for (1..1);
print "ok";
EOI
my $object = Foo->new;
my $ref = $object;
weaken $ref;
-threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
+threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
+print "ok";
+EOI
+
+#PR30333 - sort() crash with threads
+sub mycmp { length($b) <=> length($a) }
+
+sub do_sort_one_thread {
+ my $kid = shift;
+ print "# kid $kid before sort\n";
+ my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
+ 'hello', 's', 'thisisalongname', '1', '2', '3',
+ 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
+
+ for my $j (1..99999) {
+ for my $k (sort mycmp @list) {}
+ }
+ print "# kid $kid after sort, sleeping 1\n";
+ sleep(1);
+ print "# kid $kid exit\n";
+}
+
+sub do_sort_threads {
+ my $nthreads = shift;
+ my @kids = ();
+ for my $i (1..$nthreads) {
+ my $t = threads->create(\&do_sort_one_thread, $i);
+ print "# parent $$: continue\n";
+ push(@kids, $t);
+ }
+ for my $t (@kids) {
+ print "# parent $$: waiting for join\n";
+ $t->join();
+ print "# parent $$: thread exited\n";
+ }
+}
+
+do_sort_threads(2); # crashes
+ok(1);
+
+# Change 24643 made the mistake of assuming that CvCONST can only be true on
+# XSUBs. Somehow it can also end up on perl subs.
+fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
+use constant x=>1;
+use threads;
+$SIG{__WARN__} = sub{};
+async sub {};
print "ok";
EOI
+
+# From a test case by Tim Bunce in
+# http://www.nntp.perl.org/group/perl.perl5.porters/63123
+fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
+use threads;
+print do 'op/threads_create.pl' || die $@;
+EOI
+
+
+TODO: {
+ no strict 'vars'; # Accessing $TODO from test.pl
+ local $TODO = 'refcount issues with threads';
+
+# Scalars leaked: 1
+foreach my $BLOCK (qw(CHECK INIT)) {
+ fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
+ use threads;
+ $BLOCK { threads->create(sub {})->join; }
+ print 'ok';
+EOI
+}
+
+# Scalars leaked: 1
+fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
+ use threads;
+ leak($x);
+ sub leak
+ {
+ local $x;
+ threads->create(sub {})->join();
+ }
+ print 'ok';
+EOI
+
+} # TODO
+
+# EOF