d8bab5b475f104572a97fb7510f607f20cf9bd59
[perl.git] / t / op / threads.t
1 #!perl
2
3 BEGIN {
4      chdir 't' if -d 't';
5      @INC = '../lib';
6      require './test.pl';
7      $| = 1;
8
9      require Config;
10      if (!$Config::Config{useithreads}) {
11         print "1..0 # Skip: no ithreads\n";
12         exit 0;
13      }
14      if ($ENV{PERL_CORE_MINITEST}) {
15        print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
16        exit 0;
17      }
18
19      plan(22);
20 }
21
22 use strict;
23 use warnings;
24 use threads;
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;
30 threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
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);
44 threads->create(sub { 1 })->join for (1..1);
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;
61 threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
62 print "ok";
63 EOI
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) {
87       my $t = threads->create(\&do_sort_one_thread, $i);
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);
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
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;
115 print do 'op/threads_create.pl' || die $@;
116 EOI
117
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
140
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 {
146     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
147     my @t;
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     }
153     $_->join for @t;
154     ok(1, '[perl #45053]');
155 }
156
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
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
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");
188
189
190 # Test we don't get:
191 # panic: del_backref during global destruction.
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]');
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
202 # Another, more reliable test for the same del_backref bug:
203 fresh_perl_is(
204  <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
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.
213 fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
214 use threads;
215 print create threads sub {
216  my $x = 'foo';
217  sub{sub{$x}}
218 }=>->join->()()
219  //"undef"
220 EOJ
221
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
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
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
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
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
295 # EOF