13 is(empty_sub,undef,"Is empty");
14 is(empty_sub(1,2,3),undef,"Is still empty");
16 is(scalar(@test), 0, 'Didnt return anything');
17 @test = empty_sub(1,2,3);
18 is(scalar(@test), 0, 'Didnt return anything');
20 # RT #63790: calling PL_sv_yes as a sub is special-cased to silently
21 # return (so Foo->import() silently fails if import() doesn't exist),
22 # But make sure it correctly pops the stack and mark stack before returning.
26 push @a, 4, 5, main->import(6,7);
27 ok(eq_array(\@a, [4,5]), "import with args");
30 push @a, 14, 15, main->import;
31 ok(eq_array(\@a, [14,15]), "import without args");
36 push @a, 24, 25, &{$x == $x}(26,27);
37 ok(eq_array(\@a, [24,25]), "yes with args");
40 push @a, 34, 35, &{$x == $x};
41 ok(eq_array(\@a, [34,35]), "yes without args");
44 # [perl #91844] return should always copy
47 for my $x ($foo{bar}) {
48 # Pity test.pl doesnt have isn't.
49 isnt \sub { delete $foo{bar} }->(), \$x,
50 'result of delete(helem) is copied when returned';
53 for my $x ($foo{bar}) {
54 isnt \sub { return delete $foo{bar} }->(), \$x,
55 'result of delete(helem) is copied when explicitly returned';
58 isnt \sub { delete $_[0] }->($x), \$x,
59 'result of delete(aelem) is copied when returned';
60 isnt \sub { return delete $_[0] }->($x), \$x,
61 'result of delete(aelem) is copied when explicitly returned';
62 isnt \sub { ()=\@_; shift }->($x), \$x,
63 'result of shift is copied when returned';
64 isnt \sub { ()=\@_; return shift }->($x), \$x,
65 'result of shift is copied when explicitly returned';
71 isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
72 }->(sub { delete $foo{bar} }->());
76 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
79 eval 'sub bar { print +(caller 0)[3], "\n" }';
84 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
89 eval 'sub bar { print +(caller 0)[3], "\n" }';
96 # The outer call sets the scalar returned by ${\""}.${\""} to the current
98 # The inner call sets it to "road".
99 # Each call records the value twice, the outer call surrounding the inner
100 # call. In 5.10-5.18 under ithreads, what gets pushed is
101 # qw(main road road road) because the inner call is clobbering the same
102 # scalar. If __PACKAGE__ is changed to "main", it works, the last element
106 for (${\""}.${\""}) {
109 a("road",1) unless $_[1];
115 is "@scratch", "main road road main",
116 'recursive calls do not share shared-hash-key TARGs';
118 # Another test for the same bug, that does not rely on foreach. It depends
119 # on ref returning a shared hash key TARG.
122 my ($pack, $depth) = @_;
123 my $o = bless[], $pack;
125 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
128 is "@scratch", "o n",
129 'recursive calls do not share shared-hash-key TARGs (2)';
131 # [perl #78194] @_ aliasing op return values
132 sub { is \$_[0], \$_[0],
133 '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
136 # The return statement should make no difference in this case:
137 sub not_constant () { 42 }
138 sub not_constantr() { return 42 }
139 use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
140 my sub not_constantm () { 42 }
141 my sub not_constantmr() { return 42 }
142 eval { ${\not_constant}++ };
143 is $@, "", 'sub (){42} returns a mutable value';
144 eval { ${\not_constantr}++ };
145 is $@, "", 'sub (){ return 42 } returns a mutable value';
146 eval { ${\not_constantm}++ };
147 is $@, "", 'my sub (){42} returns a mutable value';
148 eval { ${\not_constantmr}++ };
149 is $@, "", 'my sub (){ return 42 } returns a mutable value';
152 sub Munchy { $_[0] = 2 }
153 eval "Crunchy"; # test that freeing this op does not turn off PADTMP
155 } || $@, 2, 'freeing ops does not make sub(){42} immutable';
157 # &xsub when @_ has nonexistent elements
159 no warnings "uninitialized";
163 is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
164 is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
167 # &xsub when @_ itself does not exist
169 eval { &utf8::encode };
170 # The main thing we are testing is that it did not crash. But make sure
171 # *_{ARRAY} was untouched, too.
172 is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
174 # We do not want re.pm loaded at this point. Move this test up or find
175 # another XSUB if this fails.
176 ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
181 no warnings 'redefine', 'prototype';
183 *re::regmust = sub{}; # GvSV had no refcount, so this freed it
184 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0)
185 @str = ($str1, $str2);
187 local $^W; # Suppress redef warnings in XSLoader
190 'XSUB clobbering sub whose DESTROY assigns to the glob';
193 no warnings 'redefine';
195 bless \&foo, 'newATTRSUBbug';
196 sub newATTRSUBbug::DESTROY {
198 *foo = sub{}; # GvSV had no refcount, so this freed it
199 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0)
200 @str = ($str1, $str2);
205 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
208 # [perl #122107] previously this would return
209 # Subroutine BEGIN redefined at (eval 2) line 2.
210 fresh_perl_is(<<'EOS', "", { stderr => 1 },
211 use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
213 "check special blocks are cleared on error");
215 use constant { constant1 => 1, constant2 => 2 };
218 local $SIG{__WARN__} = sub { $w++ };
219 eval 'sub constant1; sub constant2($)';
220 is eval '&constant1', '1',
221 'stub re-declaration of constant with no prototype';
222 is eval '&constant2', '2',
223 'stub re-declaration of constant with wrong prototype';
224 is $w, 2, 'two warnings from the above';
229 my $parent; # just to make the sub a closure
232 local $depth = $depth + 1;
233 our $ok++, return if $depth == 2;
235 ()= $parent; # just to make the sub a closure
236 our $whatever; # this causes the crash
242 '[perl #122845] no crash in closure recursion with our-vars';
244 () = *predeclared; # vivify the glob at compile time
245 sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
248 sub inside_predeclared {
249 is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub';
252 predeclared(); # set $x to 42
253 $main::x = $main::x = "You should not see this.";
254 inside_predeclared(); # run test
256 # RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
257 eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
258 pass("RT #126845: stub with prototype, then with attribute");
260 eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
261 pass("RT #126845: stub with prototype, then definition with attribute");
263 # RT #124156 death during unwinding causes crash
264 # the tie allows us to trigger another die while cleaning up the stack
265 # from an earlier die.
270 sub TIEHASH { bless({}, $_[0]) }
274 sub DELETE { die "outer\n" }
282 local $a{foo} = "bar";
289 ::is($@, "outer\n", "RT124156 plain");
292 sub DESTROY { $destroyed = 1 }
297 $x = 1; # force closure
300 local $a{foo} = "bar";
303 bless $f, 'RT124156';
308 # as opposed to $@ eq "Can't undef active subroutine"
309 ::is($@, "outer\n", "RT124156 depth");
310 ::is($destroyed, 1, "RT124156 freed cv");
313 # trapping dying while popping a scope needs to have the right pad at all
314 # times. Localising a tied array then dying in STORE raises an exception
315 # while leaving g(). Note that using an object and destructor wouldn't be
316 # sufficient since DESTROY is called with call_sv(...,G_EVAL).
317 # We make sure that the first item in every sub's pad is a lexical with
318 # different values per sub.
321 package tie_exception;
322 sub TIEARRAY { my $x = 4; bless [0] }
323 sub FETCH { my $x = 5; 1 }
324 sub STORE { my $x = 6; die if $_[0][0]; $_[0][0] = 1 }
327 sub f { my $x = 7; eval { g() }; $y = $x }
331 tie @a, "tie_exception";
336 ::is($y, 7, "tie_exception");
340 # check that return pops extraneous stuff from the stack
343 # the extra scopes push contexts and extra SVs on the stack
345 my @a = map $_ + 20, @_;
347 return if defined $_[0] && $_[0] < 0;
350 check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5);
355 is(scalar check_ret(), undef, "check_ret() scalar");
356 is(scalar check_ret(5), 25, "check_ret(5) scalar");
357 is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar");
358 is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar");
359 is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar");
360 is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar");
362 is(scalar check_ret(-1), undef, "check_ret(-1) scalar");
363 is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar");
365 is(join('-', 10, check_ret()), "10", "check_ret() list");
366 is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list");
367 is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list");
368 is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list");
369 is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list");
370 is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
372 is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list");
373 is(join('-', 10, check_ret(-1,5)), "10", "check_ret(-1,5) list");
375 # a sub without nested scopes that still leaves rubbish on the stack
376 # which needs popping
380 # conditional leaves rubbish on stack
381 return @_ unless $false and $false;
384 is(join('-', @res), "a-b", "unnested rubbish");
387 # a sub should copy returned PADTMPs
390 sub f99 { $_[0] . "x" };
391 my $a = [ f99(1), f99(2) ];
392 is("@$a", "1x 2x", "PADTMPs copied on return");