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 overload
[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 124;
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   state sub quire{qr "quires"}
327   package o { use overload qr => \&quire }
328   ok "quires" =~ bless([], o::), 'state sub used as overload method';
329 }
330
331 # -------------------- my -------------------- #
332
333 {
334   my sub foo { 44 }
335   isnt \&::foo, \&foo, 'my sub is not stored in the package';
336   is foo, 44, 'calling my sub from same package';
337   is &foo, 44, 'calling my sub from same package (amper)';
338   package bar;
339   is foo, 44, 'calling my sub from another package';
340   is &foo, 44, 'calling my sub from another package (amper)';
341 }
342 package bar;
343 is foo, 43, 'my sub falling out of scope';
344 is &foo, 43, 'my sub falling out of scope (called via amper)';
345 {
346   sub ma { 43 }
347   my sub ma {
348     if (shift) {
349       is ma, 43, 'my sub invisible inside itself';
350       is &ma, 43, 'my sub invisible inside itself (called via amper)';
351     }
352     44
353   }
354   ma(1);
355   sub mb { 43 }
356   my sub mb;
357   my sub mb {
358     if (shift) {
359       # ‘my sub foo{}’ creates a new pad entry, not reusing the forward
360       #  declaration.  Being invisible inside itself, it sees the stub.
361       eval{mb};
362       like $@, qr/^Undefined subroutine &mb called at /,
363         'my sub foo {} after forward declaration';
364       eval{&mb};
365       like $@, qr/^Undefined subroutine &mb called at /,
366         'my sub foo {} after forward declaration (amper)';
367     }
368     44
369   }
370   mb(1);
371   sub mb2 { 43 }
372   my sub sb2;
373   sub mb2 {
374     if (shift) {
375       package bar;
376       is mb2, 44, 'my sub visible inside itself after decl';
377       is &mb2, 44, 'my sub visible inside itself after decl (amper)';
378     }
379     44
380   }
381   mb2(1);
382   my sub mb3;
383   {
384     my sub mb3 { # new pad entry
385       # The sub containing this comment is invisible inside itself.
386       # So this one here will assign to the outer pad entry:
387       sub mb3 { 47 }
388     }
389   }
390   is eval{mb3}, 47,
391     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
392   # Same test again, but inside an anonymous sub
393   sub {
394     my sub mb4;
395     {
396       my sub mb4 {
397         sub mb4 { 47 }
398       }
399     }
400     is mb4, 47,
401       'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
402   }->();
403 }
404 sub mc { 43 }
405 {
406   my sub mc;
407   eval{mc};
408   like $@, qr/^Undefined subroutine &mc called at /,
409      'my sub foo; makes no lex alias for existing sub';
410   eval{&mc};
411   like $@, qr/^Undefined subroutine &mc called at /,
412      'my sub foo; makes no lex alias for existing sub (amper)';
413 }
414 package main;
415 {
416   my sub me ($);
417   is prototype eval{\&me}, '$', 'my sub with proto';
418   is prototype "me", undef, 'prototype "..." ignores my subs';
419
420   my $coderef = eval "my sub foo (\$\x{30cd}) {1}; \\&foo";
421   my $proto = prototype $coderef;
422   ok(utf8::is_utf8($proto), "my sub with UTF8 proto maintains the UTF8ness");
423   is($proto, "\$\x{30cd}", "check the prototypes actually match");
424 }
425 {
426   my sub if() { 44 }
427   my $x = if if if;
428   is $x, 44, 'my subs override all keywords';
429   package bar;
430   my $y = if if if;
431   is $y, 44, 'my subs from other packages override all keywords';
432 }
433 {
434   use warnings; no warnings "experimental::lexical_subs";
435   my $w ;
436   local $SIG{__WARN__} = sub { $w .= shift };
437   eval '#line 87 squidges
438     my sub foo;
439     my sub foo {};
440   ';
441   is $w,
442      '"my" subroutine &foo masks earlier declaration in same scope at '
443    . "squidges line 88.\n",
444      'warning for my sub masking earlier declaration';
445 }
446 # Test that my subs are cloned inside anonymous subs.
447 sub mmake_closure {
448   my $x = shift;
449   sub {
450     my sub foo { $x }
451     foo
452   }
453 }
454 $sub1 = mmake_closure 48;
455 $sub2 = mmake_closure 49;
456 is &$sub1, 48, 'my sub in closure (1)';
457 is &$sub2, 49, 'my sub in closure (2)';
458 # Test that they are cloned in named subs.
459 {
460   use warnings; no warnings "experimental::lexical_subs";
461   my $w;
462   local $SIG{__WARN__} = sub { $w .= shift };
463   eval '#line 65 teetet
464     sub mfoom {
465       my $x = shift;
466       my sub poom { $x }
467       \&poom
468     }
469   ';
470   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
471   my $poom = mfoom(27);
472   my $poom2 = mfoom(678);
473   is $poom->(), 27, 'my subs closing over outer my var (1)';
474   is $poom2->(), 678, 'my subs closing over outer my var (2)';
475   my $x = 43;
476   my sub aoeu;
477   for $x (765) {
478     my sub etetetet { $x }
479     sub aoeu { $x }
480     is etetetet, 765, 'my sub respects for() localisation';
481     is aoeu, 43, 'unless it is declared outside the for loop';
482   }
483 }
484 # And we also need to test that multiple my subs can close over each
485 # other’s entries in the parent subs pad, and that cv_clone is not con-
486 # fused by that.
487 sub make_anon_with_my_sub{
488   sub {
489     my sub s1;
490     my sub s2 { \&s1 }
491     sub s1 { \&s2 }
492     if (@_) { return eval { \&s1 } }
493     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
494     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
495   }
496 }
497
498 # Test my subs inside predeclared my subs
499 {
500   my sub s2;
501   sub s2 {
502     my $x = 3;
503     my sub s3 { eval '$x' }
504     s3;
505   }
506   is s2, 3, 'my sub inside predeclared my sub';
507 }
508
509 {
510   my $s = make_anon_with_my_sub;
511   &$s;
512
513   # And make sure the my subs were actually cloned.
514   isnt make_anon_with_my_sub->(0), &$s(0),
515     'my subs in anon subs are cloned';
516   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
517 }
518 {
519   my sub BEGIN { exit };
520   pass 'my subs are never special blocks';
521   my sub END { shift }
522   is END('jkqeudth'), jkqeudth,
523     'my sub END {shift} implies @_, not @ARGV';
524 }
525 {
526   my sub redef {}
527   use warnings; no warnings "experimental::lexical_subs";
528   my $w;
529   local $SIG{__WARN__} = sub { $w .= shift };
530   eval "#line 56 pygpyf\nsub redef {}";
531   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
532          "sub redefinition warnings from my subs";
533
534   undef $w;
535   sub {
536     my sub x {};
537     sub { eval "#line 87 khaki\n\\&x" }
538   }->()();
539   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
540          "unavailability warning during compilation of eval in closure";
541
542   undef $w;
543   no warnings 'void';
544   eval <<'->()();';
545 #line 87 khaki
546     sub {
547       my sub x{}
548       sub not_lexical8 {
549         \&x
550       }
551     }
552 ->()();
553   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
554          "unavailability warning during compilation of named sub in anon";
555
556   undef $w;
557   sub not_lexical9 {
558     my sub x {};
559     format =
560 @
561 &x
562 .
563   }
564   eval { write };
565   my($f,$l) = (__FILE__,__LINE__ - 1);
566   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
567          'unavailability warning during cloning';
568   $l -= 3;
569   is $@, "Undefined subroutine &x called at $f line $l.\n",
570          'Vivified sub is correctly named';
571 }
572 sub not_lexical10 {
573   my sub foo;
574   foo();
575   sub not_lexical11 {
576     my sub bar {
577       my $x = 'khaki car keys for the khaki car';
578       not_lexical10();
579       sub foo {
580        is $x, 'khaki car keys for the khaki car',
581        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
582       }
583     }
584     bar()
585   }
586 }
587 not_lexical11();
588 {
589   my sub p (\@) {
590     is ref $_[0], 'ARRAY', 'my sub with proto';
591   }
592   p(my @a);
593   p @a;
594   my sub q () { 46 }
595   is q(), 46, 'my constant called with parens';
596 }
597 {
598   my sub x;
599   my $count;
600   sub x { x() if $count++ < 10 }
601   x();
602   is $count, 11, 'my recursive subs';
603 }
604 {
605   my sub x;
606   eval 'sub x {3}';
607   is x, 3, 'my sub defined inside eval';
608 }
609
610 {
611   state $w;
612   local $SIG{__WARN__} = sub { $w .= shift };
613   eval q{ my sub george () { 2 } };
614   is $w, undef, 'no double free from constant my subs';
615 }
616 like runperl(
617       switches => [ '-Mfeature=lexical_subs,state' ],
618       prog     => 'my sub a { foo ref } a()',
619       stderr   => 1
620      ),
621      qr/syntax error/,
622     'referencing a my sub after a syntax error does not crash';
623 {
624   state $stuff;
625   package A {
626     my sub foo{ $stuff .= our $AUTOLOAD }
627     *A::AUTOLOAD = \&foo;
628   }
629   A::bar();
630   is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload';
631 }
632 {
633   my sub quire{qr "quires"}
634   package mo { use overload qr => \&quire }
635   ok "quires" =~ bless([], mo::), 'my sub used as overload method';
636 }
637
638 # -------------------- Interactions (and misc tests) -------------------- #
639
640 is sub {
641     my sub s1;
642     my sub s2 { 3 };
643     sub s1 { state sub foo { \&s2 } foo }
644     s1
645   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
646
647 {
648   my sub s2 { 3 };
649   sub not_lexical { state sub foo { \&s2 } foo }
650   is not_lexical->(), 3, 'state subs that reference my sub from outside';
651 }
652
653 # Test my subs inside predeclared package subs
654 # This test also checks that CvOUTSIDE pointers are not mangled when the
655 # inner sub’s CvOUTSIDE points to another sub.
656 sub not_lexical2;
657 sub not_lexical2 {
658   my $x = 23;
659   my sub bar;
660   sub not_lexical3 {
661     not_lexical2();
662     sub bar { $x }
663   };
664   bar
665 }
666 is not_lexical3, 23, 'my subs inside predeclared package subs';
667
668 # Test my subs inside predeclared package sub, where the lexical sub is
669 # declared outside the package sub.
670 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
671 # not declared inside the sub that its CvOUTSIDE points to.
672 sub not_lexical5 {
673   my sub foo;
674   sub not_lexical4;
675   sub not_lexical4 {
676     my $x = 234;
677     not_lexical5();
678     sub foo { $x }
679   }
680   foo
681 }
682 is not_lexical4, 234,
683     'my sub defined in predeclared pkg sub but declared outside';
684
685 undef *not_lexical6;
686 {
687   my sub foo;
688   sub not_lexical6 { sub foo { } }
689   pass 'no crash when cloning a mysub declared inside an undef pack sub';
690 }
691
692 undef &not_lexical7;
693 eval 'sub not_lexical7 { my @x }';
694 {
695   my sub foo;
696   foo();
697   sub not_lexical7 {
698     state $x;
699     sub foo {
700       is ref \$x, 'SCALAR',
701         "redeffing a mysub's outside does not make it use the wrong pad"
702     }
703   }
704 }
705
706 like runperl(
707       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
708       prog     => 'my sub foo; sub foo { foo } foo',
709       stderr   => 1
710      ),
711      qr/Deep recursion on subroutine "foo"/,
712     'deep recursion warnings for lexical subs do not crash';
713
714 like runperl(
715       switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ],
716       prog     => 'my sub foo() { 42 } undef &foo',
717       stderr   => 1
718      ),
719      qr/Constant subroutine foo undefined at /,
720     'constant undefinition warnings for lexical subs do not crash';
721
722 {
723   my sub foo;
724   *AutoloadTestSuper::blah = \&foo;
725   sub AutoloadTestSuper::AUTOLOAD {
726     is $AutoloadTestSuper::AUTOLOAD, "AutoloadTestSuper::blah",
727       "Autoloading via inherited lex stub";
728   }
729   @AutoloadTest::ISA = AutoloadTestSuper::;
730   AutoloadTest->blah;
731 }