PATCH: [perl #133767] Assertion failure
[perl.git] / 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]';