Bump Devel::PPPort to 3.44 for CPAN release
[perl.git] / t / op / sub.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan(tests => 62);
10
11 sub empty_sub {}
12
13 is(empty_sub,undef,"Is empty");
14 is(empty_sub(1,2,3),undef,"Is still empty");
15 @test = empty_sub();
16 is(scalar(@test), 0, 'Didnt return anything');
17 @test = empty_sub(1,2,3);
18 is(scalar(@test), 0, 'Didnt return anything');
19
20 # [perl #91844] return should always copy
21 {
22     $foo{bar} = 7;
23     for my $x ($foo{bar}) {
24         # Pity test.pl doesnt have isn't.
25         isnt \sub { delete $foo{bar} }->(), \$x,
26            'result of delete(helem) is copied when returned';
27     }
28     $foo{bar} = 7;
29     for my $x ($foo{bar}) {
30         isnt \sub { return delete $foo{bar} }->(), \$x,
31            'result of delete(helem) is copied when explicitly returned';
32     }
33     my $x;
34     isnt \sub { delete $_[0] }->($x), \$x,
35       'result of delete(aelem) is copied when returned';
36     isnt \sub { return delete $_[0] }->($x), \$x,
37       'result of delete(aelem) is copied when explicitly returned';
38     isnt \sub { ()=\@_; shift }->($x), \$x,
39       'result of shift is copied when returned';
40     isnt \sub { ()=\@_; return shift }->($x), \$x,
41       'result of shift is copied when explicitly returned';
42
43     $foo{bar} = 7;
44     my $r = \$foo{bar};
45     sub {
46         $$r++;
47         isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
48     }->(sub { delete $foo{bar} }->());
49 }
50
51 fresh_perl_is
52   <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
53 *foo = \&baz;
54 *bar = *foo;
55 eval 'sub bar { print +(caller 0)[3], "\n" }';
56 bar();
57 end
58
59 fresh_perl_is
60   <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
61 my $sub = sub { 4 };
62 *foo = $sub;
63 *bar = *foo;
64 undef &$sub;
65 eval 'sub bar { print +(caller 0)[3], "\n" }';
66 &$sub;
67 undef *foo;
68 undef *bar;
69 print "ok\n";
70 end
71
72 # The outer call sets the scalar returned by ${\""}.${\""} to the current
73 # package name.
74 # The inner call sets it to "road".
75 # Each call records the value twice, the outer call surrounding the inner
76 # call.  In 5.10-5.18 under ithreads, what gets pushed is
77 # qw(main road road road) because the inner call is clobbering the same
78 # scalar.  If __PACKAGE__ is changed to "main", it works, the last element
79 # becoming "main".
80 my @scratch;
81 sub a {
82   for (${\""}.${\""}) {
83     $_ = $_[0];
84     push @scratch, $_;
85     a("road",1) unless $_[1];
86     push @scratch, $_;
87   }
88 }
89 a(__PACKAGE__);
90 require Config;
91 is "@scratch", "main road road main",
92    'recursive calls do not share shared-hash-key TARGs';
93
94 # Another test for the same bug, that does not rely on foreach.  It depends
95 # on ref returning a shared hash key TARG.
96 undef @scratch;
97 sub b {
98     my ($pack, $depth) = @_;
99     my $o = bless[], $pack;
100     $pack++;
101     push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
102 }
103 b('n',0);
104 is "@scratch", "o n", 
105    'recursive calls do not share shared-hash-key TARGs (2)';
106
107 # [perl #78194] @_ aliasing op return values
108 sub { is \$_[0], \$_[0],
109         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
110  ->("${\''}");
111
112 # The return statement should make no difference in this case:
113 sub not_constant () {        42 }
114 sub not_constantr() { return 42 }
115 use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
116 my sub not_constantm () {        42 }
117 my sub not_constantmr() { return 42 }
118 eval { ${\not_constant}++ };
119 is $@, "", 'sub (){42} returns a mutable value';
120 eval { ${\not_constantr}++ };
121 is $@, "", 'sub (){ return 42 } returns a mutable value';
122 eval { ${\not_constantm}++ };
123 is $@, "", 'my sub (){42} returns a mutable value';
124 eval { ${\not_constantmr}++ };
125 is $@, "", 'my sub (){ return 42 } returns a mutable value';
126 is eval {
127     sub Crunchy () { 1 }
128     sub Munchy { $_[0] = 2 }
129     eval "Crunchy"; # test that freeing this op does not turn off PADTMP
130     Munchy(Crunchy);
131 } || $@, 2, 'freeing ops does not make sub(){42} immutable';
132
133 # &xsub when @_ has nonexistent elements
134 {
135     no warnings "uninitialized";
136     local @_ = ();
137     $#_++;
138     &utf8::encode;
139     is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
140     is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
141 }
142
143 # &xsub when @_ itself does not exist
144 undef *_;
145 eval { &utf8::encode };
146 # The main thing we are testing is that it did not crash.  But make sure 
147 # *_{ARRAY} was untouched, too.
148 is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
149
150 # We do not want re.pm loaded at this point.  Move this test up or find
151 # another XSUB if this fails.
152 ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
153 {
154     sub re::regmust{}
155     bless \&re::regmust;
156     DESTROY {
157         no warnings 'redefine', 'prototype';
158         my $str1 = "$_[0]";
159         *re::regmust = sub{}; # GvSV had no refcount, so this freed it
160         my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
161         @str = ($str1, $str2);
162     }
163     local $^W; # Suppress redef warnings in XSLoader
164     require re;
165     is $str[1], $str[0],
166       'XSUB clobbering sub whose DESTROY assigns to the glob';
167 }
168 {
169     no warnings 'redefine';
170     sub foo {}
171     bless \&foo, 'newATTRSUBbug';
172     sub newATTRSUBbug::DESTROY {
173         my $str1 = "$_[0]";
174         *foo = sub{}; # GvSV had no refcount, so this freed it
175         my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
176         @str = ($str1, $str2);
177     }
178     splice @str;
179     eval "sub foo{}";
180     is $str[1], $str[0],
181       'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
182 }
183
184 # [perl #122107] previously this would return
185 #  Subroutine BEGIN redefined at (eval 2) line 2.
186 fresh_perl_is(<<'EOS', "", { stderr => 1 },
187 use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
188 EOS
189                "check special blocks are cleared on error");
190
191 use constant { constant1 => 1, constant2 => 2 };
192 {
193     my $w;
194     local $SIG{__WARN__} = sub { $w++ };
195     eval 'sub constant1; sub constant2($)';
196     is eval '&constant1', '1',
197       'stub re-declaration of constant with no prototype';
198     is eval '&constant2', '2',
199       'stub re-declaration of constant with wrong prototype';
200     is $w, 2, 'two warnings from the above';
201 }
202
203 package _122845 {
204     our $depth = 0;
205     my $parent; # just to make the sub a closure
206
207     sub {
208         local $depth = $depth + 1;
209         our $ok++, return if $depth == 2;
210
211         ()= $parent;  # just to make the sub a closure
212         our $whatever; # this causes the crash
213
214         CORE::__SUB__->();
215     }->();
216 };
217 is $_122845::ok, 1,
218   '[perl #122845] no crash in closure recursion with our-vars';
219
220 () = *predeclared; # vivify the glob at compile time
221 sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
222 sub predeclared {
223     CORE::state $x = 42;
224     sub inside_predeclared {
225         is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub';
226     }
227 }
228 predeclared(); # set $x to 42
229 $main::x = $main::x = "You should not see this.";
230 inside_predeclared(); # run test
231
232 # RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
233 eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
234 pass("RT #126845: stub with prototype, then with attribute");
235
236 eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
237 pass("RT #126845: stub with prototype, then definition with attribute");
238
239 # RT #124156 death during unwinding causes crash
240 # the tie allows us to trigger another die while cleaning up the stack
241 # from an earlier die.
242
243 {
244     package RT124156;
245
246     sub TIEHASH { bless({}, $_[0]) }
247     sub EXISTS { 0 }
248     sub FETCH { undef }
249     sub STORE { }
250     sub DELETE { die "outer\n" }
251
252     my @value;
253     eval {
254         @value = sub {
255             @value = sub {
256                 my %a;
257                 tie %a, "RT124156";
258                 local $a{foo} = "bar";
259                 die "inner";
260                 ("dd2a", "dd2b");
261             }->();
262             ("cc3a", "cc3b");
263         }->();
264     };
265     ::is($@, "outer\n", "RT124156 plain");
266
267     my $destroyed = 0;
268     sub DESTROY { $destroyed = 1 }
269
270     sub f {
271         my $x;
272         my $f = sub {
273             $x = 1; # force closure
274             my %a;
275             tie %a, "RT124156";
276             local $a{foo} = "bar";
277             die "inner";
278         };
279         bless $f, 'RT124156';
280         $f->();
281     }
282
283     eval { f(); };
284     # as opposed to $@ eq "Can't undef active subroutine"
285     ::is($@, "outer\n", "RT124156 depth");
286     ::is($destroyed, 1, "RT124156 freed cv");
287 }
288
289 # trapping dying while popping a scope needs to have the right pad at all
290 # times. Localising a tied array then dying in STORE raises an exception
291 # while leaving g(). Note that using an object and destructor wouldn't be
292 # sufficient since DESTROY is called with call_sv(...,G_EVAL).
293 # We make sure that the first item in every sub's pad is a lexical with
294 # different values per sub.
295
296 {
297     package tie_exception;
298     sub TIEARRAY { my $x = 4; bless [0] }
299     sub FETCH    { my $x = 5; 1 }
300     sub STORE    { my $x = 6; die if $_[0][0]; $_[0][0] = 1 }
301
302     my $y;
303     sub f { my $x = 7; eval { g() }; $y = $x }
304     sub g {
305         my $x = 8;
306         my @a;
307         tie @a, "tie_exception";
308         local $a[0];
309     }
310
311     f();
312     ::is($y, 7, "tie_exception");
313 }
314
315
316 # check that return pops extraneous stuff from the stack
317
318 sub check_ret {
319     # the extra scopes push contexts and extra SVs on the stack
320     {
321         my @a = map $_ + 20, @_;
322         for ('x') {
323             return if defined $_[0] && $_[0] < 0;
324         }
325         for ('y') {
326             check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5);
327         }
328     }
329 }
330
331 is(scalar check_ret(),          undef, "check_ret() scalar");
332 is(scalar check_ret(5),         25,    "check_ret(5) scalar");
333 is(scalar check_ret(5,6),       26,    "check_ret(5,6) scalar");
334 is(scalar check_ret(5,6,7),     27,    "check_ret(5,6,7) scalar");
335 is(scalar check_ret(5,6,7,8),   28,    "check_ret(5,6,7,8) scalar");
336 is(scalar check_ret(5,6,7,8,9), 29,    "check_ret(5,6,7,8,9) scalar");
337
338 is(scalar check_ret(-1),        undef, "check_ret(-1) scalar");
339 is(scalar check_ret(-1,5),      undef, "check_ret(-1,5) scalar");
340
341 is(join('-', 10, check_ret()),          "10",                "check_ret() list");
342 is(join('-', 10, check_ret(5)),         "10-25",             "check_ret(5) list");
343 is(join('-', 10, check_ret(5,6)),       "10-25-26",          "check_ret(5,6) list");
344 is(join('-', 10, check_ret(5,6,7)),     "10-25-26-27",       "check_ret(5,6,7) list");
345 is(join('-', 10, check_ret(5,6,7,8)),   "10-25-26-27-28",    "check_ret(5,6,7,8) list");
346 is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
347
348 is(join('-', 10, check_ret(-1)),        "10",  "check_ret(-1) list");
349 is(join('-', 10, check_ret(-1,5)),      "10",  "check_ret(-1,5) list");
350
351 # a sub without nested scopes that still leaves rubbish on the stack
352 # which needs popping
353 {
354     my @res = sub {
355         my $false;
356         # conditional leaves rubbish on stack
357         return @_ unless $false and $false;
358         1;
359     }->('a','b');
360     is(join('-', @res), "a-b", "unnested rubbish");
361 }
362
363 # a sub should copy returned PADTMPs
364
365 {
366     sub f99 { $_[0] . "x" };
367     my $a = [ f99(1), f99(2) ];
368     is("@$a", "1x 2x", "PADTMPs copied on return");
369 }
370
371 # A sub should FREETMPS on exit
372 # RT #124248
373
374 {
375     package p124248;
376     my $d = 0;
377     sub DESTROY { $d++ }
378     sub f { ::is($d, 1, "RT 124248"); }
379     sub g { !!(my $x = bless []); }
380     f(g());
381 }
382
383 # return should have the right PL_curpm while copying its return args
384
385 sub curpm {
386     "b" =~ /(.)/;
387     {
388         "c" =~ /(.)/;
389         return $1;
390     }
391 }
392 "a" =~ /(.)/;
393 is(curpm(), 'c', 'return and PL_curpm');
394
395 sub rt_129916 { 42 }
396 is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)';
397 {
398     package RT129916;
399     sub foo { 42 }
400 }
401 {
402     local $::TODO = "disabled for now";
403     is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
404 }
405
406 # Calling xsub via ampersand syntax when @_ has holes
407 SKIP: {
408     skip "no XS::APItest on miniperl" if is_miniperl;
409     require XS::APItest;
410     local *_;
411     $_[1] = 1;
412     &XS::APItest::unshift_and_set_defav;
413     is "@_", "42 43 1"
414 }
415
416 # [perl #129090] Crashes and hangs
417 watchdog 10;
418 { no warnings;
419   eval '$a=qq|a$a|;my sub b;%c;sub c{sub b;sub c}';
420 }
421 eval '
422    ()= %d;
423    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
424    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
425    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
426    CORE::state sub b; sub d { sub b {} sub d }
427  ';
428 eval '()=%e; sub e { sub e; eval q|$x| } e;';