t/cmd/lexsub.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7     *bar::is = *is;
   8     *bar::like = *like;
   9 }
  10 no warnings 'deprecated';
  11 plan 122;
  12
  13 # -------------------- our -------------------- #
  14
  15 {
  16   our sub foo { 42 }
  17   is foo, 42, 'calling our sub from same package';
  18   is &foo, 42, 'calling our sub from same package (amper)';
  19   is do foo(), 42, 'calling our sub from same package (do)';
  20   package bar;
  21   sub bar::foo { 43 }
  22   is foo, 42, 'calling our sub from another package';
  23   is &foo, 42, 'calling our sub from another package (amper)';
  24   is do foo(), 42, 'calling our sub from another package (do)';
  25 }
  26 package bar;
  27 is foo, 43, 'our sub falling out of scope';
  28 is &foo, 43, 'our sub falling out of scope (called via amper)';
  29 is do foo(), 43, 'our sub falling out of scope (called via amper)';
  30 package main;
  31 {
  32   sub bar::a { 43 }
  33   our sub a {
  34     if (shift) {
  35       package bar;
  36       is a, 43, 'our sub invisible inside itself';
  37       is &a, 43, 'our sub invisible inside itself (called via amper)';
  38       is do a(), 43, 'our sub invisible inside itself (called via do)';
  39     }
  40     42
  41   }
  42   a(1);
  43   sub bar::b { 43 }
  44   our sub b;
  45   our sub b {
  46     if (shift) {
  47       package bar;
  48       is b, 42, 'our sub visible inside itself after decl';
  49       is &b, 42, 'our sub visible inside itself after decl (amper)';
  50       is do b(), 42, 'our sub visible inside itself after decl (do)';
  51     }
  52     42
  53   }
  54   b(1)
  55 }
  56 sub c { 42 }
  57 sub bar::c { 43 }
  58 {
  59   our sub c;
  60   package bar;
  61   is c, 42, 'our sub foo; makes lex alias for existing sub';
  62   is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)';
  63   is do c(), 42, 'our sub foo; makes lex alias for existing sub (do)';
  64 }
  65 {
  66   our sub d;
  67   sub bar::d { 'd43' }
  68   package bar;
  69   sub d { 'd42' }
  70   is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}';
  71 }
  72 {
  73   our sub e ($);
  74   is prototype "::e", '$', 'our sub with proto';
  75 }
  76 {
  77   our sub if() { 42 }
  78   my $x = if if if;
  79   is $x, 42, 'lexical subs (even our) override all keywords';
  80   package bar;
  81   my $y = if if if;
  82   is $y, 42, 'our subs from other packages override all keywords';
  83 }
  84
  85 # -------------------- state -------------------- #
  86
  87 use 5.01; # state
  88 {
  89   state sub foo { 44 }
  90   isnt \&::foo, \&foo, 'state sub is not stored in the package';
  91   is eval foo, 44, 'calling state sub from same package';
  92   is eval &foo, 44, 'calling state sub from same package (amper)';
  93   is eval do foo(), 44, 'calling state sub from same package (do)';
  94   package bar;
  95   is eval foo, 44, 'calling state sub from another package';
  96   is eval &foo, 44, 'calling state sub from another package (amper)';
  97   is eval do foo(), 44, 'calling state sub from another package (do)';
  98 }
  99 package bar;
 100 is foo, 43, 'state sub falling out of scope';
 101 is &foo, 43, 'state sub falling out of scope (called via amper)';
 102 is do foo(), 43, 'state sub falling out of scope (called via amper)';
 103 {
 104   sub sa { 43 }
 105   state sub sa {
 106     if (shift) {
 107       is sa, 43, 'state sub invisible inside itself';
 108       is &sa, 43, 'state sub invisible inside itself (called via amper)';
 109       is do sa(), 43, 'state sub invisible inside itself (called via do)';
 110     }
 111     44
 112   }
 113   sa(1);
 114   sub sb { 43 }
 115   state sub sb;
 116   state sub sb {
 117     if (shift) {
 118       # ‘state sub foo{}’ creates a new pad entry, not reusing the forward
 119       #  declaration.  Being invisible inside itself, it sees the stub.
 120       eval{sb};
 121       like $@, qr/^Undefined subroutine &sb called at /,
 122         'state sub foo {} after forward declaration';
 123       eval{&sb};
 124       like $@, qr/^Undefined subroutine &sb called at /,
 125         'state sub foo {} after forward declaration (amper)';
 126       eval{do sb()};
 127       like $@, qr/^Undefined subroutine &sb called at /,
 128         'state sub foo {} after forward declaration (do)';
 129     }
 130     44
 131   }
 132   sb(1);
 133   sub sb2 { 43 }
 134   state sub sb2;
 135   sub sb2 {
 136     if (shift) {
 137       package bar;
 138       is sb2, 44, 'state sub visible inside itself after decl';
 139       is &sb2, 44, 'state sub visible inside itself after decl (amper)';
 140       is do sb2(), 44, 'state sub visible inside itself after decl (do)';
 141     }
 142     44
 143   }
 144   sb2(1);
 145   state sub sb3;
 146   {
 147     state sub sb3 { # new pad entry
 148       # The sub containing this comment is invisible inside itself.
 149       # So this one here will assign to the outer pad entry:
 150       sub sb3 { 47 }
 151     }
 152   }
 153   is eval{sb3}, 47,
 154     'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
 155   # Same test again, but inside an anonymous sub
 156   sub {
 157     state sub sb4;
 158     {
 159       state sub sb4 {
 160         sub sb4 { 47 }
 161       }
 162     }
 163     is sb4, 47,
 164       'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
 165   }->();
 166 }
 167 sub sc { 43 }
 168 {
 169   state sub sc;
 170   eval{sc};
 171   like $@, qr/^Undefined subroutine &sc called at /,
 172      'state sub foo; makes no lex alias for existing sub';
 173   eval{&sc};
 174   like $@, qr/^Undefined subroutine &sc called at /,
 175      'state sub foo; makes no lex alias for existing sub (amper)';
 176   eval{do sc()};
 177   like $@, qr/^Undefined subroutine &sc called at /,
 178      'state sub foo; makes no lex alias for existing sub (do)';
 179 }
 180 package main;
 181 {
 182   state sub se ($);
 183   is prototype eval{\&se}, '$', 'state sub with proto';
 184   is prototype "se", undef, 'prototype "..." ignores state subs';
 185 }
 186 {
 187   state sub if() { 44 }
 188   my $x = if if if;
 189   is $x, 44, 'state subs override all keywords';
 190   package bar;
 191   my $y = if if if;
 192   is $y, 44, 'state subs from other packages override all keywords';
 193 }
 194 {
 195   use warnings;
 196   state $w ;
 197   local $SIG{__WARN__} = sub { $w .= shift };
 198   eval '#line 87 squidges
 199     state sub foo;
 200     state sub foo {};
 201   ';
 202   is $w,
 203      '"state" subroutine &foo masks earlier declaration in same scope at '
 204    . "squidges line 88.\n",
 205      'warning for state sub masking earlier declaration';
 206 }
 207 # Since state vars inside anonymous subs are cloned at the same time as the
 208 # anonymous subs containing them, the same should happen for state subs.
 209 sub make_closure {
 210   my $x = shift;
 211   sub {
 212     state sub foo { $x }
 213     foo
 214   }
 215 }
 216 $sub1 = make_closure 48;
 217 $sub2 = make_closure 49;
 218 is &$sub1, 48, 'state sub in closure (1)';
 219 is &$sub2, 49, 'state sub in closure (2)';
 220 # But we need to test that state subs actually do persist from one invoca-
 221 # tion of a named sub to another (i.e., that they are not my subs).
 222 {
 223   use warnings;
 224   state $w;
 225   local $SIG{__WARN__} = sub { $w .= shift };
 226   eval '#line 65 teetet
 227     sub foom {
 228       my $x = shift;
 229       state sub poom { $x }
 230       eval{\&poom}
 231     }
 232   ';
 233   is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n",
 234          'state subs get "Variable will not stay shared" messages';
 235   my $poom = foom(27);
 236   my $poom2 = foom(678);
 237   is eval{$poom->()}, eval {$poom2->()},
 238     'state subs close over the first outer my var, like pkg subs';
 239   my $x = 43;
 240   for $x (765) {
 241     state sub etetetet { $x }
 242     is eval{etetetet}, 43, 'state sub ignores for() localisation';
 243   }
 244 }
 245 # And we also need to test that multiple state subs can close over each
 246 # other’s entries in the parent subs pad, and that cv_clone is not con-
 247 # fused by that.
 248 sub make_anon_with_state_sub{
 249   sub {
 250     state sub s1;
 251     state sub s2 { \&s1 }
 252     sub s1 { \&s2 }
 253     if (@_) { return \&s1 }
 254     is s1,\&s2, 'state sub in anon closure closing over sibling state sub';
 255     is s2,\&s1, 'state sub in anon closure closing over sibling state sub';
 256   }
 257 }
 258 {
 259   my $s = make_anon_with_state_sub;
 260   &$s;
 261
 262   # And make sure the state subs were actually cloned.
 263   isnt make_anon_with_state_sub->(0), &$s(0),
 264     'state subs in anon subs are cloned';
 265   is &$s(0), &$s(0), 'but only when the anon sub is cloned';
 266 }
 267 {
 268   state sub BEGIN { exit };
 269   pass 'state subs are never special blocks';
 270   state sub END { shift }
 271   is eval{END('jkqeudth')}, jkqeudth,
 272     'state sub END {shift} implies @_, not @ARGV';
 273 }
 274 {
 275   state sub redef {}
 276   use warnings;
 277   state $w;
 278   local $SIG{__WARN__} = sub { $w .= shift };
 279   eval "#line 56 pygpyf\nsub redef {}";
 280   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
 281          "sub redefinition warnings from state subs";
 282 }
 283 {
 284   state sub p (\@) {
 285     is ref $_[0], 'ARRAY', 'state sub with proto';
 286   }
 287   p(my @a);
 288 }
 289 {
 290   state sub x;
 291   eval 'sub x {3}';
 292   is x, 3, 'state sub defined inside eval';
 293 }
 294
 295 # -------------------- my -------------------- #
 296
 297 {
 298   my sub foo { 44 }
 299   isnt \&::foo, \&foo, 'my sub is not stored in the package';
 300   is foo, 44, 'calling my sub from same package';
 301   is &foo, 44, 'calling my sub from same package (amper)';
 302   is do foo(), 44, 'calling my sub from same package (do)';
 303   package bar;
 304   is foo, 44, 'calling my sub from another package';
 305   is &foo, 44, 'calling my sub from another package (amper)';
 306   is do foo(), 44, 'calling my sub from another package (do)';
 307 }
 308 package bar;
 309 is foo, 43, 'my sub falling out of scope';
 310 is &foo, 43, 'my sub falling out of scope (called via amper)';
 311 is do foo(), 43, 'my sub falling out of scope (called via amper)';
 312 {
 313   sub ma { 43 }
 314   my sub ma {
 315     if (shift) {
 316       is ma, 43, 'my sub invisible inside itself';
 317       is &ma, 43, 'my sub invisible inside itself (called via amper)';
 318       is do ma(), 43, 'my sub invisible inside itself (called via do)';
 319     }
 320     44
 321   }
 322   ma(1);
 323   sub mb { 43 }
 324   my sub mb;
 325   my sub mb {
 326     if (shift) {
 327       # ‘my sub foo{}’ creates a new pad entry, not reusing the forward
 328       #  declaration.  Being invisible inside itself, it sees the stub.
 329       eval{mb};
 330       like $@, qr/^Undefined subroutine &mb called at /,
 331         'my sub foo {} after forward declaration';
 332       eval{&mb};
 333       like $@, qr/^Undefined subroutine &mb called at /,
 334         'my sub foo {} after forward declaration (amper)';
 335       eval{do mb()};
 336       like $@, qr/^Undefined subroutine &mb called at /,
 337         'my sub foo {} after forward declaration (do)';
 338     }
 339     44
 340   }
 341   mb(1);
 342   sub mb2 { 43 }
 343   my sub sb2;
 344   sub mb2 {
 345     if (shift) {
 346       package bar;
 347       is mb2, 44, 'my sub visible inside itself after decl';
 348       is &mb2, 44, 'my sub visible inside itself after decl (amper)';
 349       is do mb2(), 44, 'my sub visible inside itself after decl (do)';
 350     }
 351     44
 352   }
 353   mb2(1);
 354   my sub mb3;
 355   {
 356     my sub mb3 { # new pad entry
 357       # The sub containing this comment is invisible inside itself.
 358       # So this one here will assign to the outer pad entry:
 359       sub mb3 { 47 }
 360     }
 361   }
 362   is eval{mb3}, 47,
 363     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
 364   # Same test again, but inside an anonymous sub
 365   sub {
 366     my sub mb4;
 367     {
 368       my sub mb4 {
 369         sub mb4 { 47 }
 370       }
 371     }
 372     is mb4, 47,
 373       'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
 374   }->();
 375 }
 376 sub mc { 43 }
 377 {
 378   my sub mc;
 379   eval{mc};
 380   like $@, qr/^Undefined subroutine &mc called at /,
 381      'my sub foo; makes no lex alias for existing sub';
 382   eval{&mc};
 383   like $@, qr/^Undefined subroutine &mc called at /,
 384      'my sub foo; makes no lex alias for existing sub (amper)';
 385   eval{do mc()};
 386   like $@, qr/^Undefined subroutine &mc called at /,
 387      'my sub foo; makes no lex alias for existing sub (do)';
 388 }
 389 package main;
 390 {
 391   my sub me ($);
 392   is prototype eval{\&me}, '$', 'my sub with proto';
 393   is prototype "me", undef, 'prototype "..." ignores my subs';
 394 }
 395 {
 396   my sub if() { 44 }
 397   my $x = if if if;
 398   is $x, 44, 'my subs override all keywords';
 399   package bar;
 400   my $y = if if if;
 401   is $y, 44, 'my subs from other packages override all keywords';
 402 }
 403 {
 404   use warnings;
 405   my $w ;
 406   local $SIG{__WARN__} = sub { $w .= shift };
 407   eval '#line 87 squidges
 408     my sub foo;
 409     my sub foo {};
 410   ';
 411   is $w,
 412      '"my" subroutine &foo masks earlier declaration in same scope at '
 413    . "squidges line 88.\n",
 414      'warning for my sub masking earlier declaration';
 415 }
 416 # Test that my subs are cloned inside anonymous subs.
 417 sub mmake_closure {
 418   my $x = shift;
 419   sub {
 420     my sub foo { $x }
 421     foo
 422   }
 423 }
 424 $sub1 = mmake_closure 48;
 425 $sub2 = mmake_closure 49;
 426 is &$sub1, 48, 'my sub in closure (1)';
 427 is &$sub2, 49, 'my sub in closure (2)';
 428 # Test that they are cloned in named subs.
 429 {
 430   use warnings;
 431   my $w;
 432   local $SIG{__WARN__} = sub { $w .= shift };
 433   eval '#line 65 teetet
 434     sub mfoom {
 435       my $x = shift;
 436       my sub poom { $x }
 437       \&poom
 438     }
 439   ';
 440   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
 441   my $poom = mfoom(27);
 442   my $poom2 = mfoom(678);
 443   is $poom->(), 27, 'my subs closing over outer my var (1)';
 444   is $poom2->(), 678, 'my subs closing over outer my var (2)';
 445   my $x = 43;
 446   my sub aoeu;
 447   for $x (765) {
 448     my sub etetetet { $x }
 449     sub aoeu { $x }
 450     is etetetet, 765, 'my sub respects for() localisation';
 451     is aoeu, 43, 'unless it is declared outside the for loop';
 452   }
 453 }
 454 # And we also need to test that multiple my subs can close over each
 455 # other’s entries in the parent subs pad, and that cv_clone is not con-
 456 # fused by that.
 457 sub make_anon_with_my_sub{
 458   sub {
 459     my sub s1;
 460     my sub s2 { \&s1 }
 461     sub s1 { \&s2 }
 462     if (@_) { return eval { \&s1 } }
 463     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
 464     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
 465   }
 466 }
 467
 468 # Test my subs inside predeclared my subs
 469 {
 470   my sub s2;
 471   sub s2 {
 472     my $x = 3;
 473     my sub s3 { eval '$x' }
 474     s3;
 475   }
 476   is s2, 3, 'my sub inside predeclared my sub';
 477 }
 478
 479 {
 480   my $s = make_anon_with_my_sub;
 481   &$s;
 482
 483   # And make sure the my subs were actually cloned.
 484   isnt make_anon_with_my_sub->(0), &$s(0),
 485     'my subs in anon subs are cloned';
 486   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
 487 }
 488 {
 489   my sub BEGIN { exit };
 490   pass 'my subs are never special blocks';
 491   my sub END { shift }
 492   is END('jkqeudth'), jkqeudth,
 493     'my sub END {shift} implies @_, not @ARGV';
 494 }
 495 {
 496   my sub redef {}
 497   use warnings;
 498   my $w;
 499   local $SIG{__WARN__} = sub { $w .= shift };
 500   eval "#line 56 pygpyf\nsub redef {}";
 501   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
 502          "sub redefinition warnings from my subs";
 503
 504   undef $w;
 505   sub {
 506     my sub x {};
 507     sub { eval "#line 87 khaki\n\\&x" }
 508   }->()();
 509   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
 510          "unavailability warning during compilation of eval in closure";
 511
 512   undef $w;
 513   no warnings 'void';
 514   eval <<'->()();';
 515 #line 87 khaki
 516     sub {
 517       my sub x{}
 518       sub not_lexical8 {
 519         \&x
 520       }
 521     }
 522 ->()();
 523   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
 524          "unavailability warning during compilation of named sub in anon";
 525
 526   undef $w;
 527   sub not_lexical9 {
 528     my sub x {};
 529     format =
 530 @
 531 &x
 532 .
 533   }
 534   eval { write };
 535   my($f,$l) = (__FILE__,__LINE__ - 1);
 536   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
 537          'unavailability warning during cloning';
 538   $l -= 3;
 539   is $@, "Undefined subroutine &x called at $f line $l.\n",
 540          'Vivified sub is correctly named';
 541 }
 542 sub not_lexical10 {
 543   my sub foo;
 544   foo();
 545   sub not_lexical11 {
 546     my sub bar {
 547       my $x = 'khaki car keys for the khaki car';
 548       not_lexical10();
 549       sub foo {
 550        is $x, 'khaki car keys for the khaki car',
 551        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
 552       }
 553     }
 554     bar()
 555   }
 556 }
 557 not_lexical11();
 558 {
 559   my sub p (\@) {
 560     is ref $_[0], 'ARRAY', 'my sub with proto';
 561   }
 562   p(my @a);
 563 }
 564 {
 565   my sub x;
 566   my $count;
 567   sub x { x() if $count++ < 10 }
 568   x();
 569   is $count, 11, 'my recursive subs';
 570 }
 571
 572 # -------------------- Interactions (and misc tests) -------------------- #
 573
 574 is sub {
 575     my sub s1;
 576     my sub s2 { 3 };
 577     sub s1 { state sub foo { \&s2 } foo }
 578     s1
 579   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
 580
 581 {
 582   my sub s2 { 3 };
 583   sub not_lexical { state sub foo { \&s2 } foo }
 584   is not_lexical->(), 3, 'state subs that reference my sub from outside';
 585 }
 586
 587 # Test my subs inside predeclared package subs
 588 # This test also checks that CvOUTSIDE pointers are not mangled when the
 589 # inner sub’s CvOUTSIDE points to another sub.
 590 sub not_lexical2;
 591 sub not_lexical2 {
 592   my $x = 23;
 593   my sub bar;
 594   sub not_lexical3 {
 595     not_lexical2();
 596     sub bar { $x }
 597   };
 598   bar
 599 }
 600 is not_lexical3, 23, 'my subs inside predeclared package subs';
 601
 602 # Test my subs inside predeclared package sub, where the lexical sub is
 603 # declared outside the package sub.
 604 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
 605 # not declared inside the sub that its CvOUTSIDE points to.
 606 sub not_lexical5 {
 607   my sub foo;
 608   sub not_lexical4;
 609   sub not_lexical4 {
 610     my $x = 234;
 611     not_lexical5();
 612     sub foo { $x }
 613   }
 614   foo
 615 }
 616 is not_lexical4, 234,
 617     'my sub defined in predeclared pkg sub but declared outside';
 618
 619 undef *not_lexical6;
 620 {
 621   my sub foo;
 622   sub not_lexical6 { sub foo { } }
 623   pass 'no crash when cloning a mysub declared inside an undef pack sub';
 624 }
 625
 626 undef &not_lexical7;
 627 eval 'sub not_lexical7 { my @x }';
 628 {
 629   my sub foo;
 630   foo();
 631   sub not_lexical7 {
 632     state $x;
 633     sub foo {
 634       is ref \$x, 'SCALAR',
 635         "redeffing a mysub's outside does not make it use the wrong pad"
 636     }
 637   }
 638 }