4dc223f9eada9341138e91acc6820213c33e0e88
[perl.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 plan 127;
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;
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;
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;
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 }
303 {
304   state sub x;
305   eval 'sub x {3}';
306   is x, 3, 'state sub defined inside eval';
307
308   sub r {
309     state sub foo { 3 };
310     if (@_) { # outer call
311       r();
312       is foo(), 42,
313          'state sub run-time redefinition applies to all recursion levels';
314     }
315     else { # inner call
316       eval 'sub foo { 42 }';
317     }
318   }
319   r(1);
320 }
321
322 # -------------------- my -------------------- #
323
324 {
325   my sub foo { 44 }
326   isnt \&::foo, \&foo, 'my sub is not stored in the package';
327   is foo, 44, 'calling my sub from same package';
328   is &foo, 44, 'calling my sub from same package (amper)';
329   is do foo(), 44, 'calling my sub from same package (do)';
330   package bar;
331   is foo, 44, 'calling my sub from another package';
332   is &foo, 44, 'calling my sub from another package (amper)';
333   is do foo(), 44, 'calling my sub from another package (do)';
334 }
335 package bar;
336 is foo, 43, 'my sub falling out of scope';
337 is &foo, 43, 'my sub falling out of scope (called via amper)';
338 is do foo(), 43, 'my sub falling out of scope (called via amper)';
339 {
340   sub ma { 43 }
341   my sub ma {
342     if (shift) {
343       is ma, 43, 'my sub invisible inside itself';
344       is &ma, 43, 'my sub invisible inside itself (called via amper)';
345       is do ma(), 43, 'my sub invisible inside itself (called via do)';
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       eval{do mb()};
363       like $@, qr/^Undefined subroutine &mb called at /,
364         'my sub foo {} after forward declaration (do)';
365     }
366     44
367   }
368   mb(1);
369   sub mb2 { 43 }
370   my sub sb2;
371   sub mb2 {
372     if (shift) {
373       package bar;
374       is mb2, 44, 'my sub visible inside itself after decl';
375       is &mb2, 44, 'my sub visible inside itself after decl (amper)';
376       is do mb2(), 44, 'my sub visible inside itself after decl (do)';
377     }
378     44
379   }
380   mb2(1);
381   my sub mb3;
382   {
383     my sub mb3 { # new pad entry
384       # The sub containing this comment is invisible inside itself.
385       # So this one here will assign to the outer pad entry:
386       sub mb3 { 47 }
387     }
388   }
389   is eval{mb3}, 47,
390     'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
391   # Same test again, but inside an anonymous sub
392   sub {
393     my sub mb4;
394     {
395       my sub mb4 {
396         sub mb4 { 47 }
397       }
398     }
399     is mb4, 47,
400       'sub foo{} applying to "my sub foo;" even inside my sub foo{}';
401   }->();
402 }
403 sub mc { 43 }
404 {
405   my sub mc;
406   eval{mc};
407   like $@, qr/^Undefined subroutine &mc called at /,
408      'my sub foo; makes no lex alias for existing sub';
409   eval{&mc};
410   like $@, qr/^Undefined subroutine &mc called at /,
411      'my sub foo; makes no lex alias for existing sub (amper)';
412   eval{do mc()};
413   like $@, qr/^Undefined subroutine &mc called at /,
414      'my sub foo; makes no lex alias for existing sub (do)';
415 }
416 package main;
417 {
418   my sub me ($);
419   is prototype eval{\&me}, '$', 'my sub with proto';
420   is prototype "me", undef, 'prototype "..." ignores my subs';
421 }
422 {
423   my sub if() { 44 }
424   my $x = if if if;
425   is $x, 44, 'my subs override all keywords';
426   package bar;
427   my $y = if if if;
428   is $y, 44, 'my subs from other packages override all keywords';
429 }
430 {
431   use warnings;
432   my $w ;
433   local $SIG{__WARN__} = sub { $w .= shift };
434   eval '#line 87 squidges
435     my sub foo;
436     my sub foo {};
437   ';
438   is $w,
439      '"my" subroutine &foo masks earlier declaration in same scope at '
440    . "squidges line 88.\n",
441      'warning for my sub masking earlier declaration';
442 }
443 # Test that my subs are cloned inside anonymous subs.
444 sub mmake_closure {
445   my $x = shift;
446   sub {
447     my sub foo { $x }
448     foo
449   }
450 }
451 $sub1 = mmake_closure 48;
452 $sub2 = mmake_closure 49;
453 is &$sub1, 48, 'my sub in closure (1)';
454 is &$sub2, 49, 'my sub in closure (2)';
455 # Test that they are cloned in named subs.
456 {
457   use warnings;
458   my $w;
459   local $SIG{__WARN__} = sub { $w .= shift };
460   eval '#line 65 teetet
461     sub mfoom {
462       my $x = shift;
463       my sub poom { $x }
464       \&poom
465     }
466   ';
467   is $w, undef, 'my subs get no "Variable will not stay shared" messages';
468   my $poom = mfoom(27);
469   my $poom2 = mfoom(678);
470   is $poom->(), 27, 'my subs closing over outer my var (1)';
471   is $poom2->(), 678, 'my subs closing over outer my var (2)';
472   my $x = 43;
473   my sub aoeu;
474   for $x (765) {
475     my sub etetetet { $x }
476     sub aoeu { $x }
477     is etetetet, 765, 'my sub respects for() localisation';
478     is aoeu, 43, 'unless it is declared outside the for loop';
479   }
480 }
481 # And we also need to test that multiple my subs can close over each
482 # other’s entries in the parent subs pad, and that cv_clone is not con-
483 # fused by that.
484 sub make_anon_with_my_sub{
485   sub {
486     my sub s1;
487     my sub s2 { \&s1 }
488     sub s1 { \&s2 }
489     if (@_) { return eval { \&s1 } }
490     is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub';
491     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
492   }
493 }
494
495 # Test my subs inside predeclared my subs
496 {
497   my sub s2;
498   sub s2 {
499     my $x = 3;
500     my sub s3 { eval '$x' }
501     s3;
502   }
503   is s2, 3, 'my sub inside predeclared my sub';
504 }
505
506 {
507   my $s = make_anon_with_my_sub;
508   &$s;
509
510   # And make sure the my subs were actually cloned.
511   isnt make_anon_with_my_sub->(0), &$s(0),
512     'my subs in anon subs are cloned';
513   isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub';
514 }
515 {
516   my sub BEGIN { exit };
517   pass 'my subs are never special blocks';
518   my sub END { shift }
519   is END('jkqeudth'), jkqeudth,
520     'my sub END {shift} implies @_, not @ARGV';
521 }
522 {
523   my sub redef {}
524   use warnings;
525   my $w;
526   local $SIG{__WARN__} = sub { $w .= shift };
527   eval "#line 56 pygpyf\nsub redef {}";
528   is $w, "Subroutine redef redefined at pygpyf line 56.\n",
529          "sub redefinition warnings from my subs";
530
531   undef $w;
532   sub {
533     my sub x {};
534     sub { eval "#line 87 khaki\n\\&x" }
535   }->()();
536   is $w, "Subroutine \"&x\" is not available at khaki line 87.\n",
537          "unavailability warning during compilation of eval in closure";
538
539   undef $w;
540   no warnings 'void';
541   eval <<'->()();';
542 #line 87 khaki
543     sub {
544       my sub x{}
545       sub not_lexical8 {
546         \&x
547       }
548     }
549 ->()();
550   is $w, "Subroutine \"&x\" is not available at khaki line 90.\n",
551          "unavailability warning during compilation of named sub in anon";
552
553   undef $w;
554   sub not_lexical9 {
555     my sub x {};
556     format =
557 @
558 &x
559 .
560   }
561   eval { write };
562   my($f,$l) = (__FILE__,__LINE__ - 1);
563   is $w, "Subroutine \"&x\" is not available at $f line $l.\n",
564          'unavailability warning during cloning';
565   $l -= 3;
566   is $@, "Undefined subroutine &x called at $f line $l.\n",
567          'Vivified sub is correctly named';
568 }
569 sub not_lexical10 {
570   my sub foo;
571   foo();
572   sub not_lexical11 {
573     my sub bar {
574       my $x = 'khaki car keys for the khaki car';
575       not_lexical10();
576       sub foo {
577        is $x, 'khaki car keys for the khaki car',
578        'mysubs in inner clonables use the running clone of their CvOUTSIDE'
579       }
580     }
581     bar()
582   }
583 }
584 not_lexical11();
585 {
586   my sub p (\@) {
587     is ref $_[0], 'ARRAY', 'my sub with proto';
588   }
589   p(my @a);
590 }
591 {
592   my sub x;
593   my $count;
594   sub x { x() if $count++ < 10 }
595   x();
596   is $count, 11, 'my recursive subs';
597 }
598 {
599   my sub x;
600   eval 'sub x {3}';
601   is x, 3, 'my sub defined inside eval';
602 }
603
604 # -------------------- Interactions (and misc tests) -------------------- #
605
606 is sub {
607     my sub s1;
608     my sub s2 { 3 };
609     sub s1 { state sub foo { \&s2 } foo }
610     s1
611   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
612
613 {
614   my sub s2 { 3 };
615   sub not_lexical { state sub foo { \&s2 } foo }
616   is not_lexical->(), 3, 'state subs that reference my sub from outside';
617 }
618
619 # Test my subs inside predeclared package subs
620 # This test also checks that CvOUTSIDE pointers are not mangled when the
621 # inner sub’s CvOUTSIDE points to another sub.
622 sub not_lexical2;
623 sub not_lexical2 {
624   my $x = 23;
625   my sub bar;
626   sub not_lexical3 {
627     not_lexical2();
628     sub bar { $x }
629   };
630   bar
631 }
632 is not_lexical3, 23, 'my subs inside predeclared package subs';
633
634 # Test my subs inside predeclared package sub, where the lexical sub is
635 # declared outside the package sub.
636 # This checks that CvOUTSIDE pointers are fixed up even when the sub is
637 # not declared inside the sub that its CvOUTSIDE points to.
638 sub not_lexical5 {
639   my sub foo;
640   sub not_lexical4;
641   sub not_lexical4 {
642     my $x = 234;
643     not_lexical5();
644     sub foo { $x }
645   }
646   foo
647 }
648 is not_lexical4, 234,
649     'my sub defined in predeclared pkg sub but declared outside';
650
651 undef *not_lexical6;
652 {
653   my sub foo;
654   sub not_lexical6 { sub foo { } }
655   pass 'no crash when cloning a mysub declared inside an undef pack sub';
656 }
657
658 undef &not_lexical7;
659 eval 'sub not_lexical7 { my @x }';
660 {
661   my sub foo;
662   foo();
663   sub not_lexical7 {
664     state $x;
665     sub foo {
666       is ref \$x, 'SCALAR',
667         "redeffing a mysub's outside does not make it use the wrong pad"
668     }
669   }
670 }