t/op/lexsub.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7     *bar::is = *is;
   8     *bar::like = *like;
   9 }
  10 plan 150;
  11
  12 # -------------------- our -------------------- #
  13
  14 {
  15   our sub foo { 42 }
  16   is foo, 42, 'calling our sub from same package';
  17   is &foo, 42, 'calling our sub from same package (amper)';
  18   package bar;
  19   sub bar::foo { 43 }
  20   is foo, 42, 'calling our sub from another package';
  21   is &foo, 42, 'calling our sub from another package (amper)';
  22 }
  23 package bar;
  24 is foo, 43, 'our sub falling out of scope';
  25 is &foo, 43, 'our sub falling out of scope (called via amper)';
  26 package main;
  27 {
  28   sub bar::a { 43 }
  29   our sub a {
  30     if (shift) {
  31       package bar;
  32       is a, 43, 'our sub invisible inside itself';
  33       is &a, 43, 'our sub invisible inside itself (called via amper)';
  34     }
  35     42
  36   }
  37   a(1);
  38   sub bar::b { 43 }
  39   our sub b;
  40   our sub b {
  41     if (shift) {
  42       package bar;
  43       is b, 42, 'our sub visible inside itself after decl';
  44       is &b, 42, 'our sub visible inside itself after decl (amper)';
  45     }
  46     42
  47   }
  48   b(1)
  49 }
  50 sub c { 42 }
  51 sub bar::c { 43 }
  52 {
  53   our sub c;
  54   package bar;
  55   is c, 42, 'our sub foo; makes lex alias for existing sub';
  56   is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)';
  57 }
  58 {
  59   our sub d;
  60   sub bar::d { 'd43' }
  61   package bar;
  62   sub d { 'd42' }
  63   is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}';
  64 }
  65 {
  66   our sub e ($);
  67   is prototype "::e", '$', 'our sub with proto';
  68 }
  69 {
  70   our sub if() { 42 }
  71   my $x = if if if;
  72   is $x, 42, 'lexical subs (even our) override all keywords';
  73   package bar;
  74   my $y = if if if;
  75   is $y, 42, 'our subs from other packages override all keywords';
  76 }
  77 # Interaction with ‘use constant’
  78 {
  79   our sub const; # symtab now has an undefined CV
  80   BEGIN { delete $::{const} } # delete symtab entry; pad entry still exists
  81   use constant const => 3; # symtab now has a scalar ref
  82   # inlining this used to fail an assertion (parentheses necessary):
  83   is(const, 3, 'our sub pointing to "use constant" constant');
  84 }
  85 # our sub and method confusion
  86 sub F::h { 4242 }
  87 {
  88   my $called;
  89   our sub h { ++$called; 4343 };
  90   is((h F),4242, 'our sub symbol translation does not affect meth names');
  91   undef $called;
  92   print "#";
  93   print h F; # follows a different path through yylex to intuit_method
  94   print "\n";
  95   is $called, undef, 'our sub symbol translation & meth names after print'
  96 }
  97 our sub j;
  98 is j
  99   =>, 'j', 'name_of_our_sub <newline> =>  is parsed properly';
 100 sub _cmp { $a cmp $b }
 101 sub bar::_cmp { $b cmp $a }
 102 {
 103   package bar;
 104   our sub _cmp;
 105   package main;
 106   is join(" ", sort _cmp split //, 'oursub'), 'u u s r o b', 'sort our_sub'
 107 }
 108
 109 # -------------------- state -------------------- #
 110
 111 use feature 'state'; # state
 112 {
 113   state sub foo { 44 }
 114   isnt \&::foo, \&foo, 'state sub is not stored in the package';
 115   is foo, 44, 'calling state sub from same package';
 116   is &foo, 44, 'calling state sub from same package (amper)';
 117   package bar;
 118   is foo, 44, 'calling state sub from another package';
 119   is &foo, 44, 'calling state sub from another package (amper)';
 120 }
 121 package bar;
 122 is foo, 43, 'state sub falling out of scope';
 123 is &foo, 43, 'state sub falling out of scope (called via amper)';
 124 {
 125   sub sa { 43 }
 126   state sub sa {
 127     if (shift) {
 128       is sa, 43, 'state sub invisible inside itself';
 129       is &sa, 43, 'state sub invisible inside itself (called via amper)';
 130     }
 131     44
 132   }
 133   sa(1);
 134   sub sb { 43 }
 135   state sub sb;
 136   state sub sb {
 137     if (shift) {
 138       # ‘state sub foo{}’ creates a new pad entry, not reusing the forward
 139       #  declaration.  Being invisible inside itself, it sees the stub.
 140       eval{sb};
 141       like $@, qr/^Undefined subroutine &sb called at /,
 142         'state sub foo {} after forward declaration';
 143       eval{&sb};
 144       like $@, qr/^Undefined subroutine &sb called at /,
 145         'state sub foo {} after forward declaration (amper)';
 146     }
 147     44
 148   }
 149   sb(1);
 150   sub sb2 { 43 }
 151   state sub sb2;
 152   sub sb2 {
 153     if (shift) {
 154       package bar;
 155       is sb2, 44, 'state sub visible inside itself after decl';
 156       is &sb2, 44, 'state sub visible inside itself after decl (amper)';
 157     }
 158     44
 159   }
 160   sb2(1);
 161   state sub sb3;
 162   {
 163     state sub sb3 { # new pad entry
 164       # The sub containing this comment is invisible inside itself.
 165       # So this one here will assign to the outer pad entry:
 166       sub sb3 { 47 }
 167     }
 168   }
 169   is eval{sb3}, 47,
 170     'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
 171   # Same test again, but inside an anonymous sub
 172   sub {
 173     state sub sb4;
 174     {
 175       state sub sb4 {
 176         sub sb4 { 47 }
 177       }
 178     }
 179     is sb4, 47,
 180       'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
 181   }->();
 182 }
 183 sub sc { 43 }
 184 {
 185   state sub sc;
 186   eval{sc};
 187   like $@, qr/^Undefined subroutine &sc called at /,
 188      'state sub foo; makes no lex alias for existing sub';
 189   eval{&sc};
 190   like $@, qr/^Undefined subroutine &sc called at /,
 191      'state sub foo; makes no lex alias for existing sub (amper)';
 192 }
 193 package main;
 194 {
 195   state sub se ($);
 196   is prototype eval{\&se}, '$', 'state sub with proto';
 197   is prototype "se", undef, 'prototype "..." ignores state subs';
 198 }
 199 {
 200   state sub if() { 44 }
 201   my $x = if if if;
 202   is $x, 44, 'state subs override all keywords';
 203   package bar;
 204   my $y = if if if;
 205   is $y, 44, 'state subs from other packages override all keywords';
 206 }
 207 {
 208   use warnings; no warnings "experimental::lexical_subs";
 209   state $w ;
 210   local $SIG{__WARN__} = sub { $w .= shift };
 211   eval '#line 87 squidges
 212     state sub foo;
 213     state sub foo {};
 214   ';
 215   is $w,
 216      '"state" subroutine &foo masks earlier declaration in same scope at '
 217    . "squidges line 88.\n",
 218      'warning for state sub masking earlier declaration';
 219 }
 220 # Since state vars inside anonymous subs are cloned at the same time as the
 221 # anonymous subs containing them, the same should happen for state subs.
 222 sub make_closure {
 223   my $x = shift;
 224   sub {
 225     state sub foo { $x }
 226     foo
 227   }
 228 }
 229 $sub1 = make_closure 48;
 230 $sub2 = make_closure 49;
 231 is &$sub1, 48, 'state sub in closure (1)';
 232 is &$sub2, 49, 'state sub in closure (2)';
 233 # But we need to test that state subs actually do persist from one invoca-
 234 # tion of a named sub to another (i.e., that they are not my subs).
 235 {
 236   use warnings; no warnings "experimental::lexical_subs";
 237   state $w;
 238   local $SIG{__WARN__} = sub { $w .= shift };
 239   eval '#line 65 teetet
 240     sub foom {
 241       my $x = shift;
 242       state sub poom { $x }
 243       eval{\&poom}
 244     }
 245   ';
 246   is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n",
 247          'state subs get "Variable will not stay shared" messages';
 248   my $poom = foom(27);
 249   my $poom2 = foom(678);
 250   is eval{$poom->()}, eval {$poom2->()},
 251     'state subs close over the first outer my var, like pkg subs';
 252   my $x = 43;
 253   for $x (765) {
 254     state sub etetetet { $x }
 255     is eval{etetetet}, 43, 'state sub ignores for() localisation';
 256   }
 257 }
 258 # And we also need to test that multiple state subs can close over each
 259 # other’s entries in the parent subs pad, and that cv_clone is not con-
 260 # fused by that.
 261 sub make_anon_with_state_sub{
 262   sub {
 263     state sub s1;
 264     state sub s2 { \&s1 }
 265     sub s1 { \&s2 }
 266     if (@_) { return \&s1 }
 267     is s1,\&s2, 'state sub in anon closure closing over sibling state sub';
 268     is s2,\&s1, 'state sub in anon closure closing over sibling state sub';
 269   }
 270 }
 271 {
 272   my $s = make_anon_with_state_sub;
 273   &$s;
 274
 275   # And make sure the state subs were actually cloned.
 276   isnt make_anon_with_state_sub->(0), &$s(0),
 277     'state subs in anon subs are cloned';
 278   is &$s(0), &$s(0), 'but only when the anon sub is cloned';
 279 }
 280 # Check that nested state subs close over variables properly
 281 {
 282   is sub {
 283     state sub a;
 284     state sub b {
 285       state sub c {
 286         state $x = 42;
 287         sub a { $x }
 288       }
 289       c();
 290     }
 291     b();
 292     a();
 293   }->(), 42, 'state sub with body defined in doubly-nested state subs';
 294   is sub {
 295     state sub a;
 296     state sub b;
 297     state sub c {
 298       sub b {
 299         state $x = 42;
 300         sub a { $x }
 301       }
 302     }
 303     b();
 304     a();
 305   }->(), 42, 'nested state subs declared in same scope';
 306   state $w;
 307   local $SIG{__WARN__} = sub { $w .= shift };
 308   use warnings 'closure';
 309   my $sub = sub {
 310     state sub a;
 311     sub {
 312       my $x;
 313       sub a { $x }
 314     }
 315   };
 316   like $w, qr/Variable \"\$x\" is not available at /,
 317       "unavailability warning when state closure is defined in anon sub";
 318 }
 319 {
 320   state sub BEGIN { exit };
 321   pass 'state subs are never special blocks';
 322   state sub END { shift }
 323   is eval{END('jkqeudth')}, jkqeudth,
 324     'state sub END {shift} implies @_, not @ARGV';
 325   state sub CORE { scalar reverse shift }
 326   is CORE::uc("hello"), "HELLO",
 327     'lexical CORE does not interfere with CORE::...';
 328 }
 329 {
 330   state sub redef {}
 331   use warnings; no warnings "experimental::lexical_subs";
 332   state $w;
 333   local $SIG{__WARN__} = sub { $w .= shift };
 334   eval "#line 56 pygpyf\nsub redef {}";
 335   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
 336          "sub redefinition warnings from state subs";
 337 }
 338 {
 339   state sub p (\@) {
 340     is ref $_[0], 'ARRAY', 'state sub with proto';
 341   }
 342   p(my @a);
 343   p my @b;
 344   state sub q () { 45 }
 345   is q(), 45, 'state constant called with parens';
 346 }
 347 {
 348   state sub x;
 349   eval 'sub x {3}';
 350   is x, 3, 'state sub defined inside eval';
 351
 352   sub r {
 353     state sub foo { 3 };
 354     if (@_) { # outer call
 355       r();
 356       is foo(), 42,
 357          'state sub run-time redefinition applies to all recursion levels';
 358     }
 359     else { # inner call
 360       eval 'sub foo { 42 }';
 361     }
 362   }
 363   r(1);
 364 }
 365 like runperl(
 366       switches => [ '-Mfeature=lexical_subs,state' ],
 367       prog     => 'state sub a { foo ref } a()',
 368       stderr   => 1
 369      ),
 370      qr/syntax error/,
 371     'referencing a state sub after a syntax error does not crash';
 372 {
 373   state $stuff;
 374   package A {
 375     state sub foo{ $stuff .= our $AUTOLOAD }
 376     *A::AUTOLOAD = \&foo;
 377   }
 378   A::bar();
 379   is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload';
 380 }
 381 {
 382   state sub quire{qr "quires"}
 383   package o { use overload qr => \&quire }
 384   ok "quires" =~ bless([], o::), 'state sub used as overload method';
 385 }
 386 {
 387   state sub foo;
 388   *cvgv = \&foo;
 389   local *cvgv2 = *cvgv;
 390   eval 'sub cvgv2 {42}'; # uses the stub already present
 391   is foo, 42, 'defining state sub body via package sub declaration';
 392 }
 393 {
 394   local $ENV{PERL5DB} = 'sub DB::DB{}';
 395   is(
 396     runperl(
 397      switches => [ '-d' ],
 398      progs => [ split "\n",
 399       'use feature qw - lexical_subs state -;
 400        no warnings q-experimental::lexical_subs-;
 401        sub DB::sub{
 402          print qq|4\n| unless $DB::sub =~ DESTROY;
 403          goto $DB::sub
 404        }
 405        state sub foo {print qq|2\n|}
 406        foo();
 407       '
 408      ],
 409      stderr => 1
 410     ),
 411     "4\n2\n",
 412     'state subs and DB::sub under -d'
 413   );
 414   is(
 415     runperl(
 416      switches => [ '-d' ],
 417      progs => [ split "\n",
 418       'use feature qw - lexical_subs state -;
 419        no warnings q-experimental::lexical_subs-;
 420        sub DB::goto{ print qq|4\n|; $_ = $DB::sub }
 421        state sub foo {print qq|2\n|}
 422        $^P|=0x80;
 423        sub { goto &foo }->();
 424        print $_ == \&foo ? qq|ok\n| : qq|$_\n|;
 425       '
 426      ],
 427      stderr => 1
 428     ),
 429     "4\n2\nok\n",
 430     'state subs and DB::goto under -d'
 431   );
 432 }
 433 # This used to fail an assertion, but only as a standalone script
 434 is runperl(switches => ['-lXMfeature=:all'],
 435            prog     => 'state sub x {}; undef &x; print defined &x',
 436            stderr   => 1), "\n", 'undefining state sub';
 437 {
 438   state sub x { is +(caller 0)[3], 'x', 'state sub name in caller' }
 439   x
 440 }
 441 {
 442   state sub _cmp { $b cmp $a }
 443   is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b',
 444     'sort state_sub LIST'
 445 }
 446 {
 447   state sub handel { "" }
 448   print handel, "ok ", curr_test(),
 449        " - no 'No comma allowed' after state sub\n";
 450   curr_test(curr_test()+1);
 451 }
 452 {
 453   use utf8;
 454   state sub φου;
 455   eval { φου };
 456   like $@, qr/^Undefined subroutine &φου called at /,
 457     'state sub with utf8 name';
 458 }
 459 # This used to crash, but only as a standalone script
 460 is runperl(switches => ['-lXMfeature=:all'],
 461            prog     => '$::x = global=>;
 462                         sub x;
 463                         sub x {
 464                           state $x = 42;
 465                           state sub x { print eval q|$x| }
 466                           x()
 467                         }
 468                         x()',
 469            stderr   => 1), "42\n",
 470   'closure behaviour of state sub in predeclared package sub';
 471
 472 # -------------------- my -------------------- #
 473
 474 {
 475   my sub foo { 44 }
 476   isnt \&::foo, \&foo, 'my sub is not stored in the package';
 477   is foo, 44, 'calling my sub from same package';
 478   is &foo, 44, 'calling my sub from same package (amper)';
 479   package bar;
 480   is foo, 44, 'calling my sub from another package';
 481   is &foo, 44, 'calling my sub from another package (amper)';
 482 }
 483 package bar;
 484 is foo, 43, 'my sub falling out of scope';
 485 is &foo, 43, 'my sub falling out of scope (called via amper)';
 486 {
 487   sub ma { 43 }
 488   my sub ma {
 489     if (shift) {
 490       is ma, 43, 'my sub invisible inside itself';
 491       is &ma, 43, 'my sub invisible inside itself (called via amper)';
 492     }
 493     44
 494   }
 495   ma(1);
 496   sub mb { 43 }
 497   my sub mb;
 498   my sub mb {
 499     if (shift) {
 500       # ‘my sub foo{}’ creates a new pad entry, not reusing the forward
 501       #  declaration.  Being invisible inside itself, it sees the stub.
 502       eval{mb};
 503       like $@, qr/^Undefined subroutine &mb called at /,
 504         'my sub foo {} after forward declaration';
 505       eval{&mb};
 506       like $@, qr/^Undefined subroutine &mb called at /,
 507         'my sub foo {} after forward declaration (amper)';
 508     }
 509     44
 510   }
 511   mb(1);
 512   sub mb2 { 43 }
 513   my sub sb2;
 514   sub mb2 {
 515     if (shift) {
 516       package bar;
 517       is mb2, 44, 'my sub visible inside itself after decl';
 518       is &mb2, 44, 'my sub visible inside itself after decl (amper)';
 519     }
 520     44
 521   }
 522   mb2(1);
 523   my sub mb3;
 524   {
 525     my sub mb3 { # new pad entry
 526       # The sub containing this comment is invisible inside itself.
 527       # So this one here will assign to the outer pad entry:
 528       sub mb3 { 47 }
 529     }
 530   }
 531   is eval{mb3}, 47,
 532     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
 533   # Same test again, but inside an anonymous sub
 534   sub {
 535     my sub mb4;
 536     {
 537       my sub mb4 {
 538         sub mb4 { 47 }
 539       }
 540     }
 541     is mb4, 47,
 542       'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
 543   }->();
 544 }
 545 sub mc { 43 }
 546 {
 547   my sub mc;
 548   eval{mc};
 549   like $@, qr/^Undefined subroutine &mc called at /,
 550      'my sub foo; makes no lex alias for existing sub';
 551   eval{&mc};
 552   like $@, qr/^Undefined subroutine &mc called at /,
 553      'my sub foo; makes no lex alias for existing sub (amper)';
 554 }
 555 package main;
 556 {
 557   my sub me ($);
 558   is prototype eval{\&me}, '$', 'my sub with proto';
 559   is prototype "me", undef, 'prototype "..." ignores my subs';
 560
 561   my $coderef = eval "my sub foo (\$\x{30cd}) {1}; \\&foo";
 562   my $proto = prototype $coderef;
 563   ok(utf8::is_utf8($proto), "my sub with UTF8 proto maintains the UTF8ness");
 564   is($proto, "\$\x{30cd}", "check the prototypes actually match");
 565 }
 566 {
 567   my sub if() { 44 }
 568   my $x = if if if;
 569   is $x, 44, 'my subs override all keywords';
 570   package bar;
 571   my $y = if if if;
 572   is $y, 44, 'my subs from other packages override all keywords';
 573 }
 574 {
 575   use warnings; no warnings "experimental::lexical_subs";
 576   my $w ;
 577   local $SIG{__WARN__} = sub { $w .= shift };
 578   eval '#line 87 squidges
 579     my sub foo;
 580     my sub foo {};
 581   ';
 582   is $w,
 583      '"my" subroutine &foo masks earlier declaration in same scope at '
 584    . "squidges line 88.\n",
 585      'warning for my sub masking earlier declaration';
 586 }
 587 # Test that my subs are cloned inside anonymous subs.
 588 sub mmake_closure {
 589   my $x = shift;
 590   sub {
 591     my sub foo { $x }
 592     foo
 593   }
 594 }
 595 $sub1 = mmake_closure 48;
 596 $sub2 = mmake_closure 49;
 597 is &$sub1, 48, 'my sub in closure (1)';
 598 is &$sub2, 49, 'my sub in closure (2)';
 599 # Test that they are cloned in named subs.
 600 {
 601   use warnings; no warnings "experimental::lexical_subs";
 602   my $w;
 603   local $SIG{__WARN__} = sub { $w .= shift };
 604   eval '#line 65 teetet
 605     sub mfoom {
 606       my $x = shift;
 607       my sub poom { $x }
 608       \&poom
 609     }
 610   ';
 611   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
 612   my $poom = mfoom(27);
 613   my $poom2 = mfoom(678);
 614   is $poom->(), 27, 'my subs closing over outer my var (1)';
 615   is $poom2->(), 678, 'my subs closing over outer my var (2)';
 616   my $x = 43;
 617   my sub aoeu;
 618   for $x (765) {
 619     my sub etetetet { $x }
 620     sub aoeu { $x }
 621     is etetetet, 765, 'my sub respects for() localisation';
 622     is aoeu, 43, 'unless it is declared outside the for loop';
 623   }
 624 }
 625 # And we also need to test that multiple my subs can close over each
 626 # other’s entries in the parent subs pad, and that cv_clone is not con-
 627 # fused by that.
 628 sub make_anon_with_my_sub{
 629   sub {
 630     my sub s1;
 631     my sub s2 { \&s1 }
 632     sub s1 { \&s2 }
 633     if (@_) { return eval { \&s1 } }
 634     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
 635     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
 636   }
 637 }
 638
 639 # Test my subs inside predeclared my subs
 640 {
 641   my sub s2;
 642   sub s2 {
 643     my $x = 3;
 644     my sub s3 { eval '$x' }
 645     s3;
 646   }
 647   is s2, 3, 'my sub inside predeclared my sub';
 648 }
 649
 650 {
 651   my $s = make_anon_with_my_sub;
 652   &$s;
 653
 654   # And make sure the my subs were actually cloned.
 655   isnt make_anon_with_my_sub->(0), &$s(0),
 656     'my subs in anon subs are cloned';
 657   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
 658 }
 659 {
 660   my sub BEGIN { exit };
 661   pass 'my subs are never special blocks';
 662   my sub END { shift }
 663   is END('jkqeudth'), jkqeudth,
 664     'my sub END {shift} implies @_, not @ARGV';
 665 }
 666 {
 667   my sub redef {}
 668   use warnings; no warnings "experimental::lexical_subs";
 669   my $w;
 670   local $SIG{__WARN__} = sub { $w .= shift };
 671   eval "#line 56 pygpyf\nsub redef {}";
 672   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
 673          "sub redefinition warnings from my subs";
 674
 675   undef $w;
 676   sub {
 677     my sub x {};
 678     sub { eval "#line 87 khaki\n\\&x" }
 679   }->()();
 680   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
 681          "unavailability warning during compilation of eval in closure";
 682
 683   undef $w;
 684   no warnings 'void';
 685   eval <<'->()();';
 686 #line 87 khaki
 687     sub {
 688       my sub x{}
 689       sub not_lexical8 {
 690         \&x
 691       }
 692     }
 693 ->()();
 694   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
 695          "unavailability warning during compilation of named sub in anon";
 696
 697   undef $w;
 698   sub not_lexical9 {
 699     my sub x {};
 700     format =
 701 @
 702 &x
 703 .
 704   }
 705   eval { write };
 706   my($f,$l) = (__FILE__,__LINE__ - 1);
 707   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
 708          'unavailability warning during cloning';
 709   $l -= 3;
 710   is $@, "Undefined subroutine &x called at $f line $l.\n",
 711          'Vivified sub is correctly named';
 712 }
 713 sub not_lexical10 {
 714   my sub foo;
 715   foo();
 716   sub not_lexical11 {
 717     my sub bar {
 718       my $x = 'khaki car keys for the khaki car';
 719       not_lexical10();
 720       sub foo {
 721        is $x, 'khaki car keys for the khaki car',
 722        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
 723       }
 724     }
 725     bar()
 726   }
 727 }
 728 not_lexical11();
 729 {
 730   my sub p (\@) {
 731     is ref $_[0], 'ARRAY', 'my sub with proto';
 732   }
 733   p(my @a);
 734   p @a;
 735   my sub q () { 46 }
 736   is q(), 46, 'my constant called with parens';
 737 }
 738 {
 739   my sub x;
 740   my $count;
 741   sub x { x() if $count++ < 10 }
 742   x();
 743   is $count, 11, 'my recursive subs';
 744 }
 745 {
 746   my sub x;
 747   eval 'sub x {3}';
 748   is x, 3, 'my sub defined inside eval';
 749
 750   my sub z;
 751   BEGIN { eval 'sub z {4}' }
 752   is z, 4, 'my sub defined in BEGIN { eval "..." }';
 753 }
 754
 755 {
 756   state $w;
 757   local $SIG{__WARN__} = sub { $w .= shift };
 758   eval q{ my sub george () { 2 } };
 759   is $w, undef, 'no double free from constant my subs';
 760 }
 761 like runperl(
 762       switches => [ '-Mfeature=lexical_subs,state' ],
 763       prog     => 'my sub a { foo ref } a()',
 764       stderr   => 1
 765      ),
 766      qr/syntax error/,
 767     'referencing a my sub after a syntax error does not crash';
 768 {
 769   state $stuff;
 770   package A {
 771     my sub foo{ $stuff .= our $AUTOLOAD }
 772     *A::AUTOLOAD = \&foo;
 773   }
 774   A::bar();
 775   is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload';
 776 }
 777 {
 778   my sub quire{qr "quires"}
 779   package mo { use overload qr => \&quire }
 780   ok "quires" =~ bless([], mo::), 'my sub used as overload method';
 781 }
 782 {
 783   my sub foo;
 784   *mcvgv = \&foo;
 785   local *mcvgv2 = *mcvgv;
 786   eval 'sub mcvgv2 {42}'; # uses the stub already present
 787   is foo, 42, 'defining my sub body via package sub declaration';
 788 }
 789 {
 790   my sub foo;
 791   *mcvgv3 = \&foo;
 792   local *mcvgv4 = *mcvgv3;
 793   eval 'sub mcvgv4 {42}'; # uses the stub already present
 794   undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference
 795 }
 796 # We would have crashed by now if it weren’t fixed.
 797 pass "pad taking ownership once more of packagified my-sub";
 798
 799 {
 800   local $ENV{PERL5DB} = 'sub DB::DB{}';
 801   is(
 802     runperl(
 803      switches => [ '-d' ],
 804      progs => [ split "\n",
 805       'use feature qw - lexical_subs state -;
 806        no warnings q-experimental::lexical_subs-;
 807        sub DB::sub{
 808          print qq|4\n| unless $DB::sub =~ DESTROY;
 809          goto $DB::sub
 810        }
 811        my sub foo {print qq|2\n|}
 812        foo();
 813       '
 814      ],
 815      stderr => 1
 816     ),
 817     "4\n2\n",
 818     'my subs and DB::sub under -d'
 819   );
 820 }
 821 # This used to fail an assertion, but only as a standalone script
 822 is runperl(switches => ['-lXMfeature=:all'],
 823            prog     => 'my sub x {}; undef &x; print defined &x',
 824            stderr   => 1), "\n", 'undefining my sub';
 825 {
 826   my sub x { is +(caller 0)[3], 'x', 'my sub name in caller' }
 827   x
 828 }
 829 {
 830   my sub _cmp { $b cmp $a }
 831   is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b',
 832     'sort my_sub LIST'
 833 }
 834 {
 835   my sub handel { "" }
 836   print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n";
 837   curr_test(curr_test()+1);
 838 }
 839 {
 840   my $x = 43;
 841   my sub y :prototype() {$x};
 842   is y, 43, 'my sub that looks like constant closure';
 843 }
 844 {
 845   use utf8;
 846   my sub φου;
 847   eval { φου };
 848   like $@, qr/^Undefined subroutine &φου called at /,
 849     'my sub with utf8 name';
 850 }
 851 {
 852   my $w;
 853   local $SIG{__WARN__} = sub { $w = shift };
 854   use warnings 'closure';
 855   eval 'sub stayshared { my sub x; sub notstayshared { x } } 1' or die;
 856   like $w, qr/^Subroutine "&x" will not stay shared at /,
 857           'Subroutine will not stay shared';
 858 }
 859
 860 # -------------------- Interactions (and misc tests) -------------------- #
 861
 862 is sub {
 863     my sub s1;
 864     my sub s2 { 3 };
 865     sub s1 { state sub foo { \&s2 } foo }
 866     s1
 867   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
 868
 869 {
 870   my sub s2 { 3 };
 871   sub not_lexical { state sub foo { \&s2 } foo }
 872   is not_lexical->(), 3, 'state subs that reference my sub from outside';
 873 }
 874
 875 # Test my subs inside predeclared package subs
 876 # This test also checks that CvOUTSIDE pointers are not mangled when the
 877 # inner sub’s CvOUTSIDE points to another sub.
 878 sub not_lexical2;
 879 sub not_lexical2 {
 880   my $x = 23;
 881   my sub bar;
 882   sub not_lexical3 {
 883     not_lexical2();
 884     sub bar { $x }
 885   };
 886   bar
 887 }
 888 is not_lexical3, 23, 'my subs inside predeclared package subs';
 889
 890 # Test my subs inside predeclared package sub, where the lexical sub is
 891 # declared outside the package sub.
 892 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
 893 # not declared inside the sub that its CvOUTSIDE points to.
 894 sub not_lexical5 {
 895   my sub foo;
 896   sub not_lexical4;
 897   sub not_lexical4 {
 898     my $x = 234;
 899     not_lexical5();
 900     sub foo { $x }
 901   }
 902   foo
 903 }
 904 is not_lexical4, 234,
 905     'my sub defined in predeclared pkg sub but declared outside';
 906
 907 undef *not_lexical6;
 908 {
 909   my sub foo;
 910   sub not_lexical6 { sub foo { } }
 911   pass 'no crash when cloning a mysub declared inside an undef pack sub';
 912 }
 913
 914 undef &not_lexical7;
 915 eval 'sub not_lexical7 { my @x }';
 916 {
 917   my sub foo;
 918   foo();
 919   sub not_lexical7 {
 920     state $x;
 921     sub foo {
 922       is ref \$x, 'SCALAR',
 923         "redeffing a mysub's outside does not make it use the wrong pad"
 924     }
 925   }
 926 }
 927
 928 like runperl(
 929       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
 930       prog     => 'my sub foo; sub foo { foo } foo',
 931       stderr   => 1
 932      ),
 933      qr/Deep recursion on subroutine "foo"/,
 934     'deep recursion warnings for lexical subs do not crash';
 935
 936 like runperl(
 937       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
 938       prog     => 'my sub foo() { 42 } undef &foo',
 939       stderr   => 1
 940      ),
 941      qr/Constant subroutine foo undefined at /,
 942     'constant undefinition warnings for lexical subs do not crash';
 943
 944 {
 945   my sub foo;
 946   *AutoloadTestSuper::blah = \&foo;
 947   sub AutoloadTestSuper::AUTOLOAD {
 948     is $AutoloadTestSuper::AUTOLOAD, "AutoloadTestSuper::blah",
 949       "Autoloading via inherited lex stub";
 950   }
 951   @AutoloadTest::ISA = AutoloadTestSuper::;
 952   AutoloadTest->blah;
 953 }
 954
 955 # This used to crash because op.c:find_lexical_cv was looking at the wrong
 956 # CV’s OUTSIDE pointer.  [perl #124099]
 957 {
 958   my sub h; sub{my $x; sub{h}}
 959 }
 960
 961 is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
 962   "aa-bb-123-cc-dd", 'do { my sub...} in a list [perl #132442]';