1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
#!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(13);
}
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
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
# [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);
# EOF
|
