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