This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d70f2ccf2bad9491149d7093cba12ea4c3a90158
[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 134;
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 {
433   my sub if() { 44 }
434   my $x = if if if;
435   is $x, 44, 'my subs override all keywords';
436   package bar;
437   my $y = if if if;
438   is $y, 44, 'my subs from other packages override all keywords';
439 }
440 {
441   use warnings; no warnings "experimental::lexical_subs";
442   my $w ;
443   local $SIG{__WARN__} = sub { $w .= shift };
444   eval '#line 87 squidges
445     my sub foo;
446     my sub foo {};
447   ';
448   is $w,
449      '"my" subroutine &foo masks earlier declaration in same scope at '
450    . "squidges line 88.\n",
451      'warning for my sub masking earlier declaration';
452 }
453 # Test that my subs are cloned inside anonymous subs.
454 sub mmake_closure {
455   my $x = shift;
456   sub {
457     my sub foo { $x }
458     foo
459   }
460 }
461 $sub1 = mmake_closure 48;
462 $sub2 = mmake_closure 49;
463 is &$sub1, 48, 'my sub in closure (1)';
464 is &$sub2, 49, 'my sub in closure (2)';
465 # Test that they are cloned in named subs.
466 {
467   use warnings; no warnings "experimental::lexical_subs";
468   my $w;
469   local $SIG{__WARN__} = sub { $w .= shift };
470   eval '#line 65 teetet
471     sub mfoom {
472       my $x = shift;
473       my sub poom { $x }
474       \&poom
475     }
476   ';
477   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
478   my $poom = mfoom(27);
479   my $poom2 = mfoom(678);
480   is $poom->(), 27, 'my subs closing over outer my var (1)';
481   is $poom2->(), 678, 'my subs closing over outer my var (2)';
482   my $x = 43;
483   my sub aoeu;
484   for $x (765) {
485     my sub etetetet { $x }
486     sub aoeu { $x }
487     is etetetet, 765, 'my sub respects for() localisation';
488     is aoeu, 43, 'unless it is declared outside the for loop';
489   }
490 }
491 # And we also need to test that multiple my subs can close over each
492 # other’s entries in the parent subs pad, and that cv_clone is not con-
493 # fused by that.
494 sub make_anon_with_my_sub{
495   sub {
496     my sub s1;
497     my sub s2 { \&s1 }
498     sub s1 { \&s2 }
499     if (@_) { return eval { \&s1 } }
500     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
501     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
502   }
503 }
504
505 # Test my subs inside predeclared my subs
506 {
507   my sub s2;
508   sub s2 {
509     my $x = 3;
510     my sub s3 { eval '$x' }
511     s3;
512   }
513   is s2, 3, 'my sub inside predeclared my sub';
514 }
515
516 {
517   my $s = make_anon_with_my_sub;
518   &$s;
519
520   # And make sure the my subs were actually cloned.
521   isnt make_anon_with_my_sub->(0), &$s(0),
522     'my subs in anon subs are cloned';
523   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
524 }
525 {
526   my sub BEGIN { exit };
527   pass 'my subs are never special blocks';
528   my sub END { shift }
529   is END('jkqeudth'), jkqeudth,
530     'my sub END {shift} implies @_, not @ARGV';
531 }
532 {
533   my sub redef {}
534   use warnings; no warnings "experimental::lexical_subs";
535   my $w;
536   local $SIG{__WARN__} = sub { $w .= shift };
537   eval "#line 56 pygpyf\nsub redef {}";
538   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
539          "sub redefinition warnings from my subs";
540
541   undef $w;
542   sub {
543     my sub x {};
544     sub { eval "#line 87 khaki\n\\&x" }
545   }->()();
546   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
547          "unavailability warning during compilation of eval in closure";
548
549   undef $w;
550   no warnings 'void';
551   eval <<'->()();';
552 #line 87 khaki
553     sub {
554       my sub x{}
555       sub not_lexical8 {
556         \&x
557       }
558     }
559 ->()();
560   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
561          "unavailability warning during compilation of named sub in anon";
562
563   undef $w;
564   sub not_lexical9 {
565     my sub x {};
566     format =
567 @
568 &x
569 .
570   }
571   eval { write };
572   my($f,$l) = (__FILE__,__LINE__ - 1);
573   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
574          'unavailability warning during cloning';
575   $l -= 3;
576   is $@, "Undefined subroutine &x called at $f line $l.\n",
577          'Vivified sub is correctly named';
578 }
579 sub not_lexical10 {
580   my sub foo;
581   foo();
582   sub not_lexical11 {
583     my sub bar {
584       my $x = 'khaki car keys for the khaki car';
585       not_lexical10();
586       sub foo {
587        is $x, 'khaki car keys for the khaki car',
588        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
589       }
590     }
591     bar()
592   }
593 }
594 not_lexical11();
595 {
596   my sub p (\@) {
597     is ref $_[0], 'ARRAY', 'my sub with proto';
598   }
599   p(my @a);
600   p @a;
601   my sub q () { 46 }
602   is q(), 46, 'my constant called with parens';
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 like runperl(
624       switches => [ '-Mfeature=:all' ],
625       prog     => 'my sub a { foo ref } a()',
626       stderr   => 1
627      ),
628      qr/syntax error/,
629     'referencing a my sub after a syntax error does not crash';
630
631 # -------------------- Interactions (and misc tests) -------------------- #
632
633 is sub {
634     my sub s1;
635     my sub s2 { 3 };
636     sub s1 { state sub foo { \&s2 } foo }
637     s1
638   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
639
640 {
641   my sub s2 { 3 };
642   sub not_lexical { state sub foo { \&s2 } foo }
643   is not_lexical->(), 3, 'state subs that reference my sub from outside';
644 }
645
646 # Test my subs inside predeclared package subs
647 # This test also checks that CvOUTSIDE pointers are not mangled when the
648 # inner sub’s CvOUTSIDE points to another sub.
649 sub not_lexical2;
650 sub not_lexical2 {
651   my $x = 23;
652   my sub bar;
653   sub not_lexical3 {
654     not_lexical2();
655     sub bar { $x }
656   };
657   bar
658 }
659 is not_lexical3, 23, 'my subs inside predeclared package subs';
660
661 # Test my subs inside predeclared package sub, where the lexical sub is
662 # declared outside the package sub.
663 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
664 # not declared inside the sub that its CvOUTSIDE points to.
665 sub not_lexical5 {
666   my sub foo;
667   sub not_lexical4;
668   sub not_lexical4 {
669     my $x = 234;
670     not_lexical5();
671     sub foo { $x }
672   }
673   foo
674 }
675 is not_lexical4, 234,
676     'my sub defined in predeclared pkg sub but declared outside';
677
678 undef *not_lexical6;
679 {
680   my sub foo;
681   sub not_lexical6 { sub foo { } }
682   pass 'no crash when cloning a mysub declared inside an undef pack sub';
683 }
684
685 undef &not_lexical7;
686 eval 'sub not_lexical7 { my @x }';
687 {
688   my sub foo;
689   foo();
690   sub not_lexical7 {
691     state $x;
692     sub foo {
693       is ref \$x, 'SCALAR',
694         "redeffing a mysub's outside does not make it use the wrong pad"
695     }
696   }
697 }