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