This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_entersub: remove extraneous SAVETMPS
[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
a934a4a7 9plan(tests => 57);
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
FC
43
44# [perl #81944] return should always copy
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';
66}
f6894bc8
FC
67
68fresh_perl_is
69 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
70*foo = \&baz;
71*bar = *foo;
72eval 'sub bar { print +(caller 0)[3], "\n" }';
73bar();
74end
e52de15a
FC
75
76fresh_perl_is
77 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
78my $sub = sub { 4 };
79*foo = $sub;
80*bar = *foo;
81undef &$sub;
82eval 'sub bar { print +(caller 0)[3], "\n" }';
83&$sub;
84undef *foo;
85undef *bar;
86print "ok\n";
87end
7f6ba6d2
FC
88
89# The outer call sets the scalar returned by ${\""}.${\""} to the current
90# package name.
91# The inner call sets it to "road".
92# Each call records the value twice, the outer call surrounding the inner
93# call. In 5.10-5.18 under ithreads, what gets pushed is
94# qw(main road road road) because the inner call is clobbering the same
95# scalar. If __PACKAGE__ is changed to "main", it works, the last element
96# becoming "main".
97my @scratch;
98sub a {
99 for (${\""}.${\""}) {
100 $_ = $_[0];
101 push @scratch, $_;
102 a("road",1) unless $_[1];
103 push @scratch, $_;
104 }
105}
106a(__PACKAGE__);
107require Config;
7f6ba6d2
FC
108is "@scratch", "main road road main",
109 'recursive calls do not share shared-hash-key TARGs';
8e079c2a
FC
110
111# Another test for the same bug, that does not rely on foreach. It depends
112# on ref returning a shared hash key TARG.
113undef @scratch;
114sub b {
115 my ($pack, $depth) = @_;
116 my $o = bless[], $pack;
117 $pack++;
118 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
119}
120b('n',0);
8e079c2a
FC
121is "@scratch", "o n",
122 'recursive calls do not share shared-hash-key TARGs (2)';
2d885586 123
2d885586
FC
124# [perl #78194] @_ aliasing op return values
125sub { is \$_[0], \$_[0],
126 '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
127 ->("${\''}");
b784b94c
FC
128
129# The return statement should make no difference in this case:
130sub not_constant () { 42 }
131sub not_constantr() { return 42 }
d2440203
FC
132use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
133my sub not_constantm () { 42 }
134my sub not_constantmr() { return 42 }
b784b94c
FC
135eval { ${\not_constant}++ };
136is $@, "", 'sub (){42} returns a mutable value';
b784b94c
FC
137eval { ${\not_constantr}++ };
138is $@, "", 'sub (){ return 42 } returns a mutable value';
d2440203
FC
139eval { ${\not_constantm}++ };
140is $@, "", 'my sub (){42} returns a mutable value';
141eval { ${\not_constantmr}++ };
142is $@, "", 'my sub (){ return 42 } returns a mutable value';
0ad6fa35
FC
143is eval {
144 sub Crunchy () { 1 }
145 sub Munchy { $_[0] = 2 }
146 eval "Crunchy"; # test that freeing this op does not turn off PADTMP
147 Munchy(Crunchy);
148} || $@, 2, 'freeing ops does not make sub(){42} immutable';
137da2b0 149
dd2a7f90
FC
150# &xsub when @_ has nonexistent elements
151{
152 no warnings "uninitialized";
153 local @_ = ();
154 $#_++;
155 &utf8::encode;
156 is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
157 is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
158}
8c9d3376
FC
159
160# &xsub when @_ itself does not exist
161undef *_;
162eval { &utf8::encode };
163# The main thing we are testing is that it did not crash. But make sure
164# *_{ARRAY} was untouched, too.
165is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
7004ee49
FC
166
167# We do not want re.pm loaded at this point. Move this test up or find
168# another XSUB if this fails.
169ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
170{
7004ee49
FC
171 sub re::regmust{}
172 bless \&re::regmust;
173 DESTROY {
a28a9f6b 174 no warnings 'redefine', 'prototype';
7004ee49
FC
175 my $str1 = "$_[0]";
176 *re::regmust = sub{}; # GvSV had no refcount, so this freed it
177 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0)
178 @str = ($str1, $str2);
179 }
a28a9f6b 180 local $^W; # Suppress redef warnings in XSLoader
7004ee49
FC
181 require re;
182 is $str[1], $str[0],
183 'XSUB clobbering sub whose DESTROY assigns to the glob';
184}
a6181857
FC
185{
186 no warnings 'redefine';
187 sub foo {}
188 bless \&foo, 'newATTRSUBbug';
189 sub newATTRSUBbug::DESTROY {
190 my $str1 = "$_[0]";
191 *foo = sub{}; # GvSV had no refcount, so this freed it
192 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0)
193 @str = ($str1, $str2);
194 }
195 splice @str;
196 eval "sub foo{}";
197 is $str[1], $str[0],
198 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
199}
2806bfd8 200
2806bfd8
TC
201# [perl #122107] previously this would return
202# Subroutine BEGIN redefined at (eval 2) line 2.
203fresh_perl_is(<<'EOS', "", { stderr => 1 },
204use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
205EOS
206 "check special blocks are cleared on error");
59e6df9f
FC
207
208use constant { constant1 => 1, constant2 => 2 };
209{
210 my $w;
211 local $SIG{__WARN__} = sub { $w++ };
212 eval 'sub constant1; sub constant2($)';
213 is eval '&constant1', '1',
214 'stub re-declaration of constant with no prototype';
215 is eval '&constant2', '2',
216 'stub re-declaration of constant with wrong prototype';
217 is $w, 2, 'two warnings from the above';
218}
7805ed55
FC
219
220package _122845 {
221 our $depth = 0;
222 my $parent; # just to make the sub a closure
223
224 sub {
225 local $depth = $depth + 1;
226 our $ok++, return if $depth == 2;
227
228 ()= $parent; # just to make the sub a closure
229 our $whatever; # this causes the crash
230
231 CORE::__SUB__->();
232 }->();
233};
234is $_122845::ok, 1,
235 '[perl #122845] no crash in closure recursion with our-vars';
a70f21d0
FC
236
237() = *predeclared; # vivify the glob at compile time
238sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
239sub predeclared {
240 CORE::state $x = 42;
241 sub inside_predeclared {
242 is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub';
243 }
244}
245predeclared(); # set $x to 42
246$main::x = $main::x = "You should not see this.";
247inside_predeclared(); # run test
1956db7e 248
a934a4a7
AC
249# RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
250eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
251pass("RT #126845: stub with prototype, then with attribute");
252
253eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
254pass("RT #126845: stub with prototype, then definition with attribute");
255
1956db7e
DM
256# RT #124156 death during unwinding causes crash
257# the tie allows us to trigger another die while cleaning up the stack
258# from an earlier die.
259
260{
261 package RT124156;
262
263 sub TIEHASH { bless({}, $_[0]) }
264 sub EXISTS { 0 }
265 sub FETCH { undef }
266 sub STORE { }
267 sub DELETE { die "outer\n" }
268
269 my @value;
270 eval {
271 @value = sub {
272 @value = sub {
273 my %a;
274 tie %a, "RT124156";
275 local $a{foo} = "bar";
276 die "inner";
277 ("dd2a", "dd2b");
278 }->();
279 ("cc3a", "cc3b");
280 }->();
281 };
282 ::is($@, "outer\n", "RT124156 plain");
283
284 my $destroyed = 0;
285 sub DESTROY { $destroyed = 1 }
286
287 sub f {
288 my $x;
289 my $f = sub {
290 $x = 1; # force closure
291 my %a;
292 tie %a, "RT124156";
293 local $a{foo} = "bar";
294 die "inner";
295 };
296 bless $f, 'RT124156';
297 $f->();
298 }
299
300 eval { f(); };
301 # as opposed to $@ eq "Can't undef active subroutine"
302 ::is($@, "outer\n", "RT124156 depth");
303 ::is($destroyed, 1, "RT124156 freed cv");
304}
6228a1e1
DM
305
306
307# check that return pops extraneous stuff from the stack
308
309sub check_ret {
310 # the extra scopes push contexts and extra SVs on the stack
311 {
312 my @a = map $_ + 20, @_;
313 for ('x') {
314 return if defined $_[0] && $_[0] < 0;
315 }
316 for ('y') {
317 check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5);
318 }
319 }
320}
321
322is(scalar check_ret(), undef, "check_ret() scalar");
323is(scalar check_ret(5), 25, "check_ret(5) scalar");
324is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar");
325is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar");
326is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar");
327is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar");
328
329is(scalar check_ret(-1), undef, "check_ret(-1) scalar");
330is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar");
331
332is(join('-', 10, check_ret()), "10", "check_ret() list");
333is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list");
334is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list");
335is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list");
336is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list");
337is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
338
339is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list");
340is(join('-', 10, check_ret(-1,5)), "10", "check_ret(-1,5) list");