[perl5.git] / t / op / sub.t

#!./perl -w

BEGIN {
    chdir 't' if -d 't';
    require './test.pl';
    set_up_inc('../lib');
}

plan(tests => 62);

sub empty_sub {}

is(empty_sub,undef,"Is empty");
is(empty_sub(1,2,3),undef,"Is still empty");
@test = empty_sub();
is(scalar(@test), 0, 'Didnt return anything');
@test = empty_sub(1,2,3);
is(scalar(@test), 0, 'Didnt return anything');

# [perl #91844] return should always copy
{
    $foo{bar} = 7;
    for my $x ($foo{bar}) {
	# Pity test.pl doesnt have isn't.
	isnt \sub { delete $foo{bar} }->(), \$x,
	   'result of delete(helem) is copied when returned';
    }
    $foo{bar} = 7;
    for my $x ($foo{bar}) {
	isnt \sub { return delete $foo{bar} }->(), \$x,
	   'result of delete(helem) is copied when explicitly returned';
    }
    my $x;
    isnt \sub { delete $_[0] }->($x), \$x,
      'result of delete(aelem) is copied when returned';
    isnt \sub { return delete $_[0] }->($x), \$x,
      'result of delete(aelem) is copied when explicitly returned';
    isnt \sub { ()=\@_; shift }->($x), \$x,
      'result of shift is copied when returned';
    isnt \sub { ()=\@_; return shift }->($x), \$x,
      'result of shift is copied when explicitly returned';

    $foo{bar} = 7;
    my $r = \$foo{bar};
    sub {
        $$r++;
        isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
    }->(sub { delete $foo{bar} }->());
}

fresh_perl_is
  <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
*foo = \&baz;
*bar = *foo;
eval 'sub bar { print +(caller 0)[3], "\n" }';
bar();
end

fresh_perl_is
  <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
my $sub = sub { 4 };
*foo = $sub;
*bar = *foo;
undef &$sub;
eval 'sub bar { print +(caller 0)[3], "\n" }';
&$sub;
undef *foo;
undef *bar;
print "ok\n";
end

# The outer call sets the scalar returned by ${\""}.${\""} to the current
# package name.
# The inner call sets it to "road".
# Each call records the value twice, the outer call surrounding the inner
# call.  In 5.10-5.18 under ithreads, what gets pushed is
# qw(main road road road) because the inner call is clobbering the same
# scalar.  If __PACKAGE__ is changed to "main", it works, the last element
# becoming "main".
my @scratch;
sub a {
  for (${\""}.${\""}) {
    $_ = $_[0];
    push @scratch, $_;
    a("road",1) unless $_[1];
    push @scratch, $_;
  }
}
a(__PACKAGE__);
require Config;
is "@scratch", "main road road main",
   'recursive calls do not share shared-hash-key TARGs';

# Another test for the same bug, that does not rely on foreach.  It depends
# on ref returning a shared hash key TARG.
undef @scratch;
sub b {
    my ($pack, $depth) = @_;
    my $o = bless[], $pack;
    $pack++;
    push @scratch, (ref $o, $depth||b($pack,$depth+1))[0];
}
b('n',0);
is "@scratch", "o n", 
   'recursive calls do not share shared-hash-key TARGs (2)';

# [perl #78194] @_ aliasing op return values
sub { is \$_[0], \$_[0],
        '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
 ->("${\''}");

# The return statement should make no difference in this case:
sub not_constant () {        42 }
sub not_constantr() { return 42 }
use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
my sub not_constantm () {        42 }
my sub not_constantmr() { return 42 }
eval { ${\not_constant}++ };
is $@, "", 'sub (){42} returns a mutable value';
eval { ${\not_constantr}++ };
is $@, "", 'sub (){ return 42 } returns a mutable value';
eval { ${\not_constantm}++ };
is $@, "", 'my sub (){42} returns a mutable value';
eval { ${\not_constantmr}++ };
is $@, "", 'my sub (){ return 42 } returns a mutable value';
is eval {
    sub Crunchy () { 1 }
    sub Munchy { $_[0] = 2 }
    eval "Crunchy"; # test that freeing this op does not turn off PADTMP
    Munchy(Crunchy);
} || $@, 2, 'freeing ops does not make sub(){42} immutable';

# &xsub when @_ has nonexistent elements
{
    no warnings "uninitialized";
    local @_ = ();
    $#_++;
    &utf8::encode;
    is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
    is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
}

# &xsub when @_ itself does not exist
undef *_;
eval { &utf8::encode };
# The main thing we are testing is that it did not crash.  But make sure 
# *_{ARRAY} was untouched, too.
is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist';

# We do not want re.pm loaded at this point.  Move this test up or find
# another XSUB if this fails.
ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
{
    sub re::regmust{}
    bless \&re::regmust;
    DESTROY {
        no warnings 'redefine', 'prototype';
        my $str1 = "$_[0]";
        *re::regmust = sub{}; # GvSV had no refcount, so this freed it
        my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
        @str = ($str1, $str2);
    }
    local $^W; # Suppress redef warnings in XSLoader
    require re;
    is $str[1], $str[0],
      'XSUB clobbering sub whose DESTROY assigns to the glob';
}
{
    no warnings 'redefine';
    sub foo {}
    bless \&foo, 'newATTRSUBbug';
    sub newATTRSUBbug::DESTROY {
        my $str1 = "$_[0]";
        *foo = sub{}; # GvSV had no refcount, so this freed it
        my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
        @str = ($str1, $str2);
    }
    splice @str;
    eval "sub foo{}";
    is $str[1], $str[0],
      'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
}

# [perl #122107] previously this would return
#  Subroutine BEGIN redefined at (eval 2) line 2.
fresh_perl_is(<<'EOS', "", { stderr => 1 },
use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
EOS
	       "check special blocks are cleared on error");

use constant { constant1 => 1, constant2 => 2 };
{
    my $w;
    local $SIG{__WARN__} = sub { $w++ };
    eval 'sub constant1; sub constant2($)';
    is eval '&constant1', '1',
      'stub re-declaration of constant with no prototype';
    is eval '&constant2', '2',
      'stub re-declaration of constant with wrong prototype';
    is $w, 2, 'two warnings from the above';
}

package _122845 {
    our $depth = 0;
    my $parent; # just to make the sub a closure

    sub {
	local $depth = $depth + 1;
	our $ok++, return if $depth == 2;

	()= $parent;  # just to make the sub a closure
	our $whatever; # this causes the crash

	CORE::__SUB__->();
    }->();
};
is $_122845::ok, 1,
  '[perl #122845] no crash in closure recursion with our-vars';

() = *predeclared; # vivify the glob at compile time
sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
sub predeclared {
    CORE::state $x = 42;
    sub inside_predeclared {
	is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub';
    }
}
predeclared(); # set $x to 42
$main::x = $main::x = "You should not see this.";
inside_predeclared(); # run test

# RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
pass("RT #126845: stub with prototype, then with attribute");

eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
pass("RT #126845: stub with prototype, then definition with attribute");

# RT #124156 death during unwinding causes crash
# the tie allows us to trigger another die while cleaning up the stack
# from an earlier die.

{
    package RT124156;

    sub TIEHASH { bless({}, $_[0]) }
    sub EXISTS { 0 }
    sub FETCH { undef }
    sub STORE { }
    sub DELETE { die "outer\n" }

    my @value;
    eval {
        @value = sub {
            @value = sub {
                my %a;
                tie %a, "RT124156";
                local $a{foo} = "bar";
                die "inner";
                ("dd2a", "dd2b");
            }->();
            ("cc3a", "cc3b");
        }->();
    };
    ::is($@, "outer\n", "RT124156 plain");

    my $destroyed = 0;
    sub DESTROY { $destroyed = 1 }

    sub f {
        my $x;
        my $f = sub {
            $x = 1; # force closure
            my %a;
            tie %a, "RT124156";
            local $a{foo} = "bar";
            die "inner";
        };
        bless $f, 'RT124156';
        $f->();
    }

    eval { f(); };
    # as opposed to $@ eq "Can't undef active subroutine"
    ::is($@, "outer\n", "RT124156 depth");
    ::is($destroyed, 1, "RT124156 freed cv");
}

# trapping dying while popping a scope needs to have the right pad at all
# times. Localising a tied array then dying in STORE raises an exception
# while leaving g(). Note that using an object and destructor wouldn't be
# sufficient since DESTROY is called with call_sv(...,G_EVAL).
# We make sure that the first item in every sub's pad is a lexical with
# different values per sub.

{
    package tie_exception;
    sub TIEARRAY { my $x = 4; bless [0] }
    sub FETCH    { my $x = 5; 1 }
    sub STORE    { my $x = 6; die if $_[0][0]; $_[0][0] = 1 }

    my $y;
    sub f { my $x = 7; eval { g() }; $y = $x }
    sub g {
        my $x = 8;
        my @a;
        tie @a, "tie_exception";
        local $a[0];
    }

    f();
    ::is($y, 7, "tie_exception");
}


# check that return pops extraneous stuff from the stack

sub check_ret {
    # the extra scopes push contexts and extra SVs on the stack
    {
        my @a = map $_ + 20, @_;
        for ('x') {
            return if defined $_[0] && $_[0] < 0;
        }
        for ('y') {
            check_ret(1, do { (2,3,4, return @a ? @a[0..$#a] : ()) }, 4.5);
        }
    }
}

is(scalar check_ret(),          undef, "check_ret() scalar");
is(scalar check_ret(5),         25,    "check_ret(5) scalar");
is(scalar check_ret(5,6),       26,    "check_ret(5,6) scalar");
is(scalar check_ret(5,6,7),     27,    "check_ret(5,6,7) scalar");
is(scalar check_ret(5,6,7,8),   28,    "check_ret(5,6,7,8) scalar");
is(scalar check_ret(5,6,7,8,9), 29,    "check_ret(5,6,7,8,9) scalar");

is(scalar check_ret(-1),        undef, "check_ret(-1) scalar");
is(scalar check_ret(-1,5),      undef, "check_ret(-1,5) scalar");

is(join('-', 10, check_ret()),          "10",                "check_ret() list");
is(join('-', 10, check_ret(5)),         "10-25",             "check_ret(5) list");
is(join('-', 10, check_ret(5,6)),       "10-25-26",          "check_ret(5,6) list");
is(join('-', 10, check_ret(5,6,7)),     "10-25-26-27",       "check_ret(5,6,7) list");
is(join('-', 10, check_ret(5,6,7,8)),   "10-25-26-27-28",    "check_ret(5,6,7,8) list");
is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");

is(join('-', 10, check_ret(-1)),        "10",  "check_ret(-1) list");
is(join('-', 10, check_ret(-1,5)),      "10",  "check_ret(-1,5) list");

# a sub without nested scopes that still leaves rubbish on the stack
# which needs popping
{
    my @res = sub {
        my $false;
        # conditional leaves rubbish on stack
        return @_ unless $false and $false;
        1;
    }->('a','b');
    is(join('-', @res), "a-b", "unnested rubbish");
}

# a sub should copy returned PADTMPs

{
    sub f99 { $_[0] . "x" };
    my $a = [ f99(1), f99(2) ];
    is("@$a", "1x 2x", "PADTMPs copied on return");
}

# A sub should FREETMPS on exit
# RT #124248

{
    package p124248;
    my $d = 0;
    sub DESTROY { $d++ }
    sub f { ::is($d, 1, "RT 124248"); }
    sub g { !!(my $x = bless []); }
    f(g());
}

# return should have the right PL_curpm while copying its return args

sub curpm {
    "b" =~ /(.)/;
    {
        "c" =~ /(.)/;
        return $1;
    }
}
"a" =~ /(.)/;
is(curpm(), 'c', 'return and PL_curpm');

sub rt_129916 { 42 }
is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)';
{
    package RT129916;
    sub foo { 42 }
}
{
    local $::TODO = "disabled for now";
    is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
}

# Calling xsub via ampersand syntax when @_ has holes
SKIP: {
    skip "no XS::APItest on miniperl" if is_miniperl;
    skip "XS::APItest not available", 1 if ! eval { require XS::APItest };
    local *_;
    $_[1] = 1;
    &XS::APItest::unshift_and_set_defav;
    is "@_", "42 43 1"
}

# [perl #129090] Crashes and hangs
watchdog 10;
{ no warnings;
  eval '$a=qq|a$a|;my sub b;%c;sub c{sub b;sub c}';
}
eval '
   ()= %d;
   {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
   {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
   {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u);}
   CORE::state sub b; sub d { sub b {} sub d }
 ';
eval '()=%e; sub e { sub e; eval q|$x| } e;';
Commit	Line	Data
f7218ed4	1	#!./perl -w
2d981f27 AB	2
	3	BEGIN {
	4	chdir 't' if -d 't';
f7218ed4	5	require './test.pl';
43ece5b1	6	set_up_inc('../lib');
2d981f27 AB	7	}
2d981f27 AB	8
7406cffe	9	plan(tests => 62);
2d981f27 AB	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
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
	51	fresh_perl_is
	52	<<'end', "main::foo\n", {}, 'sub redefinition sets CvGV';
	53	*foo = \&baz;
	54	bar = foo;
	55	eval 'sub bar { print +(caller 0)[3], "\n" }';
	56	bar();
	57	end
e52de15a FC	58
	59	fresh_perl_is
	60	<<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
	61	my $sub = sub { 4 };
	62	*foo = $sub;
	63	bar = foo;
	64	undef &$sub;
	65	eval 'sub bar { print +(caller 0)[3], "\n" }';
	66	&$sub;
	67	undef *foo;
	68	undef *bar;
	69	print "ok\n";
	70	end
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".
	80	my @scratch;
	81	sub a {
	82	for (${\""}.${\""}) {
	83	$_ = $_[0];
	84	push @scratch, $_;
	85	a("road",1) unless $_[1];
	86	push @scratch, $_;
	87	}
	88	}
	89	a(__PACKAGE__);
	90	require Config;
7f6ba6d2 FC	91	is "@scratch", "main road road main",
7f6ba6d2 FC	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.
	96	undef @scratch;
	97	sub b {
	98	my ($pack, $depth) = @_;
	99	my $o = bless[], $pack;
	100	$pack++;
	101	push @scratch, (ref $o, $depth\|\|b($pack,$depth+1))[0];
	102	}
	103	b('n',0);
8e079c2a FC	104	is "@scratch", "o n",
8e079c2a FC	105	'recursive calls do not share shared-hash-key TARGs (2)';
2d885586	106
2d885586 FC	107	# [perl #78194] @_ aliasing op return values
	108	sub { 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:
	113	sub not_constant () { 42 }
	114	sub not_constantr() { return 42 }
d2440203 FC	115	use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
	116	my sub not_constantm () { 42 }
	117	my sub not_constantmr() { return 42 }
b784b94c FC	118	eval { ${\not_constant}++ };
b784b94c FC	119	is $@, "", 'sub (){42} returns a mutable value';
b784b94c FC	120	eval { ${\not_constantr}++ };
b784b94c FC	121	is $@, "", 'sub (){ return 42 } returns a mutable value';
d2440203 FC	122	eval { ${\not_constantm}++ };
	123	is $@, "", 'my sub (){42} returns a mutable value';
	124	eval { ${\not_constantmr}++ };
	125	is $@, "", 'my sub (){ return 42 } returns a mutable value';
0ad6fa35 FC	126	is 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
	144	undef *_;
	145	eval { &utf8::encode };
	146	# The main thing we are testing is that it did not crash. But make sure
	147	# *_{ARRAY} was untouched, too.
	148	is *_{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.
	152	ok !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.
	186	fresh_perl_is(<<'EOS', "", { stderr => 1 },
	187	use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
	188	EOS
	189	"check special blocks are cleared on error");
59e6df9f FC	190
	191	use 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
	203	package _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	};
	217	is $_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
	221	sub predeclared; # now we have a CV stub with no body (incorporeal? :-)
	222	sub 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	}
	228	predeclared(); # set $x to 42
	229	$main::x = $main::x = "You should not see this.";
	230	inside_predeclared(); # run test
1956db7e	231
a934a4a7 AC	232	# RT #126845: this used to fail an assertion in Perl_newATTRSUB_x()
	233	eval 'sub rt126845_1 (); sub rt126845_1 () :lvalue';
	234	pass("RT #126845: stub with prototype, then with attribute");
	235
	236	eval 'sub rt126845_2 (); sub rt126845_2 () :lvalue {}';
	237	pass("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
	318	sub 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
	331	is(scalar check_ret(), undef, "check_ret() scalar");
	332	is(scalar check_ret(5), 25, "check_ret(5) scalar");
	333	is(scalar check_ret(5,6), 26, "check_ret(5,6) scalar");
	334	is(scalar check_ret(5,6,7), 27, "check_ret(5,6,7) scalar");
	335	is(scalar check_ret(5,6,7,8), 28, "check_ret(5,6,7,8) scalar");
	336	is(scalar check_ret(5,6,7,8,9), 29, "check_ret(5,6,7,8,9) scalar");
	337
	338	is(scalar check_ret(-1), undef, "check_ret(-1) scalar");
	339	is(scalar check_ret(-1,5), undef, "check_ret(-1,5) scalar");
	340
	341	is(join('-', 10, check_ret()), "10", "check_ret() list");
	342	is(join('-', 10, check_ret(5)), "10-25", "check_ret(5) list");
	343	is(join('-', 10, check_ret(5,6)), "10-25-26", "check_ret(5,6) list");
	344	is(join('-', 10, check_ret(5,6,7)), "10-25-26-27", "check_ret(5,6,7) list");
	345	is(join('-', 10, check_ret(5,6,7,8)), "10-25-26-27-28", "check_ret(5,6,7,8) list");
	346	is(join('-', 10, check_ret(5,6,7,8,9)), "10-25-26-27-28-29", "check_ret(5,6,7,8,9) list");
	347
	348	is(join('-', 10, check_ret(-1)), "10", "check_ret(-1) list");
	349	is(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
	385	sub curpm {
	386	"b" =~ /(.)/;
	387	{
	388	"c" =~ /(.)/;
	389	return $1;
	390	}
	391	}
	392	"a" =~ /(.)/;
	393	is(curpm(), 'c', 'return and PL_curpm');
6da13066	394
eb6d9f5b LM	395	sub rt_129916 { 42 }
	396	is 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
	407	SKIP: {
	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
	417	watchdog 10;
	418	{ no warnings;
	419	eval '$a=qq\|a$a\|;my sub b;%c;sub c{sub b;sub c}';
	420	}
	421	eval '
	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	';
	428	eval '()=%e; sub e { sub e; eval q\|$x\| } e;';