This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_leavesub(): call FREETMPS and optimise
[perl5.git] / t / op / sub.t
CommitLineData
f7218ed4 1#!./perl -w
2d981f27
AB
2
3BEGIN {
4 chdir 't' if -d 't';
f7218ed4 5 require './test.pl';
43ece5b1 6 set_up_inc('../lib');
2d981f27
AB
7}
8
f7a874b8 9plan(tests => 62);
2d981f27
AB
10
11sub empty_sub {}
12
13is(empty_sub,undef,"Is empty");
14is(empty_sub(1,2,3),undef,"Is still empty");
15@test = empty_sub();
16is(scalar(@test), 0, 'Didnt return anything');
17@test = empty_sub(1,2,3);
18is(scalar(@test), 0, 'Didnt return anything');
19
4d198de3
DM
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.
23
24{
25 my @a;
26 push @a, 4, 5, main->import(6,7);
27 ok(eq_array(\@a, [4,5]), "import with args");
28
29 @a = ();
30 push @a, 14, 15, main->import;
31 ok(eq_array(\@a, [14,15]), "import without args");
32
33 my $x = 1;
34
35 @a = ();
36 push @a, 24, 25, &{$x == $x}(26,27);
37 ok(eq_array(\@a, [24,25]), "yes with args");
38
39 @a = ();
40 push @a, 34, 35, &{$x == $x};
41 ok(eq_array(\@a, [34,35]), "yes without args");
42}
3ed94dc0 43
a45346a4 44# [perl #91844] return should always copy
3ed94dc0
FC
45{
46 $foo{bar} = 7;
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';
51 }
52 $foo{bar} = 7;
53 for my $x ($foo{bar}) {
54 isnt \sub { return delete $foo{bar} }->(), \$x,
55 'result of delete(helem) is copied when explicitly returned';
56 }
57 my $x;
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';
5e267fb8
DM
66
67 $foo{bar} = 7;
68 my $r = \$foo{bar};
69 sub {
70 $$r++;
71 isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
72 }->(sub { delete $foo{bar} }->());
3ed94dc0 73}
f6894bc8
FC
74
75fresh_perl_is
76 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
77*foo = \&baz;
78*bar = *foo;
79eval 'sub bar { print +(caller 0)[3], "\n" }';
80bar();
81end
e52de15a
FC
82
83fresh_perl_is
84 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
85my $sub = sub { 4 };
86*foo = $sub;
87*bar = *foo;
88undef &$sub;
89eval 'sub bar { print +(caller 0)[3], "\n" }';
90&$sub;
91undef *foo;
92undef *bar;
93print "ok\n";
94end
7f6ba6d2
FC
95
96# The outer call sets the scalar returned by ${\""}.${\""} to the current
97# package name.
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
103# becoming "main".
104my @scratch;
105sub a {
106 for (${\""}.${\""}) {
107 $_ = $_[0];
108 push @scratch, $_;
109 a("road",1) unless $_[1];
110 push @scratch, $_;
111 }
112}
113a(__PACKAGE__);
114require Config;
7f6ba6d2
FC
115is "@scratch", "main road road main",
116 'recursive calls do not share shared-hash-key TARGs';
8e079c2a
FC
117
118# Another test for the same bug, that does not rely on foreach. It depends
119# on ref returning a shared hash key TARG.
120undef @scratch;
121sub b {
122 my ($pack, $depth) = @_;
123 my $o = bless[], $pack;
124 $pack++;
125 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
126}
127b('n',0);
8e079c2a
FC
128is "@scratch", "o n",
129 'recursive calls do not share shared-hash-key TARGs (2)';
2d885586 130
2d885586
FC
131# [perl #78194] @_ aliasing op return values
132sub { is \$_[0], \$_[0],
133 '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
134 ->("${\''}");
b784b94c
FC
135
136# The return statement should make no difference in this case:
137sub not_constant () { 42 }
138sub not_constantr() { return 42 }
d2440203
FC
139use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
140my sub not_constantm () { 42 }
141my sub not_constantmr() { return 42 }
b784b94c
FC
142eval { ${\not_constant}++ };
143is $@, "", 'sub (){42} returns a mutable value';
b784b94c
FC
144eval { ${\not_constantr}++ };
145is $@, "", 'sub (){ return 42 } returns a mutable value';
d2440203
FC
146eval { ${\not_constantm}++ };
147is $@, "", 'my sub (){42} returns a mutable value';
148eval { ${\not_constantmr}++ };
149is $@, "", 'my sub (){ return 42 } returns a mutable value';
0ad6fa35
FC
150is eval {
151 sub Crunchy () { 1 }
152 sub Munchy { $_[0] = 2 }
153 eval "Crunchy"; # test that freeing this op does not turn off PADTMP
154 Munchy(Crunchy);
155} || $@, 2, 'freeing ops does not make sub(){42} immutable';
137da2b0 156
dd2a7f90
FC
157# &xsub when @_ has nonexistent elements
158{
159 no warnings "uninitialized";
160 local @_ = ();
161 $#_++;
162 &utf8::encode;
163 is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
164 is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
165}
8c9d3376
FC
166
167# &xsub when @_ itself does not exist
168undef *_;
169eval { &utf8::encode };
170# The main thing we are testing is that it did not crash. But make sure
171# *_{ARRAY} was untouched, too.
172is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
7004ee49
FC
173
174# We do not want re.pm loaded at this point. Move this test up or find
175# another XSUB if this fails.
176ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
177{
7004ee49
FC
178 sub re::regmust{}
179 bless \&re::regmust;
180 DESTROY {
a28a9f6b 181 no warnings 'redefine', 'prototype';
7004ee49
FC
182 my $str1 = "$_[0]";
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);
186 }
a28a9f6b 187 local $^W; # Suppress redef warnings in XSLoader
7004ee49
FC
188 require re;
189 is $str[1], $str[0],
190 'XSUB clobbering sub whose DESTROY assigns to the glob';
191}
a6181857
FC
192{
193 no warnings 'redefine';
194 sub foo {}
195 bless \&foo, 'newATTRSUBbug';
196 sub newATTRSUBbug::DESTROY {
197 my $str1 = "$_[0]";
198 *foo = sub{}; # GvSV had no refcount, so this freed it
199 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0)
200 @str = ($str1, $str2);
201 }
202 splice @str;
203 eval "sub foo{}";
204 is $str[1], $str[0],
205 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
206}
2806bfd8 207
2806bfd8
TC
208# [perl #122107] previously this would return
209# Subroutine BEGIN redefined at (eval 2) line 2.
210fresh_perl_is(<<'EOS', "", { stderr => 1 },
211use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
212EOS
213 "check special blocks are cleared on error");
59e6df9f
FC
214
215use constant { constant1 => 1, constant2 => 2 };
216{
217 my $w;
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';
225}
7805ed55
FC
226
227package _122845 {
228 our $depth = 0;
229 my $parent; # just to make the sub a closure
230
231 sub {
232 local $depth = $depth + 1;
233 our $ok++, return if $depth == 2;
234
235 ()= $parent; # just to make the sub a closure
236 our $whatever; # this causes the crash
237
238 CORE::__SUB__->();
239 }->();
240};
241is $_122845::ok, 1,
242 '[perl #122845] no crash in closure recursion with our-vars';
a70f21d0
FC
243
244() = *predeclared; # vivify the glob at compile time
245sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
246sub predeclared {
247 CORE::state $x = 42;
248 sub inside_predeclared {
249 is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub';
250 }
251}
252predeclared(); # set $x to 42
253$main::x = $main::x = "You should not see this.";
254inside_predeclared(); # run test
1956db7e 255
a934a4a7
AC
256# RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
257eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
258pass("RT #126845: stub with prototype, then with attribute");
259
260eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
261pass("RT #126845: stub with prototype, then definition with attribute");
262
1956db7e
DM
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.
266
267{
268 package RT124156;
269
270 sub TIEHASH { bless({}, $_[0]) }
271 sub EXISTS { 0 }
272 sub FETCH { undef }
273 sub STORE { }
274 sub DELETE { die "outer\n" }
275
276 my @value;
277 eval {
278 @value = sub {
279 @value = sub {
280 my %a;
281 tie %a, "RT124156";
282 local $a{foo} = "bar";
283 die "inner";
284 ("dd2a", "dd2b");
285 }->();
286 ("cc3a", "cc3b");
287 }->();
288 };
289 ::is($@, "outer\n", "RT124156 plain");
290
291 my $destroyed = 0;
292 sub DESTROY { $destroyed = 1 }
293
294 sub f {
295 my $x;
296 my $f = sub {
297 $x = 1; # force closure
298 my %a;
299 tie %a, "RT124156";
300 local $a{foo} = "bar";
301 die "inner";
302 };
303 bless $f, 'RT124156';
304 $f->();
305 }
306
307 eval { f(); };
308 # as opposed to $@ eq "Can't undef active subroutine"
309 ::is($@, "outer\n", "RT124156 depth");
310 ::is($destroyed, 1, "RT124156 freed cv");
311}
6228a1e1 312
3b21fb5d
DM
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.
319
320{
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 }
325
326 my $y;
327 sub f { my $x = 7; eval { g() }; $y = $x }
328 sub g {
329 my $x = 8;
330 my @a;
331 tie @a, "tie_exception";
332 local $a[0];
333 }
334
335 f();
3b21fb5d
DM
336 ::is($y, 7, "tie_exception");
337}
338
6228a1e1
DM
339
340# check that return pops extraneous stuff from the stack
341
342sub check_ret {
343 # the extra scopes push contexts and extra SVs on the stack
344 {
345 my @a = map $_ + 20, @_;
346 for ('x') {
347 return if defined $_[0] && $_[0] < 0;
348 }
349 for ('y') {
350 check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5);
351 }
352 }
353}
354
355is(scalar check_ret(), undef, "check_ret() scalar");
356is(scalar check_ret(5), 25, "check_ret(5) scalar");
357is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar");
358is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar");
359is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar");
360is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar");
361
362is(scalar check_ret(-1), undef, "check_ret(-1) scalar");
363is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar");
364
365is(join('-', 10, check_ret()), "10", "check_ret() list");
366is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list");
367is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list");
368is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list");
369is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list");
370is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
371
372is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list");
373is(join('-', 10, check_ret(-1,5)), "10", "check_ret(-1,5) list");
3089a108
DM
374
375# a sub without nested scopes that still leaves rubbish on the stack
376# which needs popping
377{
378 my @res = sub {
379 my $false;
380 # conditional leaves rubbish on stack
381 return @_ unless $false and $false;
382 1;
383 }->('a','b');
384 is(join('-', @res), "a-b", "unnested rubbish");
385}
b28bb06c
DM
386
387# a sub should copy returned PADTMPs
388
389{
390 sub f99 { $_[0] . "x" };
391 my $a = [ f99(1), f99(2) ];
392 is("@$a", "1x 2x", "PADTMPs copied on return");
393}
f7a874b8
DM
394
395# A sub should FREETMPS on exit
396# RT #124248
397
398{
399 package p124248;
400 my $d = 0;
401 sub DESTROY { $d++ }
402 sub f { ::is($d, 1, "RT 124248"); }
403 sub g { !!(my $x = bless []); }
404 f(g());
405}