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