Commit | Line | Data |
09576c7d |
1 | #!perl |
2 | |
f935b2f6 |
3 | BEGIN { |
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 | |
1db36481 |
19 | plan(13); |
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"; |
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 | |
dd5ef8e0 |
119 | TODO: { |
120 | no strict 'vars'; # Accessing $TODO from test.pl |
121 | local $TODO = 'refcount issues with threads'; |
122 | |
9708a845 |
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 |
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 |
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 |
158 | $_->join for @t; |
159 | ok(1, '[perl #45053]'); |
160 | } |
161 | |
f708cfc1 |
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 |
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 | |
188 | |
9708a845 |
189 | # EOF |