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 => 61);
  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 }