This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix crash when lex subs are used for AUTOLOAD
[perl5.git] / t / op / 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 plan 122;
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
92 # -------------------- state -------------------- #
93
94 use feature 'state'; # state
95 {
96   state sub foo { 44 }
97   isnt \&::foo, \&foo, 'state sub is not stored in the package';
98   is eval foo, 44, 'calling state sub from same package';
99   is eval &foo, 44, 'calling state sub from same package (amper)';
100   package bar;
101   is eval foo, 44, 'calling state sub from another package';
102   is eval &foo, 44, 'calling state sub from another package (amper)';
103 }
104 package bar;
105 is foo, 43, 'state sub falling out of scope';
106 is &foo, 43, 'state sub falling out of scope (called via amper)';
107 {
108   sub sa { 43 }
109   state sub sa {
110     if (shift) {
111       is sa, 43, 'state sub invisible inside itself';
112       is &sa, 43, 'state sub invisible inside itself (called via amper)';
113     }
114     44
115   }
116   sa(1);
117   sub sb { 43 }
118   state sub sb;
119   state sub sb {
120     if (shift) {
121       # ‘state sub foo{}’ creates a new pad entry, not reusing the forward
122       #  declaration.  Being invisible inside itself, it sees the stub.
123       eval{sb};
124       like $@, qr/^Undefined subroutine &sb called at /,
125         'state sub foo {} after forward declaration';
126       eval{&sb};
127       like $@, qr/^Undefined subroutine &sb called at /,
128         'state sub foo {} after forward declaration (amper)';
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     }
141     44
142   }
143   sb2(1);
144   state sub sb3;
145   {
146     state sub sb3 { # new pad entry
147       # The sub containing this comment is invisible inside itself.
148       # So this one here will assign to the outer pad entry:
149       sub sb3 { 47 }
150     }
151   }
152   is eval{sb3}, 47,
153     'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
154   # Same test again, but inside an anonymous sub
155   sub {
156     state sub sb4;
157     {
158       state sub sb4 {
159         sub sb4 { 47 }
160       }
161     }
162     is sb4, 47,
163       'sub foo{} applying to "state sub foo;" even inside state sub foo{}';
164   }->();
165 }
166 sub sc { 43 }
167 {
168   state sub sc;
169   eval{sc};
170   like $@, qr/^Undefined subroutine &sc called at /,
171      'state sub foo; makes no lex alias for existing sub';
172   eval{&sc};
173   like $@, qr/^Undefined subroutine &sc called at /,
174      'state sub foo; makes no lex alias for existing sub (amper)';
175 }
176 package main;
177 {
178   state sub se ($);
179   is prototype eval{\&se}, '$', 'state sub with proto';
180   is prototype "se", undef, 'prototype "..." ignores state subs';
181 }
182 {
183   state sub if() { 44 }
184   my $x = if if if;
185   is $x, 44, 'state subs override all keywords';
186   package bar;
187   my $y = if if if;
188   is $y, 44, 'state subs from other packages override all keywords';
189 }
190 {
191   use warnings; no warnings "experimental::lexical_subs";
192   state $w ;
193   local $SIG{__WARN__} = sub { $w .= shift };
194   eval '#line 87 squidges
195     state sub foo;
196     state sub foo {};
197   ';
198   is $w,
199      '"state" subroutine &foo masks earlier declaration in same scope at '
200    . "squidges line 88.\n",
201      'warning for state sub masking earlier declaration';
202 }
203 # Since state vars inside anonymous subs are cloned at the same time as the
204 # anonymous subs containing them, the same should happen for state subs.
205 sub make_closure {
206   my $x = shift;
207   sub {
208     state sub foo { $x }
209     foo
210   }
211 }
212 $sub1 = make_closure 48;
213 $sub2 = make_closure 49;
214 is &$sub1, 48, 'state sub in closure (1)';
215 is &$sub2, 49, 'state sub in closure (2)';
216 # But we need to test that state subs actually do persist from one invoca-
217 # tion of a named sub to another (i.e., that they are not my subs).
218 {
219   use warnings; no warnings "experimental::lexical_subs";
220   state $w;
221   local $SIG{__WARN__} = sub { $w .= shift };
222   eval '#line 65 teetet
223     sub foom {
224       my $x = shift;
225       state sub poom { $x }
226       eval{\&poom}
227     }
228   ';
229   is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n",
230          'state subs get "Variable will not stay shared" messages';
231   my $poom = foom(27);
232   my $poom2 = foom(678);
233   is eval{$poom->()}, eval {$poom2->()},
234     'state subs close over the first outer my var, like pkg subs';
235   my $x = 43;
236   for $x (765) {
237     state sub etetetet { $x }
238     is eval{etetetet}, 43, 'state sub ignores for() localisation';
239   }
240 }
241 # And we also need to test that multiple state subs can close over each
242 # other’s entries in the parent subs pad, and that cv_clone is not con-
243 # fused by that.
244 sub make_anon_with_state_sub{
245   sub {
246     state sub s1;
247     state sub s2 { \&s1 }
248     sub s1 { \&s2 }
249     if (@_) { return \&s1 }
250     is s1,\&s2, 'state sub in anon closure closing over sibling state sub';
251     is s2,\&s1, 'state sub in anon closure closing over sibling state sub';
252   }
253 }
254 {
255   my $s = make_anon_with_state_sub;
256   &$s;
257
258   # And make sure the state subs were actually cloned.
259   isnt make_anon_with_state_sub->(0), &$s(0),
260     'state subs in anon subs are cloned';
261   is &$s(0), &$s(0), 'but only when the anon sub is cloned';
262 }
263 {
264   state sub BEGIN { exit };
265   pass 'state subs are never special blocks';
266   state sub END { shift }
267   is eval{END('jkqeudth')}, jkqeudth,
268     'state sub END {shift} implies @_, not @ARGV';
269   state sub CORE { scalar reverse shift }
270   is CORE::uc("hello"), "HELLO",
271     'lexical CORE does not interfere with CORE::...';
272 }
273 {
274   state sub redef {}
275   use warnings; no warnings "experimental::lexical_subs";
276   state $w;
277   local $SIG{__WARN__} = sub { $w .= shift };
278   eval "#line 56 pygpyf\nsub redef {}";
279   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
280          "sub redefinition warnings from state subs";
281 }
282 {
283   state sub p (\@) {
284     is ref $_[0], 'ARRAY', 'state sub with proto';
285   }
286   p(my @a);
287   p my @b;
288   state sub q () { 45 }
289   is q(), 45, 'state constant called with parens';
290 }
291 {
292   state sub x;
293   eval 'sub x {3}';
294   is x, 3, 'state sub defined inside eval';
295
296   sub r {
297     state sub foo { 3 };
298     if (@_) { # outer call
299       r();
300       is foo(), 42,
301          'state sub run-time redefinition applies to all recursion levels';
302     }
303     else { # inner call
304       eval 'sub foo { 42 }';
305     }
306   }
307   r(1);
308 }
309 like runperl(
310       switches => [ '-Mfeature=lexical_subs,state' ],
311       prog     => 'state sub a { foo ref } a()',
312       stderr   => 1
313      ),
314      qr/syntax error/,
315     'referencing a state sub after a syntax error does not crash';
316 {
317   state $stuff;
318   package A {
319     state sub foo{ $stuff .= our $AUTOLOAD }
320     *A::AUTOLOAD = \&foo;
321   }
322   A::bar();
323   is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload';
324 }
325
326 # -------------------- my -------------------- #
327
328 {
329   my sub foo { 44 }
330   isnt \&::foo, \&foo, 'my sub is not stored in the package';
331   is foo, 44, 'calling my sub from same package';
332   is &foo, 44, 'calling my sub from same package (amper)';
333   package bar;
334   is foo, 44, 'calling my sub from another package';
335   is &foo, 44, 'calling my sub from another package (amper)';
336 }
337 package bar;
338 is foo, 43, 'my sub falling out of scope';
339 is &foo, 43, 'my sub falling out of scope (called via amper)';
340 {
341   sub ma { 43 }
342   my sub ma {
343     if (shift) {
344       is ma, 43, 'my sub invisible inside itself';
345       is &ma, 43, 'my sub invisible inside itself (called via amper)';
346     }
347     44
348   }
349   ma(1);
350   sub mb { 43 }
351   my sub mb;
352   my sub mb {
353     if (shift) {
354       # ‘my sub foo{}’ creates a new pad entry, not reusing the forward
355       #  declaration.  Being invisible inside itself, it sees the stub.
356       eval{mb};
357       like $@, qr/^Undefined subroutine &mb called at /,
358         'my sub foo {} after forward declaration';
359       eval{&mb};
360       like $@, qr/^Undefined subroutine &mb called at /,
361         'my sub foo {} after forward declaration (amper)';
362     }
363     44
364   }
365   mb(1);
366   sub mb2 { 43 }
367   my sub sb2;
368   sub mb2 {
369     if (shift) {
370       package bar;
371       is mb2, 44, 'my sub visible inside itself after decl';
372       is &mb2, 44, 'my sub visible inside itself after decl (amper)';
373     }
374     44
375   }
376   mb2(1);
377   my sub mb3;
378   {
379     my sub mb3 { # new pad entry
380       # The sub containing this comment is invisible inside itself.
381       # So this one here will assign to the outer pad entry:
382       sub mb3 { 47 }
383     }
384   }
385   is eval{mb3}, 47,
386     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
387   # Same test again, but inside an anonymous sub
388   sub {
389     my sub mb4;
390     {
391       my sub mb4 {
392         sub mb4 { 47 }
393       }
394     }
395     is mb4, 47,
396       'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
397   }->();
398 }
399 sub mc { 43 }
400 {
401   my sub mc;
402   eval{mc};
403   like $@, qr/^Undefined subroutine &mc called at /,
404      'my sub foo; makes no lex alias for existing sub';
405   eval{&mc};
406   like $@, qr/^Undefined subroutine &mc called at /,
407      'my sub foo; makes no lex alias for existing sub (amper)';
408 }
409 package main;
410 {
411   my sub me ($);
412   is prototype eval{\&me}, '$', 'my sub with proto';
413   is prototype "me", undef, 'prototype "..." ignores my subs';
414
415   my $coderef = eval "my sub foo (\$\x{30cd}) {1}; \\&foo";
416   my $proto = prototype $coderef;
417   ok(utf8::is_utf8($proto), "my sub with UTF8 proto maintains the UTF8ness");
418   is($proto, "\$\x{30cd}", "check the prototypes actually match");
419 }
420 {
421   my sub if() { 44 }
422   my $x = if if if;
423   is $x, 44, 'my subs override all keywords';
424   package bar;
425   my $y = if if if;
426   is $y, 44, 'my subs from other packages override all keywords';
427 }
428 {
429   use warnings; no warnings "experimental::lexical_subs";
430   my $w ;
431   local $SIG{__WARN__} = sub { $w .= shift };
432   eval '#line 87 squidges
433     my sub foo;
434     my sub foo {};
435   ';
436   is $w,
437      '"my" subroutine &foo masks earlier declaration in same scope at '
438    . "squidges line 88.\n",
439      'warning for my sub masking earlier declaration';
440 }
441 # Test that my subs are cloned inside anonymous subs.
442 sub mmake_closure {
443   my $x = shift;
444   sub {
445     my sub foo { $x }
446     foo
447   }
448 }
449 $sub1 = mmake_closure 48;
450 $sub2 = mmake_closure 49;
451 is &$sub1, 48, 'my sub in closure (1)';
452 is &$sub2, 49, 'my sub in closure (2)';
453 # Test that they are cloned in named subs.
454 {
455   use warnings; no warnings "experimental::lexical_subs";
456   my $w;
457   local $SIG{__WARN__} = sub { $w .= shift };
458   eval '#line 65 teetet
459     sub mfoom {
460       my $x = shift;
461       my sub poom { $x }
462       \&poom
463     }
464   ';
465   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
466   my $poom = mfoom(27);
467   my $poom2 = mfoom(678);
468   is $poom->(), 27, 'my subs closing over outer my var (1)';
469   is $poom2->(), 678, 'my subs closing over outer my var (2)';
470   my $x = 43;
471   my sub aoeu;
472   for $x (765) {
473     my sub etetetet { $x }
474     sub aoeu { $x }
475     is etetetet, 765, 'my sub respects for() localisation';
476     is aoeu, 43, 'unless it is declared outside the for loop';
477   }
478 }
479 # And we also need to test that multiple my subs can close over each
480 # other’s entries in the parent subs pad, and that cv_clone is not con-
481 # fused by that.
482 sub make_anon_with_my_sub{
483   sub {
484     my sub s1;
485     my sub s2 { \&s1 }
486     sub s1 { \&s2 }
487     if (@_) { return eval { \&s1 } }
488     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
489     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
490   }
491 }
492
493 # Test my subs inside predeclared my subs
494 {
495   my sub s2;
496   sub s2 {
497     my $x = 3;
498     my sub s3 { eval '$x' }
499     s3;
500   }
501   is s2, 3, 'my sub inside predeclared my sub';
502 }
503
504 {
505   my $s = make_anon_with_my_sub;
506   &$s;
507
508   # And make sure the my subs were actually cloned.
509   isnt make_anon_with_my_sub->(0), &$s(0),
510     'my subs in anon subs are cloned';
511   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
512 }
513 {
514   my sub BEGIN { exit };
515   pass 'my subs are never special blocks';
516   my sub END { shift }
517   is END('jkqeudth'), jkqeudth,
518     'my sub END {shift} implies @_, not @ARGV';
519 }
520 {
521   my sub redef {}
522   use warnings; no warnings "experimental::lexical_subs";
523   my $w;
524   local $SIG{__WARN__} = sub { $w .= shift };
525   eval "#line 56 pygpyf\nsub redef {}";
526   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
527          "sub redefinition warnings from my subs";
528
529   undef $w;
530   sub {
531     my sub x {};
532     sub { eval "#line 87 khaki\n\\&x" }
533   }->()();
534   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
535          "unavailability warning during compilation of eval in closure";
536
537   undef $w;
538   no warnings 'void';
539   eval <<'->()();';
540 #line 87 khaki
541     sub {
542       my sub x{}
543       sub not_lexical8 {
544         \&x
545       }
546     }
547 ->()();
548   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
549          "unavailability warning during compilation of named sub in anon";
550
551   undef $w;
552   sub not_lexical9 {
553     my sub x {};
554     format =
555 @
556 &x
557 .
558   }
559   eval { write };
560   my($f,$l) = (__FILE__,__LINE__ - 1);
561   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
562          'unavailability warning during cloning';
563   $l -= 3;
564   is $@, "Undefined subroutine &x called at $f line $l.\n",
565          'Vivified sub is correctly named';
566 }
567 sub not_lexical10 {
568   my sub foo;
569   foo();
570   sub not_lexical11 {
571     my sub bar {
572       my $x = 'khaki car keys for the khaki car';
573       not_lexical10();
574       sub foo {
575        is $x, 'khaki car keys for the khaki car',
576        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
577       }
578     }
579     bar()
580   }
581 }
582 not_lexical11();
583 {
584   my sub p (\@) {
585     is ref $_[0], 'ARRAY', 'my sub with proto';
586   }
587   p(my @a);
588   p @a;
589   my sub q () { 46 }
590   is q(), 46, 'my constant called with parens';
591 }
592 {
593   my sub x;
594   my $count;
595   sub x { x() if $count++ < 10 }
596   x();
597   is $count, 11, 'my recursive subs';
598 }
599 {
600   my sub x;
601   eval 'sub x {3}';
602   is x, 3, 'my sub defined inside eval';
603 }
604
605 {
606   state $w;
607   local $SIG{__WARN__} = sub { $w .= shift };
608   eval q{ my sub george () { 2 } };
609   is $w, undef, 'no double free from constant my subs';
610 }
611 like runperl(
612       switches => [ '-Mfeature=lexical_subs,state' ],
613       prog     => 'my sub a { foo ref } a()',
614       stderr   => 1
615      ),
616      qr/syntax error/,
617     'referencing a my sub after a syntax error does not crash';
618 {
619   state $stuff;
620   package A {
621     my sub foo{ $stuff .= our $AUTOLOAD }
622     *A::AUTOLOAD = \&foo;
623   }
624   A::bar();
625   is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload';
626 }
627
628 # -------------------- Interactions (and misc tests) -------------------- #
629
630 is sub {
631     my sub s1;
632     my sub s2 { 3 };
633     sub s1 { state sub foo { \&s2 } foo }
634     s1
635   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
636
637 {
638   my sub s2 { 3 };
639   sub not_lexical { state sub foo { \&s2 } foo }
640   is not_lexical->(), 3, 'state subs that reference my sub from outside';
641 }
642
643 # Test my subs inside predeclared package subs
644 # This test also checks that CvOUTSIDE pointers are not mangled when the
645 # inner sub’s CvOUTSIDE points to another sub.
646 sub not_lexical2;
647 sub not_lexical2 {
648   my $x = 23;
649   my sub bar;
650   sub not_lexical3 {
651     not_lexical2();
652     sub bar { $x }
653   };
654   bar
655 }
656 is not_lexical3, 23, 'my subs inside predeclared package subs';
657
658 # Test my subs inside predeclared package sub, where the lexical sub is
659 # declared outside the package sub.
660 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
661 # not declared inside the sub that its CvOUTSIDE points to.
662 sub not_lexical5 {
663   my sub foo;
664   sub not_lexical4;
665   sub not_lexical4 {
666     my $x = 234;
667     not_lexical5();
668     sub foo { $x }
669   }
670   foo
671 }
672 is not_lexical4, 234,
673     'my sub defined in predeclared pkg sub but declared outside';
674
675 undef *not_lexical6;
676 {
677   my sub foo;
678   sub not_lexical6 { sub foo { } }
679   pass 'no crash when cloning a mysub declared inside an undef pack sub';
680 }
681
682 undef &not_lexical7;
683 eval 'sub not_lexical7 { my @x }';
684 {
685   my sub foo;
686   foo();
687   sub not_lexical7 {
688     state $x;
689     sub foo {
690       is ref \$x, 'SCALAR',
691         "redeffing a mysub's outside does not make it use the wrong pad"
692     }
693   }
694 }
695
696 like runperl(
697       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
698       prog     => 'my sub foo; sub foo { foo } foo',
699       stderr   => 1
700      ),
701      qr/Deep recursion on subroutine "foo"/,
702     'deep recursion warnings for lexical subs do not crash';
703
704 like runperl(
705       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
706       prog     => 'my sub foo() { 42 } undef &foo',
707       stderr   => 1
708      ),
709      qr/Constant subroutine foo undefined at /,
710     'constant undefinition warnings for lexical subs do not crash';
711
712 {
713   my sub foo;
714   *AutoloadTestSuper::blah = \&foo;
715   sub AutoloadTestSuper::AUTOLOAD {
716     is $AutoloadTestSuper::AUTOLOAD, "AutoloadTestSuper::blah",
717       "Autoloading via inherited lex stub";
718   }
719   @AutoloadTest::ISA = AutoloadTestSuper::;
720   AutoloadTest->blah;
721 }