This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5c501b181ee5817d4b6e5a73f76a8808057f6610
[perl5.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 => 65);
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 # 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 }
43
44 # [perl #91844] 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
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} }->());
73 }
74
75 fresh_perl_is
76   <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
77 *foo = \&baz;
78 *bar = *foo;
79 eval 'sub bar { print +(caller 0)[3], "\n" }';
80 bar();
81 end
82
83 fresh_perl_is
84   <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
85 my $sub = sub { 4 };
86 *foo = $sub;
87 *bar = *foo;
88 undef &$sub;
89 eval 'sub bar { print +(caller 0)[3], "\n" }';
90 &$sub;
91 undef *foo;
92 undef *bar;
93 print "ok\n";
94 end
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".
104 my @scratch;
105 sub a {
106   for (${\""}.${\""}) {
107     $_ = $_[0];
108     push @scratch, $_;
109     a("road",1) unless $_[1];
110     push @scratch, $_;
111   }
112 }
113 a(__PACKAGE__);
114 require Config;
115 is "@scratch", "main road road main",
116    'recursive calls do not share shared-hash-key TARGs';
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.
120 undef @scratch;
121 sub b {
122     my ($pack, $depth) = @_;
123     my $o = bless[], $pack;
124     $pack++;
125     push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
126 }
127 b('n',0);
128 is "@scratch", "o n", 
129    'recursive calls do not share shared-hash-key TARGs (2)';
130
131 # [perl #78194] @_ aliasing op return values
132 sub { is \$_[0], \$_[0],
133         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
134  ->("${\''}");
135
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';
150 is 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';
156
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 }
166
167 # &xsub when @_ itself does not exist
168 undef *_;
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';
173
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';
177 {
178     sub re::regmust{}
179     bless \&re::regmust;
180     DESTROY {
181         no warnings 'redefine', 'prototype';
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     }
187     local $^W; # Suppress redef warnings in XSLoader
188     require re;
189     is $str[1], $str[0],
190       'XSUB clobbering sub whose DESTROY assigns to the glob';
191 }
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 }
207
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/;
212 EOS
213                "check special blocks are cleared on error");
214
215 use 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 }
226
227 package _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 };
241 is $_122845::ok, 1,
242   '[perl #122845] no crash in closure recursion with our-vars';
243
244 () = *predeclared; # vivify the glob at compile time
245 sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
246 sub 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 }
252 predeclared(); # set $x to 42
253 $main::x = $main::x = "You should not see this.";
254 inside_predeclared(); # run test
255
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");
259
260 eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
261 pass("RT #126845: stub with prototype, then definition with attribute");
262
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 }
312
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();
336     ::is($y, 7, "tie_exception");
337 }
338
339
340 # check that return pops extraneous stuff from the stack
341
342 sub 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
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");
361
362 is(scalar check_ret(-1),        undef, "check_ret(-1) scalar");
363 is(scalar check_ret(-1,5),      undef, "check_ret(-1,5) scalar");
364
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");
371
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");
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 }
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 }
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 }
406
407 # return should have the right PL_curpm while copying its return args
408
409 sub curpm {
410     "b" =~ /(.)/;
411     {
412         "c" =~ /(.)/;
413         return $1;
414     }
415 }
416 "a" =~ /(.)/;
417 is(curpm(), 'c', 'return and PL_curpm');
418
419 sub rt_129916 { 42 }
420 is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)';
421 {
422     package RT129916;
423     sub foo { 42 }
424 }
425 {
426     local $TODO = "CV symbol table optimization only works in main:: [perl #129916]";
427     is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
428 }
429
430 # [perl #129090] Crashes and hangs
431 watchdog 10;
432 { no warnings;
433   eval '$a=qq|a$a|;my sub b;%c;sub c{sub b;sub c}';
434 }
435 eval '
436    ()= %d;
437    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
438    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
439    {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
440    CORE::state sub b; sub d { sub b {} sub d }
441  ';
442 eval '()=%e; sub e { sub e; eval q|$x| } e;';