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 => 63);
  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 # [perl #91844] return should always copy
  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';
  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} }->());
  49 }
  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
  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
  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;
  91 is "@scratch", "main road road main",
  92    'recursive calls do not share shared-hash-key TARGs';
  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);
 104 is "@scratch", "o n",
 105    'recursive calls do not share shared-hash-key TARGs (2)';
 106
 107 # [perl #78194] @_ aliasing op return values
 108 sub { is \$_[0], \$_[0],
 109         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
 110  ->("${\''}");
 111
 112 # The return statement should make no difference in this case:
 113 sub not_constant () {        42 }
 114 sub not_constantr() { return 42 }
 115 use feature 'lexical_subs'; no warnings 'experimental::lexical_subs';
 116 my sub not_constantm () {        42 }
 117 my sub not_constantmr() { return 42 }
 118 eval { ${\not_constant}++ };
 119 is $@, "", 'sub (){42} returns a mutable value';
 120 eval { ${\not_constantr}++ };
 121 is $@, "", 'sub (){ return 42 } returns a mutable value';
 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';
 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';
 132
 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 }
 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';
 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 {
 154     sub re::regmust{}
 155     bless \&re::regmust;
 156     DESTROY {
 157         no warnings 'redefine', 'prototype';
 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     }
 163     local $^W; # Suppress redef warnings in XSLoader
 164     require re;
 165     is $str[1], $str[0],
 166       'XSUB clobbering sub whose DESTROY assigns to the glob';
 167 }
 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 }
 183
 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");
 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 }
 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';
 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
 231
 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
 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 }
 288
 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();
 312     ::is($y, 7, "tie_exception");
 313 }
 314
 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");
 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 }
 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 }
 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 }
 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');
 394
 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 {
 402     local $::TODO = "disabled for now";
 403     is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
 404 }
 405
 406 # Calling xsub via ampersand syntax when @_ has holes
 407 SKIP: {
 408     skip "no XS::APItest on miniperl" if is_miniperl;
 409     skip "XS::APItest not available", 1 if ! eval { require XS::APItest };
 410     local *_;
 411     $_[1] = 1;
 412     &XS::APItest::unshift_and_set_defav;
 413     is "@_", "42 43 1"
 414 }
 415
 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;';
 429
 430 fresh_perl_like(
 431     q#<s,,$0[sub{m]]]],}>0,shift#,
 432     qr/^syntax error/,
 433     {},
 434     "GH Issue #16944 - Syntax error with sub and shift causes segfault"
 435 );