Commit | Line | Data |
---|---|---|
09576c7d JH |
1 | #!perl |
2 | ||
f935b2f6 SB |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
996dc718 | 5 | @INC = '../lib'; |
9708a845 | 6 | require './test.pl'; |
57690963 | 7 | $| = 1; |
f935b2f6 | 8 | |
09576c7d JH |
9 | require Config; |
10 | if (!$Config::Config{useithreads}) { | |
11 | print "1..0 # Skip: no ithreads\n"; | |
12 | exit 0; | |
f935b2f6 | 13 | } |
6765206c NC |
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 | |
1dffc4d1 | 19 | plan(14); |
f935b2f6 | 20 | } |
09576c7d JH |
21 | |
22 | use strict; | |
23 | use warnings; | |
6765206c | 24 | use threads; |
f935b2f6 SB |
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 SB |
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 SB |
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 SB |
62 | print "ok"; |
63 | EOI | |
9850bf21 RH |
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 RH |
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 NC |
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 NC |
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 | |
dd5ef8e0 DM |
119 | TODO: { |
120 | no strict 'vars'; # Accessing $TODO from test.pl | |
121 | local $TODO = 'refcount issues with threads'; | |
122 | ||
9708a845 JH |
123 | # Scalars leaked: 1 |
124 | foreach my $BLOCK (qw(CHECK INIT)) { | |
125 | fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block"); | |
126 | use threads; | |
127 | $BLOCK { threads->create(sub {})->join; } | |
128 | print 'ok'; | |
129 | EOI | |
130 | } | |
131 | ||
132 | # Scalars leaked: 1 | |
133 | fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138'); | |
134 | use threads; | |
135 | leak($x); | |
136 | sub leak | |
137 | { | |
138 | local $x; | |
139 | threads->create(sub {})->join(); | |
140 | } | |
141 | print 'ok'; | |
142 | EOI | |
143 | ||
144 | } # TODO | |
145 | ||
f0d3b40c JH |
146 | # [perl #45053] Memory corruption with heavy module loading in threads |
147 | # | |
148 | # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't | |
149 | # thread-safe - got occasional coredumps or malloc corruption | |
150 | { | |
76eabe0a | 151 | local $SIG{__WARN__} = sub {}; # Ignore any thread creation failure warnings |
f0d3b40c | 152 | my @t; |
76eabe0a JH |
153 | for (1..100) { |
154 | my $thr = threads->create( sub { require IO }); | |
155 | last if !defined($thr); # Probably ran out of memory | |
156 | push(@t, $thr); | |
157 | } | |
f0d3b40c JH |
158 | $_->join for @t; |
159 | ok(1, '[perl #45053]'); | |
160 | } | |
161 | ||
f708cfc1 NC |
162 | sub matchit { |
163 | is (ref $_[1], "Regexp"); | |
164 | like ($_[0], $_[1]); | |
165 | } | |
166 | ||
167 | threads->new(\&matchit, "Pie", qr/pie/i)->join(); | |
168 | ||
169 | # tests in threads don't get counted, so | |
170 | curr_test(curr_test() + 2); | |
171 | ||
1db36481 DM |
172 | |
173 | # the seen_evals field of a regexp was getting zeroed on clone, so | |
174 | # within a thread it didn't know that a regex object contrained a 'safe' | |
175 | # re_eval expression, so it later died with 'Eval-group not allowed' when | |
176 | # you tried to interpolate the object | |
177 | ||
178 | sub safe_re { | |
179 | my $re = qr/(?{1})/; # this is literal, so safe | |
180 | eval { "a" =~ /$re$re/ }; # interpolating safe values, so safe | |
181 | ok($@ eq "", 'clone seen-evals'); | |
182 | } | |
183 | threads->new(\&safe_re)->join(); | |
184 | ||
185 | # tests in threads don't get counted, so | |
186 | curr_test(curr_test() + 1); | |
187 | ||
1dffc4d1 NC |
188 | # This used to crash in 5.10.0 [perl #64954] |
189 | ||
190 | undef *a; | |
191 | threads->new(sub {})->join; | |
192 | pass("undefing a typeglob doesn't cause a crash during cloning"); | |
1db36481 | 193 | |
9708a845 | 194 | # EOF |