Devel::PPPort: Fix D_PPP_FIX_UTF8_ERRSV macro
[perl.git] / t / op / threads.t
1 #!perl
2
3 BEGIN {
4      chdir 't' if -d 't';
5      require './test.pl';
6      set_up_inc( '../lib' );
7      $| = 1;
8
9      skip_all_without_config('useithreads');
10      skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
11
12      plan(30);
13 }
14
15 use strict;
16 use warnings;
17 use threads;
18
19 # test that we don't get:
20 # Attempt to free unreferenced scalar: SV 0x40173f3c
21 fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
22 use threads;
23 threads->create(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
24 print "ok";
25 EOI
26
27 #PR24660
28 # test that we don't get:
29 # Attempt to free unreferenced scalar: SV 0x814e0dc.
30 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
31 use threads;
32 use Scalar::Util;
33 my $data = "a";
34 my $obj = \$data;
35 my $copy = $obj;
36 Scalar::Util::weaken($copy);
37 threads->create(sub { 1 })->join for (1..1);
38 print "ok";
39 EOI
40
41 #PR24663
42 # test that we don't get:
43 # panic: magic_killbackrefs.
44 # Scalars leaked: 3
45 fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
46 package Foo;
47 sub new { bless {},shift }
48 package main;
49 use threads;
50 use Scalar::Util qw(weaken);
51 my $object = Foo->new;
52 my $ref = $object;
53 weaken $ref;
54 threads->create(sub { $ref = $object } )->join; # $ref = $object causes problems
55 print "ok";
56 EOI
57
58 #PR30333 - sort() crash with threads
59 sub mycmp { length($b) <=> length($a) }
60
61 sub do_sort_one_thread {
62    my $kid = shift;
63    print "# kid $kid before sort\n";
64    my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
65                 'hello', 's', 'thisisalongname', '1', '2', '3',
66                 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
67
68    for my $j (1..99999) {
69       for my $k (sort mycmp @list) {}
70    }
71    print "# kid $kid after sort, sleeping 1\n";
72    sleep(1);
73    print "# kid $kid exit\n";
74 }
75
76 sub do_sort_threads {
77    my $nthreads = shift;
78    my @kids = ();
79    for my $i (1..$nthreads) {
80       my $t = threads->create(\&do_sort_one_thread, $i);
81       print "# parent $$: continue\n";
82       push(@kids, $t);
83    }
84    for my $t (@kids) {
85       print "# parent $$: waiting for join\n";
86       $t->join();
87       print "# parent $$: thread exited\n";
88    }
89 }
90
91 do_sort_threads(2);        # crashes
92 ok(1);
93
94 # Change 24643 made the mistake of assuming that CvCONST can only be true on
95 # XSUBs. Somehow it can also end up on perl subs.
96 fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
97 use constant x=>1;
98 use threads;
99 $SIG{__WARN__} = sub{};
100 async sub {};
101 print "ok";
102 EOI
103
104 # From a test case by Tim Bunce in
105 # http://www.nntp.perl.org/group/perl.perl5.porters/63123
106 fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
107 use threads;
108 print do 'op/threads_create.pl' || die $@;
109 EOI
110
111
112 # Scalars leaked: 1
113 foreach my $BLOCK (qw(CHECK INIT)) {
114     fresh_perl_is(<<EOI, 'ok', { }, "threads in $BLOCK block");
115         use threads;
116         $BLOCK { threads->create(sub {})->join; }
117         print 'ok';
118 EOI
119 }
120
121 # Scalars leaked: 1
122 fresh_perl_is(<<'EOI', 'ok', { }, 'Bug #41138');
123     use threads;
124     leak($x);
125     sub leak
126     {
127         local $x;
128         threads->create(sub {})->join();
129     }
130     print 'ok';
131 EOI
132
133
134 # [perl #45053] Memory corruption with heavy module loading in threads
135 #
136 # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
137 # thread-safe - got occasional coredumps or malloc corruption
138 watchdog(180, "process");
139 {
140     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
141     my @t;
142     for (1..10) {
143         my $thr = threads->create( sub { require IO });
144         last if !defined($thr);      # Probably ran out of memory
145         push(@t, $thr);
146     }
147     $_->join for @t;
148     ok(1, '[perl #45053]');
149 }
150
151 sub matchit {
152     is (ref $_[1], "Regexp");
153     like ($_[0], $_[1]);
154 }
155
156 threads->new(\&matchit, "Pie", qr/pie/i)->join();
157
158 # tests in threads don't get counted, so
159 curr_test(curr_test() + 2);
160
161
162 # the seen_evals field of a regexp was getting zeroed on clone, so
163 # within a thread it didn't  know that a regex object contained a 'safe'
164 # code expression, so it later died with 'Eval-group not allowed' when
165 # you tried to interpolate the object
166
167 sub safe_re {
168     my $re = qr/(?{1})/;        # this is literal, so safe
169     eval { "a" =~ /$re$re/ };   # interpolating safe values, so safe
170     ok($@ eq "", 'clone seen-evals');
171 }
172 threads->new(\&safe_re)->join();
173
174 # tests in threads don't get counted, so
175 curr_test(curr_test() + 1);
176
177 # This used to crash in 5.10.0 [perl #64954]
178
179 undef *a;
180 threads->new(sub {})->join;
181 pass("undefing a typeglob doesn't cause a crash during cloning");
182
183
184 # Test we don't get:
185 # panic: del_backref during global destruction.
186 # when returning a non-closure sub from a thread and subsequently starting
187 # a new thread.
188 fresh_perl_is(<<'EOI', 'ok', { }, 'No del_backref panic [perl #70748]');
189 use threads;
190 sub foo { return (sub { }); }
191 my $bar = threads->create(\&foo)->join();
192 threads->create(sub { })->join();
193 print "ok";
194 EOI
195
196 # Another, more reliable test for the same del_backref bug:
197 fresh_perl_is(
198  <<'   EOJ', 'ok', {}, 'No del_backref panic [perl #70748] (2)'
199    use threads;
200    push @bar, threads->create(sub{sub{}})->join() for 1...10;
201    print "ok";
202    EOJ
203 );
204
205 # Simple closure-returning test: At least this case works (though it
206 # leaks), and we don't want to break it.
207 fresh_perl_is(<<'EOJ', 'foo', {}, 'returning a closure');
208 use threads;
209 print create threads sub {
210  my $x = 'foo';
211  sub{sub{$x}}
212 }=>->join->()()
213  //"undef"
214 EOJ
215
216 # At the point of thread creation, $h{1} is on the temps stack.
217 # The weak reference $a, however, is visible from the symbol table.
218 fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9');
219     use threads;
220     %h = (1, 2);
221     use Scalar::Util 'weaken';
222     $a = \$h{1};
223     weaken($a);
224     delete $h{1} && threads->create(sub {}, shift)->join();
225     print 'ok';
226 EOI
227
228 # This will fail in "interesting" ways if stashes in clone_params is not
229 # initialised correctly.
230 fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046');
231     use strict;
232     use threads;
233
234     sub foo::bar;
235
236     my %h = (1, *{$::{'foo::'}}{HASH});
237     *{$::{'foo::'}} = {};
238
239     threads->create({}, delete $h{1})->join();
240
241     print "end";
242 EOI
243
244 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt neither on tmps stack nor in @_');
245     use threads;
246     my %h = (1, []);
247     use Scalar::Util 'weaken';
248     my $a = $h{1};
249     weaken($a);
250     delete $h{1} && threads->create(sub {}, shift)->join();
251     print 'ok';
252 EOI
253
254 {
255     my $got;
256     sub stuff {
257         my $a;
258         if (@_) {
259             $a = "Leakage";
260             threads->create(\&stuff)->join();
261         } else {
262             is ($a, undef, 'RT #73086 - clone used to clone active pads');
263         }
264     }
265
266     stuff(1);
267
268     curr_test(curr_test() + 1);
269 }
270
271 {
272     my $got;
273     sub more_stuff {
274         my $a;
275         $::b = \$a;
276         if (@_) {
277             $a = "More leakage";
278             threads->create(\&more_stuff)->join();
279         } else {
280             is ($a, undef, 'Just special casing lexicals in ?{ ... }');
281         }
282     }
283
284     more_stuff(1);
285
286     curr_test(curr_test() + 1);
287 }
288
289 # Test from Jerry Hedden, reduced by him from Object::InsideOut's tests.
290 fresh_perl_is(<<'EOI', 'ok', { }, '0 refcnt during CLONE');
291 use strict;
292 use warnings;
293
294 use threads;
295
296 {
297     package My::Obj;
298     use Scalar::Util 'weaken';
299
300     my %reg;
301
302     sub new
303     {
304         # Create object with ID = 1
305         my $class = shift;
306         my $id = 1;
307         my $obj = bless(\do{ my $scalar = $id; }, $class);
308
309         # Save weak copy of object for reference during cloning
310         weaken($reg{$id} = $obj);
311
312         # Return object
313         return $obj;
314     }
315
316     # Return the internal ID of the object
317     sub id
318     {
319         my $obj = shift;
320         return $$obj;
321     }
322
323     # During cloning 'look' at the object
324     sub CLONE {
325         foreach my $id (keys(%reg)) {
326             # This triggers SvREFCNT_inc() then SvREFCNT_dec() on the referent.
327             my $obj = $reg{$id};
328         }
329     }
330 }
331
332 # Create object in 'main' thread
333 my $obj = My::Obj->new();
334 my $id = $obj->id();
335 die "\$id is '$id'" unless $id == 1;
336
337 # Access object in thread
338 threads->create(
339     sub {
340         print $obj->id() == 1 ? "ok\n" : "not ok '" . $obj->id() . "'\n";
341     }
342 )->join();
343
344 EOI
345
346 # make sure peephole optimiser doesn't recurse heavily.
347 # (We run this inside a thread to get a small stack)
348
349 {
350     # lots of constructs that have o->op_other etc
351     my $code = <<'EOF';
352         $r = $x || $y;
353         $x ||= $y;
354         $r = $x // $y;
355         $x //= $y;
356         $r = $x && $y;
357         $x &&= $y;
358         $r = $x ? $y : $z;
359         @a = map $x+1, @a;
360         @a = grep $x+1, @a;
361         $r = /$x/../$y/;
362
363         # this one will fail since we removed tail recursion optimisation
364         # with f11ca51e41e8
365         #while (1) { $x = 0 };
366
367         while (0) { $x = 0 };
368         for ($x=0; $y; $z=0) { $r = 0 };
369         for (1) { $x = 0 };
370         { $x = 0 };
371         $x =~ s/a/$x + 1/e;
372 EOF
373     $code = 'my ($r, $x,$y,$z,@a); return 5; ' . ($code x 1000);
374     my $res = threads->create(sub { eval $code})->join;
375     is($res, 5, "avoid peephole recursion");
376 }
377
378
379 # [perl #78494] Pipes shared between threads block when closed
380 {
381   my $perl = which_perl;
382   $perl = qq'"$perl"' if $perl =~ /\s/;
383   open(my $OUT, "|$perl") || die("ERROR: $!");
384   threads->create(sub { })->join;
385   ok(1, "Pipes shared between threads do not block when closed");
386 }
387
388 # [perl #105208] Typeglob clones should not be cloned again during a join
389 {
390   threads->create(sub { sub { $::hypogamma = 3 } })->join->();
391   is $::hypogamma, 3, 'globs cloned and joined are not recloned';
392 }
393
394 fresh_perl_is(
395   'use threads;' .
396   'async { delete $::{INC}; eval q"my $foo : bar" } ->join; print "ok\n";',
397   "ok",
398    {},
399   'no crash when deleting $::{INC} in thread'
400 );
401
402 fresh_perl_is(<<'CODE', 'ok', {}, 'no crash modifying extended array element');
403 use threads;
404 my @a = 1;
405 threads->create(sub { $#a = 1; $a[1] = 2; print qq/ok\n/ })->join;
406 CODE
407
408 fresh_perl_is(<<'CODE', '3.5,3.5', {}, 'RT #36664: Strange behavior of shared array');
409 use threads;
410 use threads::shared;
411
412 our @List : shared = (1..5);
413 my $v = 3.5;
414 $v > 0;
415 $List[3] = $v;
416 printf "%s,%s", @List[(3)], $List[3];
417 CODE
418
419 fresh_perl_like(<<'CODE', qr/ok/, {}, 'RT #41121 binmode(STDOUT,":encoding(utf8) does not crash');
420 use threads;
421 binmode(STDOUT,":encoding(utf8)");
422 threads->create(sub{});
423 print "ok\n";
424 CODE
425
426 # EOF