[p5sagit/p5-mst-13.2.git] / t / op / threads.t

#!perl

BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
     $| = 1;

     require Config;
     if (!$Config::Config{useithreads}) {
        print "1..0 # Skip: no ithreads\n";
        exit 0;
     }
     if ($ENV{PERL_CORE_MINITEST}) {
       print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
       exit 0;
     }

     plan(23);
}

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->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
print "ok";
EOI

#PR24660
# test that we don't get:
# Attempt to free unreferenced scalar: SV 0x814e0dc.
fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
use threads;
use Scalar::Util;
my $data = "a";
my $obj = \$data;
my $copy = $obj;
Scalar::Util::weaken($copy);
threads->create(sub { 1 })->join for (1..1);
print "ok";
EOI

#PR24663
# test that we don't get:
# panic: magic_killbackrefs.
# Scalars leaked: 3
fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
package Foo;
sub new { bless {},shift }
package main;
use threads;
use Scalar::Util qw(weaken);
my $object = Foo->new;
my $ref = $object;
weaken $ref;
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


# 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


# [perl #45053] Memory corruption with heavy module loading in threads
#
# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
# thread-safe - got occasional coredumps or malloc corruption
{
    local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
    my @t;
    for (1..100) {
        my $thr = threads->create( sub { require IO });
        last if !defined($thr);      # Probably ran out of memory
        push(@t, $thr);
    }
    $_->join for @t;
    ok(1, '[perl #45053]');
}

sub matchit {
    is (ref $_[1], "Regexp");
    like ($_[0], $_[1]);
}

threads->new(\&matchit, "Pie", qr/pie/i)->join();

# tests in threads don't get counted, so
curr_test(curr_test() + 2);


# the seen_evals field of a regexp was getting zeroed on clone, so
# within a thread it didn't  know that a regex object contrained a 'safe'
# re_eval expression, so it later died with 'Eval-group not allowed' when
# you tried to interpolate the object

sub safe_re {
    my $re = qr/(?{1})/;	# this is literal, so safe
    eval { "a" =~ /$re$re/ };	# interpolating safe values, so safe
    ok($@ eq "", 'clone seen-evals');
}
threads->new(\&safe_re)->join();

# tests in threads don't get counted, so
curr_test(curr_test() + 1);

# This used to crash in 5.10.0 [perl #64954]

undef *a;
threads->new(sub {})->join;
pass("undefing a typeglob doesn't cause a crash during cloning");


# Test we don't get:
# panic: del_backref during global destruction.
# when returning a non-closure sub from a thread and subsequently starting
# a new thread.
fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
use threads;
sub foo { return (sub { }); }
my $bar = threads->create(\&foo)->join();
threads->create(sub { })->join();
print "ok";
EOI

# Another, more reliable test for the same del_backref bug:
fresh_perl_is(
 <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
   use threads;
   push @bar, threads->create(sub{sub{}})->join() for 1...10;
   print "ok";
   EOJ
);

# Simple closure-returning test: At least this case works (though it
# leaks), and we don't want to break it.
fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
use threads;
print create threads sub {
 my $x = 'foo';
 sub{sub{$x}}
}=>->join->()()
 //"undef"
EOJ

# At the point of thread creation, $h{1} is on the temps stack.
# The weak reference $a, however, is visible from the symbol table.
fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
    use threads;
    %h = (1, 2);
    use Scalar::Util 'weaken';
    $a = \$h{1};
    weaken($a);
    delete $h{1} && threads->create(sub {}, shift)->join();
    print 'ok';
EOI

# This will fail in "interesting" ways if stashes in clone_params is not
# initialised correctly.
fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
    use strict;
    use threads;

    sub foo::bar;

    my %h = (1, *{$::{'foo::'}}{HASH});
    *{$::{'foo::'}} = {};

    threads->create({}, delete $h{1})->join();

    print "end";
EOI

fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
    use threads;
    my %h = (1, []);
    use Scalar::Util 'weaken';
    my $a = $h{1};
    weaken($a);
    delete $h{1} && threads->create(sub {}, shift)->join();
    print 'ok';
EOI

{
    my $got;
    sub stuff {
	my $a;
	if (@_) {
	    $a = "Leakage";
	    threads->create(\&stuff)->join();
	} else {
	    is ($a, undef, 'RT #73086 - clone used to clone active pads');
	}
    }

    stuff(1);

    curr_test(curr_test() + 1);
}

{
    my $got;
    sub more_stuff {
	my $a;
	$::b = \$a;
	if (@_) {
	    $a = "More leakage";
	    threads->create(\&more_stuff)->join();
	} else {
	    is ($a, undef, 'Just special casing lexicals in ?{ ... }');
	}
    }

    more_stuff(1);

    curr_test(curr_test() + 1);
}

# Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
use strict;
use warnings;

use threads;

{
    package My::Obj;
    use Scalar::Util 'weaken';

    my %reg;

    sub new
    {
        # Create object with ID = 1
        my $class = shift;
        my $id = 1;
        my $obj = bless(\do{ my $scalar = $id; }, $class);

        # Save weak copy of object for reference during cloning
        weaken($reg{$id} = $obj);

        # Return object
        return $obj;
    }

    # Return the internal ID of the object
    sub id
    {
        my $obj = shift;
        return $$obj;
    }

    # During cloning 'look' at the object
    sub CLONE {
        foreach my $id (keys(%reg)) {
            # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant.
            my $obj = $reg{$id};
        }
    }
}

# Create object in 'main' thread
my $obj = My::Obj->new();
my $id = $obj->id();
die "\$id is '$id'" unless $id == 1;

# Access object in thread
threads->create(
    sub {
        print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
    }
)->join();

EOI

# EOF
Commit	Line	Data
09576c7d	1	#!perl
09576c7d	2
f935b2f6	3	BEGIN {
f935b2f6	4	chdir 't' if -d 't';
996dc718	5	@INC = '../lib';
9708a845	6	require './test.pl';
57690963	7	$\| = 1;
f935b2f6	8
09576c7d	9	require Config;
	10	if (!$Config::Config{useithreads}) {
	11	print "1..0 # Skip: no ithreads\n";
	12	exit 0;
f935b2f6	13	}
6765206c	14	if ($ENV{PERL_CORE_MINITEST}) {
	15	print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
	16	exit 0;
f935b2f6	17	}
09576c7d	18
04518cc3	19	plan(23);
f935b2f6	20	}
09576c7d	21
	22	use strict;
	23	use warnings;
6765206c	24	use threads;
f935b2f6	25
	26	# test that we don't get:
	27	# Attempt to free unreferenced scalar: SV 0x40173f3c
	28	fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
	29	use threads;
878090d5	30	threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
f935b2f6	31	print "ok";
	32	EOI
	33
	34	#PR24660
	35	# test that we don't get:
	36	# Attempt to free unreferenced scalar: SV 0x814e0dc.
	37	fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
	38	use threads;
	39	use Scalar::Util;
	40	my $data = "a";
	41	my $obj = \$data;
	42	my $copy = $obj;
	43	Scalar::Util::weaken($copy);
878090d5	44	threads->create(sub { 1 })->join for (1..1);
f935b2f6	45	print "ok";
	46	EOI
	47
	48	#PR24663
	49	# test that we don't get:
	50	# panic: magic_killbackrefs.
	51	# Scalars leaked: 3
	52	fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
	53	package Foo;
	54	sub new { bless {},shift }
	55	package main;
	56	use threads;
	57	use Scalar::Util qw(weaken);
	58	my $object = Foo->new;
	59	my $ref = $object;
	60	weaken $ref;
878090d5	61	threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
f935b2f6	62	print "ok";
f935b2f6	63	EOI
9850bf21	64
	65	#PR30333 - sort() crash with threads
	66	sub mycmp { length($b) <=> length($a) }
	67
	68	sub do_sort_one_thread {
	69	my $kid = shift;
	70	print "# kid $kid before sort\n";
	71	my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
	72	'hello', 's', 'thisisalongname', '1', '2', '3',
	73	'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
	74
	75	for my $j (1..99999) {
	76	for my $k (sort mycmp @list) {}
	77	}
	78	print "# kid $kid after sort, sleeping 1\n";
	79	sleep(1);
	80	print "# kid $kid exit\n";
	81	}
	82
	83	sub do_sort_threads {
	84	my $nthreads = shift;
	85	my @kids = ();
	86	for my $i (1..$nthreads) {
878090d5	87	my $t = threads->create(\&do_sort_one_thread, $i);
9850bf21	88	print "# parent $$: continue\n";
	89	push(@kids, $t);
	90	}
	91	for my $t (@kids) {
	92	print "# parent $$: waiting for join\n";
	93	$t->join();
	94	print "# parent $$: thread exited\n";
	95	}
	96	}
	97
	98	do_sort_threads(2); # crashes
	99	ok(1);
cfae286e	100
	101	# Change 24643 made the mistake of assuming that CvCONST can only be true on
	102	# XSUBs. Somehow it can also end up on perl subs.
	103	fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
	104	use constant x=>1;
	105	use threads;
	106	$SIG{__WARN__} = sub{};
	107	async sub {};
	108	print "ok";
	109	EOI
db4997f0	110
	111	# From a test case by Tim Bunce in
	112	# http://www.nntp.perl.org/group/perl.perl5.porters/63123
	113	fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
	114	use threads;
e81465be	115	print do 'op/threads_create.pl' \|\| die $@;
db4997f0	116	EOI
9708a845	117
9708a845	118
	119	# Scalars leaked: 1
	120	foreach my $BLOCK (qw(CHECK INIT)) {
	121	fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
	122	use threads;
	123	$BLOCK { threads->create(sub {})->join; }
	124	print 'ok';
	125	EOI
	126	}
	127
	128	# Scalars leaked: 1
	129	fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
	130	use threads;
	131	leak($x);
	132	sub leak
	133	{
	134	local $x;
	135	threads->create(sub {})->join();
	136	}
	137	print 'ok';
	138	EOI
	139
9708a845	140
f0d3b40c	141	# [perl #45053] Memory corruption with heavy module loading in threads
	142	#
	143	# run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
	144	# thread-safe - got occasional coredumps or malloc corruption
	145	{
76eabe0a	146	local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings
f0d3b40c	147	my @t;
76eabe0a	148	for (1..100) {
	149	my $thr = threads->create( sub { require IO });
	150	last if !defined($thr); # Probably ran out of memory
	151	push(@t, $thr);
	152	}
f0d3b40c	153	$_->join for @t;
	154	ok(1, '[perl #45053]');
	155	}
	156
f708cfc1	157	sub matchit {
	158	is (ref $_[1], "Regexp");
	159	like ($_[0], $_[1]);
	160	}
	161
	162	threads->new(\&matchit, "Pie", qr/pie/i)->join();
	163
	164	# tests in threads don't get counted, so
	165	curr_test(curr_test() + 2);
	166
1db36481	167
	168	# the seen_evals field of a regexp was getting zeroed on clone, so
	169	# within a thread it didn't know that a regex object contrained a 'safe'
	170	# re_eval expression, so it later died with 'Eval-group not allowed' when
	171	# you tried to interpolate the object
	172
	173	sub safe_re {
	174	my $re = qr/(?{1})/; # this is literal, so safe
	175	eval { "a" =~ /$re$re/ }; # interpolating safe values, so safe
	176	ok($@ eq "", 'clone seen-evals');
	177	}
	178	threads->new(\&safe_re)->join();
	179
	180	# tests in threads don't get counted, so
	181	curr_test(curr_test() + 1);
	182
1dffc4d1	183	# This used to crash in 5.10.0 [perl #64954]
	184
	185	undef *a;
	186	threads->new(sub {})->join;
	187	pass("undefing a typeglob doesn't cause a crash during cloning");
1db36481	188
7c76c2a0	189
7c76c2a0	190	# Test we don't get:
7c76c2a0	191	# panic: del_backref during global destruction.
27bca322	192	# when returning a non-closure sub from a thread and subsequently starting
	193	# a new thread.
	194	fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
7c76c2a0	195	use threads;
	196	sub foo { return (sub { }); }
	197	my $bar = threads->create(\&foo)->join();
	198	threads->create(sub { })->join();
	199	print "ok";
	200	EOI
	201
27bca322	202	# Another, more reliable test for the same del_backref bug:
e4295668	203	fresh_perl_is(
e4295668	204	<<' EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
27bca322	205	use threads;
	206	push @bar, threads->create(sub{sub{}})->join() for 1...10;
	207	print "ok";
	208	EOJ
	209	);
	210
	211	# Simple closure-returning test: At least this case works (though it
	212	# leaks), and we don't want to break it.
e4295668	213	fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
27bca322	214	use threads;
27bca322	215	print create threads sub {
e4295668	216	my $x = 'foo';
27bca322	217	sub{sub{$x}}
	218	}=>->join->()()
	219	//"undef"
	220	EOJ
7c76c2a0	221
3287f6c3	222	# At the point of thread creation, $h{1} is on the temps stack.
	223	# The weak reference $a, however, is visible from the symbol table.
	224	fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
	225	use threads;
	226	%h = (1, 2);
	227	use Scalar::Util 'weaken';
	228	$a = \$h{1};
	229	weaken($a);
	230	delete $h{1} && threads->create(sub {}, shift)->join();
	231	print 'ok';
	232	EOI
	233
f7abe70b	234	# This will fail in "interesting" ways if stashes in clone_params is not
	235	# initialised correctly.
	236	fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
	237	use strict;
	238	use threads;
	239
	240	sub foo::bar;
	241
	242	my %h = (1, *{$::{'foo::'}}{HASH});
	243	*{$::{'foo::'}} = {};
	244
	245	threads->create({}, delete $h{1})->join();
	246
	247	print "end";
	248	EOI
	249
d08d57ef	250	fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
	251	use threads;
	252	my %h = (1, []);
	253	use Scalar::Util 'weaken';
	254	my $a = $h{1};
	255	weaken($a);
	256	delete $h{1} && threads->create(sub {}, shift)->join();
	257	print 'ok';
	258	EOI
	259
05d04d9c	260	{
	261	my $got;
	262	sub stuff {
	263	my $a;
	264	if (@_) {
	265	$a = "Leakage";
	266	threads->create(\&stuff)->join();
	267	} else {
	268	is ($a, undef, 'RT #73086 - clone used to clone active pads');
	269	}
	270	}
	271
	272	stuff(1);
	273
	274	curr_test(curr_test() + 1);
	275	}
	276
adf8f095	277	{
	278	my $got;
	279	sub more_stuff {
	280	my $a;
	281	$::b = \$a;
	282	if (@_) {
	283	$a = "More leakage";
	284	threads->create(\&more_stuff)->join();
	285	} else {
	286	is ($a, undef, 'Just special casing lexicals in ?{ ... }');
	287	}
	288	}
	289
	290	more_stuff(1);
	291
	292	curr_test(curr_test() + 1);
	293	}
	294
04518cc3	295	# Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
	296	fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
	297	use strict;
	298	use warnings;
	299
	300	use threads;
	301
	302	{
	303	package My::Obj;
	304	use Scalar::Util 'weaken';
	305
	306	my %reg;
	307
	308	sub new
	309	{
	310	# Create object with ID = 1
	311	my $class = shift;
	312	my $id = 1;
	313	my $obj = bless(\do{ my $scalar = $id; }, $class);
	314
	315	# Save weak copy of object for reference during cloning
	316	weaken($reg{$id} = $obj);
	317
	318	# Return object
	319	return $obj;
	320	}
	321
	322	# Return the internal ID of the object
	323	sub id
	324	{
	325	my $obj = shift;
	326	return $$obj;
	327	}
	328
	329	# During cloning 'look' at the object
	330	sub CLONE {
	331	foreach my $id (keys(%reg)) {
	332	# This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referant.
	333	my $obj = $reg{$id};
	334	}
	335	}
	336	}
	337
	338	# Create object in 'main' thread
	339	my $obj = My::Obj->new();
	340	my $id = $obj->id();
	341	die "\$id is '$id'" unless $id == 1;
	342
	343	# Access object in thread
	344	threads->create(
	345	sub {
	346	print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
	347	}
	348	)->join();
	349
	350	EOI
	351
9708a845	352	# EOF