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