This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Perl_gp_free() use PL_tmps_stack to avoid freeing glob entries immediately.
[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
7406cffe 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
a45346a4 20# [perl #91844] return should always copy
3ed94dc0
FC
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';
5e267fb8
DM
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} }->());
3ed94dc0 49}
f6894bc8
FC
50
51fresh_perl_is
52 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
53*foo = \&baz;
54*bar = *foo;
55eval 'sub bar { print +(caller 0)[3], "\n" }';
56bar();
57end
e52de15a
FC
58
59fresh_perl_is
60 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
61my $sub = sub { 4 };
62*foo = $sub;
63*bar = *foo;
64undef &$sub;
65eval 'sub bar { print +(caller 0)[3], "\n" }';
66&$sub;
67undef *foo;
68undef *bar;
69print "ok\n";
70end
7f6ba6d2
FC
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".
80my @scratch;
81sub a {
82 for (${\""}.${\""}) {
83 $_ = $_[0];
84 push @scratch, $_;
85 a("road",1) unless $_[1];
86 push @scratch, $_;
87 }
88}
89a(__PACKAGE__);
90require Config;
7f6ba6d2
FC
91is "@scratch", "main road road main",
92 'recursive calls do not share shared-hash-key TARGs';
8e079c2a
FC
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.
96undef @scratch;
97sub b {
98 my ($pack, $depth) = @_;
99 my $o = bless[], $pack;
100 $pack++;
101 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
102}
103b('n',0);
8e079c2a
FC
104is "@scratch", "o n",
105 'recursive calls do not share shared-hash-key TARGs (2)';
2d885586 106
2d885586
FC
107# [perl #78194] @_ aliasing op return values
108sub { is \$_[0], \$_[0],
109 '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
110 ->("${\''}");
b784b94c
FC
111
112# The return statement should make no difference in this case:
113sub not_constant () { 42 }
114sub not_constantr() { return 42 }
d2440203
FC
115use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
116my sub not_constantm () { 42 }
117my sub not_constantmr() { return 42 }
b784b94c
FC
118eval { ${\not_constant}++ };
119is $@, "", 'sub (){42} returns a mutable value';
b784b94c
FC
120eval { ${\not_constantr}++ };
121is $@, "", 'sub (){ return 42 } returns a mutable value';
d2440203
FC
122eval { ${\not_constantm}++ };
123is $@, "", 'my sub (){42} returns a mutable value';
124eval { ${\not_constantmr}++ };
125is $@, "", 'my sub (){ return 42 } returns a mutable value';
0ad6fa35
FC
126is 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';
137da2b0 132
dd2a7f90
FC
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}
8c9d3376
FC
142
143# &xsub when @_ itself does not exist
144undef *_;
145eval { &utf8::encode };
146# The main thing we are testing is that it did not crash. But make sure
147# *_{ARRAY} was untouched, too.
148is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';
7004ee49
FC
149
150# We do not want re.pm loaded at this point. Move this test up or find
151# another XSUB if this fails.
152ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
153{
7004ee49
FC
154 sub re::regmust{}
155 bless \&re::regmust;
156 DESTROY {
a28a9f6b 157 no warnings 'redefine', 'prototype';
7004ee49
FC
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 }
a28a9f6b 163 local $^W; # Suppress redef warnings in XSLoader
7004ee49
FC
164 require re;
165 is $str[1], $str[0],
166 'XSUB clobbering sub whose DESTROY assigns to the glob';
167}
a6181857
FC
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}
2806bfd8 183
2806bfd8
TC
184# [perl #122107] previously this would return
185# Subroutine BEGIN redefined at (eval 2) line 2.
186fresh_perl_is(<<'EOS', "", { stderr => 1 },
187use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
188EOS
189 "check special blocks are cleared on error");
59e6df9f
FC
190
191use 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}
7805ed55
FC
202
203package _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};
217is $_122845::ok, 1,
218 '[perl #122845] no crash in closure recursion with our-vars';
a70f21d0
FC
219
220() = *predeclared; # vivify the glob at compile time
221sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
222sub 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}
228predeclared(); # set $x to 42
229$main::x = $main::x = "You should not see this.";
230inside_predeclared(); # run test
1956db7e 231
a934a4a7
AC
232# RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
233eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
234pass("RT #126845: stub with prototype, then with attribute");
235
236eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
237pass("RT #126845: stub with prototype, then definition with attribute");
238
1956db7e
DM
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}
6228a1e1 288
3b21fb5d
DM
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();
3b21fb5d
DM
312 ::is($y, 7, "tie_exception");
313}
314
6228a1e1
DM
315
316# check that return pops extraneous stuff from the stack
317
318sub 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
331is(scalar check_ret(), undef, "check_ret() scalar");
332is(scalar check_ret(5), 25, "check_ret(5) scalar");
333is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar");
334is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar");
335is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar");
336is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar");
337
338is(scalar check_ret(-1), undef, "check_ret(-1) scalar");
339is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar");
340
341is(join('-', 10, check_ret()), "10", "check_ret() list");
342is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list");
343is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list");
344is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list");
345is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list");
346is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
347
348is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list");
349is(join('-', 10, check_ret(-1,5)), "10", "check_ret(-1,5) list");
3089a108
DM
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}
b28bb06c
DM
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}
f7a874b8
DM
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}
fc6e609e
DM
382
383# return should have the right PL_curpm while copying its return args
384
385sub curpm {
386 "b" =~ /(.)/;
387 {
388 "c" =~ /(.)/;
389 return $1;
390 }
391}
392"a" =~ /(.)/;
393is(curpm(), 'c', 'return and PL_curpm');
6da13066 394
eb6d9f5b
LM
395sub rt_129916 { 42 }
396is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)';
397{
398 package RT129916;
399 sub foo { 42 }
400}
401{
1e2cfe15 402 local $::TODO = "disabled for now";
eb6d9f5b
LM
403 is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
404}
405
7406cffe
FC
406# Calling xsub via ampersand syntax when @_ has holes
407SKIP: {
408 skip "no XS::APItest on miniperl" if is_miniperl;
bbbfd957 409 skip "XS::APItest not available", 1 if ! eval { require XS::APItest };
7406cffe
FC
410 local *_;
411 $_[1] = 1;
412 &XS::APItest::unshift_and_set_defav;
413 is "@_", "42 43 1"
414}
415
6da13066
FC
416# [perl #129090] Crashes and hangs
417watchdog 10;
418{ no warnings;
419 eval '$a=qq|a$a|;my sub b;%c;sub c{sub b;sub c}';
420}
421eval '
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 ';
428eval '()=%e; sub e { sub e; eval q|$x| } e;';