Commit | Line | Data |
---|---|---|
c07656ed FC |
1 | #!perl |
2 | ||
39075fb1 FC |
3 | BEGIN { |
4 | chdir 't'; | |
4b473a5a | 5 | @INC = '../lib'; |
39075fb1 FC |
6 | require './test.pl'; |
7 | *bar::is = *is; | |
21452252 | 8 | *bar::like = *like; |
39075fb1 | 9 | } |
8536f7a0 | 10 | plan 130; |
e7d0b801 FC |
11 | |
12 | # -------------------- Errors with feature disabled -------------------- # | |
13 | ||
14 | eval "#line 8 foo\nmy sub foo"; | |
15 | is $@, qq 'Experimental "my" subs not enabled at foo line 8.\n', | |
16 | 'my sub unexperimental error'; | |
17 | eval "#line 8 foo\nCORE::state sub foo"; | |
18 | is $@, qq 'Experimental "state" subs not enabled at foo line 8.\n', | |
19 | 'state sub unexperimental error'; | |
20 | eval "#line 8 foo\nour sub foo"; | |
21 | is $@, qq 'Experimental "our" subs not enabled at foo line 8.\n', | |
22 | 'our sub unexperimental error'; | |
21452252 FC |
23 | |
24 | # -------------------- our -------------------- # | |
c07656ed | 25 | |
f1d34ca8 | 26 | no warnings "experimental::lexical_subs"; |
e7d0b801 | 27 | use feature 'lexical_subs'; |
c07656ed FC |
28 | { |
29 | our sub foo { 42 } | |
39075fb1 FC |
30 | is foo, 42, 'calling our sub from same package'; |
31 | is &foo, 42, 'calling our sub from same package (amper)'; | |
c07656ed FC |
32 | package bar; |
33 | sub bar::foo { 43 } | |
18f70389 | 34 | is foo, 42, 'calling our sub from another package'; |
39075fb1 | 35 | is &foo, 42, 'calling our sub from another package (amper)'; |
c07656ed FC |
36 | } |
37 | package bar; | |
39075fb1 FC |
38 | is foo, 43, 'our sub falling out of scope'; |
39 | is &foo, 43, 'our sub falling out of scope (called via amper)'; | |
c07656ed FC |
40 | package main; |
41 | { | |
42 | sub bar::a { 43 } | |
43 | our sub a { | |
44 | if (shift) { | |
45 | package bar; | |
39075fb1 FC |
46 | is a, 43, 'our sub invisible inside itself'; |
47 | is &a, 43, 'our sub invisible inside itself (called via amper)'; | |
c07656ed FC |
48 | } |
49 | 42 | |
50 | } | |
51 | a(1); | |
52 | sub bar::b { 43 } | |
53 | our sub b; | |
54 | our sub b { | |
55 | if (shift) { | |
56 | package bar; | |
18f70389 | 57 | is b, 42, 'our sub visible inside itself after decl'; |
39075fb1 | 58 | is &b, 42, 'our sub visible inside itself after decl (amper)'; |
c07656ed FC |
59 | } |
60 | 42 | |
61 | } | |
62 | b(1) | |
63 | } | |
64 | sub c { 42 } | |
65 | sub bar::c { 43 } | |
66 | { | |
67 | our sub c; | |
68 | package bar; | |
18f70389 | 69 | is c, 42, 'our sub foo; makes lex alias for existing sub'; |
39075fb1 | 70 | is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)'; |
c07656ed FC |
71 | } |
72 | { | |
73 | our sub d; | |
c07656ed FC |
74 | sub bar::d { 'd43' } |
75 | package bar; | |
945534e1 | 76 | sub d { 'd42' } |
4210d3f1 | 77 | is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}'; |
c07656ed | 78 | } |
60ac52eb FC |
79 | { |
80 | our sub e ($); | |
81 | is prototype "::e", '$', 'our sub with proto'; | |
82 | } | |
18f70389 | 83 | { |
18f70389 FC |
84 | our sub if() { 42 } |
85 | my $x = if if if; | |
f37b842a FC |
86 | is $x, 42, 'lexical subs (even our) override all keywords'; |
87 | package bar; | |
88 | my $y = if if if; | |
89 | is $y, 42, 'our subs from other packages override all keywords'; | |
18f70389 | 90 | } |
8536f7a0 FC |
91 | # Interaction with ‘use constant’ |
92 | { | |
93 | our sub const; # symtab now has an undefined CV | |
94 | BEGIN { delete $::{const} } # delete symtab entry; pad entry still exists | |
95 | use constant const => 3; # symtab now has a scalar ref | |
96 | # inlining this used to fail an assertion (parentheses necessary): | |
97 | is(const, 3, 'our sub pointing to "use constant" constant'); | |
98 | } | |
21452252 FC |
99 | |
100 | # -------------------- state -------------------- # | |
101 | ||
e7d0b801 | 102 | use feature 'state'; # state |
21452252 FC |
103 | { |
104 | state sub foo { 44 } | |
97b03d64 FC |
105 | isnt \&::foo, \&foo, 'state sub is not stored in the package'; |
106 | is eval foo, 44, 'calling state sub from same package'; | |
107 | is eval &foo, 44, 'calling state sub from same package (amper)'; | |
21452252 | 108 | package bar; |
97b03d64 FC |
109 | is eval foo, 44, 'calling state sub from another package'; |
110 | is eval &foo, 44, 'calling state sub from another package (amper)'; | |
21452252 | 111 | } |
21452252 FC |
112 | package bar; |
113 | is foo, 43, 'state sub falling out of scope'; | |
114 | is &foo, 43, 'state sub falling out of scope (called via amper)'; | |
21452252 FC |
115 | { |
116 | sub sa { 43 } | |
117 | state sub sa { | |
118 | if (shift) { | |
119 | is sa, 43, 'state sub invisible inside itself'; | |
120 | is &sa, 43, 'state sub invisible inside itself (called via amper)'; | |
21452252 FC |
121 | } |
122 | 44 | |
123 | } | |
21452252 | 124 | sa(1); |
21452252 FC |
125 | sub sb { 43 } |
126 | state sub sb; | |
127 | state sub sb { | |
128 | if (shift) { | |
129 | # ‘state sub foo{}’ creates a new pad entry, not reusing the forward | |
130 | # declaration. Being invisible inside itself, it sees the stub. | |
131 | eval{sb}; | |
132 | like $@, qr/^Undefined subroutine &sb called at /, | |
133 | 'state sub foo {} after forward declaration'; | |
134 | eval{&sb}; | |
135 | like $@, qr/^Undefined subroutine &sb called at /, | |
136 | 'state sub foo {} after forward declaration (amper)'; | |
21452252 FC |
137 | } |
138 | 44 | |
139 | } | |
21452252 | 140 | sb(1); |
21452252 FC |
141 | sub sb2 { 43 } |
142 | state sub sb2; | |
143 | sub sb2 { | |
144 | if (shift) { | |
145 | package bar; | |
97b03d64 FC |
146 | is sb2, 44, 'state sub visible inside itself after decl'; |
147 | is &sb2, 44, 'state sub visible inside itself after decl (amper)'; | |
21452252 FC |
148 | } |
149 | 44 | |
150 | } | |
21452252 | 151 | sb2(1); |
21452252 FC |
152 | state sub sb3; |
153 | { | |
154 | state sub sb3 { # new pad entry | |
155 | # The sub containing this comment is invisible inside itself. | |
156 | # So this one here will assign to the outer pad entry: | |
157 | sub sb3 { 47 } | |
158 | } | |
159 | } | |
21452252 FC |
160 | is eval{sb3}, 47, |
161 | 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; | |
10342479 FC |
162 | # Same test again, but inside an anonymous sub |
163 | sub { | |
164 | state sub sb4; | |
165 | { | |
166 | state sub sb4 { | |
167 | sub sb4 { 47 } | |
168 | } | |
169 | } | |
170 | is sb4, 47, | |
171 | 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; | |
172 | }->(); | |
21452252 FC |
173 | } |
174 | sub sc { 43 } | |
175 | { | |
176 | state sub sc; | |
177 | eval{sc}; | |
251a11d5 | 178 | like $@, qr/^Undefined subroutine &sc called at /, |
21452252 FC |
179 | 'state sub foo; makes no lex alias for existing sub'; |
180 | eval{&sc}; | |
251a11d5 | 181 | like $@, qr/^Undefined subroutine &sc called at /, |
21452252 | 182 | 'state sub foo; makes no lex alias for existing sub (amper)'; |
21452252 FC |
183 | } |
184 | package main; | |
185 | { | |
186 | state sub se ($); | |
187 | is prototype eval{\&se}, '$', 'state sub with proto'; | |
21452252 FC |
188 | is prototype "se", undef, 'prototype "..." ignores state subs'; |
189 | } | |
190 | { | |
191 | state sub if() { 44 } | |
192 | my $x = if if if; | |
193 | is $x, 44, 'state subs override all keywords'; | |
194 | package bar; | |
195 | my $y = if if if; | |
196 | is $y, 44, 'state subs from other packages override all keywords'; | |
197 | } | |
198 | { | |
64fbf0dd | 199 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
200 | state $w ; |
201 | local $SIG{__WARN__} = sub { $w .= shift }; | |
202 | eval '#line 87 squidges | |
203 | state sub foo; | |
204 | state sub foo {}; | |
205 | '; | |
21452252 | 206 | is $w, |
4eb94d7c | 207 | '"state" subroutine &foo masks earlier declaration in same scope at ' |
21452252 | 208 | . "squidges line 88.\n", |
4eb94d7c | 209 | 'warning for state sub masking earlier declaration'; |
21452252 FC |
210 | } |
211 | # Since state vars inside anonymous subs are cloned at the same time as the | |
212 | # anonymous subs containing them, the same should happen for state subs. | |
213 | sub make_closure { | |
e07561e6 | 214 | my $x = shift; |
21452252 FC |
215 | sub { |
216 | state sub foo { $x } | |
e07561e6 | 217 | foo |
21452252 FC |
218 | } |
219 | } | |
220 | $sub1 = make_closure 48; | |
221 | $sub2 = make_closure 49; | |
222 | is &$sub1, 48, 'state sub in closure (1)'; | |
97b03d64 | 223 | is &$sub2, 49, 'state sub in closure (2)'; |
21452252 FC |
224 | # But we need to test that state subs actually do persist from one invoca- |
225 | # tion of a named sub to another (i.e., that they are not my subs). | |
226 | { | |
64fbf0dd | 227 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
228 | state $w; |
229 | local $SIG{__WARN__} = sub { $w .= shift }; | |
230 | eval '#line 65 teetet | |
231 | sub foom { | |
232 | my $x = shift; | |
233 | state sub poom { $x } | |
234 | eval{\&poom} | |
235 | } | |
236 | '; | |
237 | is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n", | |
238 | 'state subs get "Variable will not stay shared" messages'; | |
239 | my $poom = foom(27); | |
240 | my $poom2 = foom(678); | |
241 | is eval{$poom->()}, eval {$poom2->()}, | |
242 | 'state subs close over the first outer my var, like pkg subs'; | |
243 | my $x = 43; | |
244 | for $x (765) { | |
245 | state sub etetetet { $x } | |
c8e83515 | 246 | is eval{etetetet}, 43, 'state sub ignores for() localisation'; |
21452252 FC |
247 | } |
248 | } | |
e07561e6 FC |
249 | # And we also need to test that multiple state subs can close over each |
250 | # other’s entries in the parent subs pad, and that cv_clone is not con- | |
251 | # fused by that. | |
252 | sub make_anon_with_state_sub{ | |
253 | sub { | |
254 | state sub s1; | |
255 | state sub s2 { \&s1 } | |
256 | sub s1 { \&s2 } | |
257 | if (@_) { return \&s1 } | |
258 | is s1,\&s2, 'state sub in anon closure closing over sibling state sub'; | |
259 | is s2,\&s1, 'state sub in anon closure closing over sibling state sub'; | |
260 | } | |
261 | } | |
262 | { | |
263 | my $s = make_anon_with_state_sub; | |
264 | &$s; | |
265 | ||
266 | # And make sure the state subs were actually cloned. | |
267 | isnt make_anon_with_state_sub->(0), &$s(0), | |
268 | 'state subs in anon subs are cloned'; | |
269 | is &$s(0), &$s(0), 'but only when the anon sub is cloned'; | |
270 | } | |
21452252 FC |
271 | { |
272 | state sub BEGIN { exit }; | |
273 | pass 'state subs are never special blocks'; | |
274 | state sub END { shift } | |
21452252 FC |
275 | is eval{END('jkqeudth')}, jkqeudth, |
276 | 'state sub END {shift} implies @_, not @ARGV'; | |
a96df643 FC |
277 | state sub CORE { scalar reverse shift } |
278 | is CORE::uc("hello"), "HELLO", | |
279 | 'lexical CORE does not interfere with CORE::...'; | |
21452252 FC |
280 | } |
281 | { | |
282 | state sub redef {} | |
64fbf0dd | 283 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
284 | state $w; |
285 | local $SIG{__WARN__} = sub { $w .= shift }; | |
286 | eval "#line 56 pygpyf\nsub redef {}"; | |
287 | is $w, "Subroutine redef redefined at pygpyf line 56.\n", | |
288 | "sub redefinition warnings from state subs"; | |
289 | } | |
279d09bf FC |
290 | { |
291 | state sub p (\@) { | |
292 | is ref $_[0], 'ARRAY', 'state sub with proto'; | |
293 | } | |
294 | p(my @a); | |
9a5e6f3c | 295 | p my @b; |
83a72a15 FC |
296 | state sub q () { 45 } |
297 | is q(), 45, 'state constant called with parens'; | |
279d09bf | 298 | } |
c388b213 FC |
299 | { |
300 | state sub x; | |
301 | eval 'sub x {3}'; | |
302 | is x, 3, 'state sub defined inside eval'; | |
a70c2d56 FC |
303 | |
304 | sub r { | |
305 | state sub foo { 3 }; | |
306 | if (@_) { # outer call | |
307 | r(); | |
308 | is foo(), 42, | |
309 | 'state sub run-time redefinition applies to all recursion levels'; | |
310 | } | |
311 | else { # inner call | |
312 | eval 'sub foo { 42 }'; | |
313 | } | |
314 | } | |
315 | r(1); | |
c388b213 | 316 | } |
fe54d63b | 317 | like runperl( |
30d9c59b | 318 | switches => [ '-Mfeature=lexical_subs,state' ], |
fe54d63b FC |
319 | prog => 'state sub a { foo ref } a()', |
320 | stderr => 1 | |
321 | ), | |
322 | qr/syntax error/, | |
323 | 'referencing a state sub after a syntax error does not crash'; | |
18691622 FC |
324 | { |
325 | state $stuff; | |
326 | package A { | |
327 | state sub foo{ $stuff .= our $AUTOLOAD } | |
328 | *A::AUTOLOAD = \&foo; | |
329 | } | |
330 | A::bar(); | |
331 | is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload'; | |
332 | } | |
56117e3e FC |
333 | { |
334 | state sub quire{qr "quires"} | |
335 | package o { use overload qr => \&quire } | |
336 | ok "quires" =~ bless([], o::), 'state sub used as overload method'; | |
337 | } | |
db5cc3ee FC |
338 | { |
339 | state sub foo; | |
340 | *cvgv = \&foo; | |
341 | local *cvgv2 = *cvgv; | |
342 | eval 'sub cvgv2 {42}'; # uses the stub already present | |
343 | is foo, 42, 'defining state sub body via package sub declaration'; | |
344 | } | |
9d8e4b9b FC |
345 | { |
346 | local $ENV{PERL5DB} = 'sub DB::DB{}'; | |
347 | is( | |
348 | runperl( | |
349 | switches => [ '-d' ], | |
350 | progs => [ split "\n", | |
351 | 'use feature qw - lexical_subs state -; | |
352 | no warnings q-experimental::lexical_subs-; | |
353 | sub DB::sub{ print qq|4\n|; goto $DB::sub } | |
354 | state sub foo {print qq|2\n|} | |
355 | foo(); | |
356 | ' | |
357 | ], | |
358 | stderr => 1 | |
359 | ), | |
360 | "4\n2\n", | |
361 | 'state subs and DB::sub under -d' | |
362 | ); | |
363 | } | |
194774c2 FC |
364 | |
365 | # -------------------- my -------------------- # | |
366 | ||
367 | { | |
368 | my sub foo { 44 } | |
369 | isnt \&::foo, \&foo, 'my sub is not stored in the package'; | |
370 | is foo, 44, 'calling my sub from same package'; | |
371 | is &foo, 44, 'calling my sub from same package (amper)'; | |
194774c2 FC |
372 | package bar; |
373 | is foo, 44, 'calling my sub from another package'; | |
374 | is &foo, 44, 'calling my sub from another package (amper)'; | |
194774c2 FC |
375 | } |
376 | package bar; | |
377 | is foo, 43, 'my sub falling out of scope'; | |
378 | is &foo, 43, 'my sub falling out of scope (called via amper)'; | |
194774c2 FC |
379 | { |
380 | sub ma { 43 } | |
381 | my sub ma { | |
382 | if (shift) { | |
383 | is ma, 43, 'my sub invisible inside itself'; | |
384 | is &ma, 43, 'my sub invisible inside itself (called via amper)'; | |
194774c2 FC |
385 | } |
386 | 44 | |
387 | } | |
388 | ma(1); | |
389 | sub mb { 43 } | |
390 | my sub mb; | |
391 | my sub mb { | |
392 | if (shift) { | |
393 | # ‘my sub foo{}’ creates a new pad entry, not reusing the forward | |
394 | # declaration. Being invisible inside itself, it sees the stub. | |
395 | eval{mb}; | |
396 | like $@, qr/^Undefined subroutine &mb called at /, | |
397 | 'my sub foo {} after forward declaration'; | |
398 | eval{&mb}; | |
399 | like $@, qr/^Undefined subroutine &mb called at /, | |
400 | 'my sub foo {} after forward declaration (amper)'; | |
194774c2 FC |
401 | } |
402 | 44 | |
403 | } | |
404 | mb(1); | |
405 | sub mb2 { 43 } | |
406 | my sub sb2; | |
407 | sub mb2 { | |
408 | if (shift) { | |
409 | package bar; | |
410 | is mb2, 44, 'my sub visible inside itself after decl'; | |
411 | is &mb2, 44, 'my sub visible inside itself after decl (amper)'; | |
194774c2 FC |
412 | } |
413 | 44 | |
414 | } | |
415 | mb2(1); | |
416 | my sub mb3; | |
417 | { | |
418 | my sub mb3 { # new pad entry | |
419 | # The sub containing this comment is invisible inside itself. | |
420 | # So this one here will assign to the outer pad entry: | |
421 | sub mb3 { 47 } | |
422 | } | |
423 | } | |
424 | is eval{mb3}, 47, | |
425 | 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; | |
10342479 FC |
426 | # Same test again, but inside an anonymous sub |
427 | sub { | |
428 | my sub mb4; | |
429 | { | |
430 | my sub mb4 { | |
431 | sub mb4 { 47 } | |
432 | } | |
433 | } | |
434 | is mb4, 47, | |
435 | 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; | |
436 | }->(); | |
194774c2 FC |
437 | } |
438 | sub mc { 43 } | |
439 | { | |
440 | my sub mc; | |
441 | eval{mc}; | |
442 | like $@, qr/^Undefined subroutine &mc called at /, | |
443 | 'my sub foo; makes no lex alias for existing sub'; | |
444 | eval{&mc}; | |
445 | like $@, qr/^Undefined subroutine &mc called at /, | |
446 | 'my sub foo; makes no lex alias for existing sub (amper)'; | |
194774c2 FC |
447 | } |
448 | package main; | |
449 | { | |
450 | my sub me ($); | |
451 | is prototype eval{\&me}, '$', 'my sub with proto'; | |
452 | is prototype "me", undef, 'prototype "..." ignores my subs'; | |
fdf416b6 BF |
453 | |
454 | my $coderef = eval "my sub foo (\$\x{30cd}) {1}; \\&foo"; | |
455 | my $proto = prototype $coderef; | |
456 | ok(utf8::is_utf8($proto), "my sub with UTF8 proto maintains the UTF8ness"); | |
72e8be86 | 457 | is($proto, "\$\x{30cd}", "check the prototypes actually match"); |
194774c2 FC |
458 | } |
459 | { | |
460 | my sub if() { 44 } | |
461 | my $x = if if if; | |
462 | is $x, 44, 'my subs override all keywords'; | |
463 | package bar; | |
464 | my $y = if if if; | |
465 | is $y, 44, 'my subs from other packages override all keywords'; | |
466 | } | |
467 | { | |
64fbf0dd | 468 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
469 | my $w ; |
470 | local $SIG{__WARN__} = sub { $w .= shift }; | |
471 | eval '#line 87 squidges | |
472 | my sub foo; | |
473 | my sub foo {}; | |
474 | '; | |
475 | is $w, | |
476 | '"my" subroutine &foo masks earlier declaration in same scope at ' | |
477 | . "squidges line 88.\n", | |
478 | 'warning for my sub masking earlier declaration'; | |
479 | } | |
480 | # Test that my subs are cloned inside anonymous subs. | |
481 | sub mmake_closure { | |
482 | my $x = shift; | |
483 | sub { | |
484 | my sub foo { $x } | |
485 | foo | |
486 | } | |
487 | } | |
488 | $sub1 = mmake_closure 48; | |
489 | $sub2 = mmake_closure 49; | |
6d5c2147 FC |
490 | is &$sub1, 48, 'my sub in closure (1)'; |
491 | is &$sub2, 49, 'my sub in closure (2)'; | |
194774c2 FC |
492 | # Test that they are cloned in named subs. |
493 | { | |
64fbf0dd | 494 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
495 | my $w; |
496 | local $SIG{__WARN__} = sub { $w .= shift }; | |
497 | eval '#line 65 teetet | |
6d5c2147 | 498 | sub mfoom { |
194774c2 FC |
499 | my $x = shift; |
500 | my sub poom { $x } | |
6d5c2147 | 501 | \&poom |
194774c2 FC |
502 | } |
503 | '; | |
504 | is $w, undef, 'my subs get no "Variable will not stay shared" messages'; | |
6d5c2147 FC |
505 | my $poom = mfoom(27); |
506 | my $poom2 = mfoom(678); | |
507 | is $poom->(), 27, 'my subs closing over outer my var (1)'; | |
508 | is $poom2->(), 678, 'my subs closing over outer my var (2)'; | |
194774c2 FC |
509 | my $x = 43; |
510 | my sub aoeu; | |
511 | for $x (765) { | |
512 | my sub etetetet { $x } | |
6d5c2147 | 513 | sub aoeu { $x } |
194774c2 | 514 | is etetetet, 765, 'my sub respects for() localisation'; |
194774c2 FC |
515 | is aoeu, 43, 'unless it is declared outside the for loop'; |
516 | } | |
517 | } | |
518 | # And we also need to test that multiple my subs can close over each | |
519 | # other’s entries in the parent subs pad, and that cv_clone is not con- | |
520 | # fused by that. | |
521 | sub make_anon_with_my_sub{ | |
522 | sub { | |
523 | my sub s1; | |
524 | my sub s2 { \&s1 } | |
525 | sub s1 { \&s2 } | |
526 | if (@_) { return eval { \&s1 } } | |
527 | is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub'; | |
528 | is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub'; | |
529 | } | |
530 | } | |
0afba48f FC |
531 | |
532 | # Test my subs inside predeclared my subs | |
533 | { | |
534 | my sub s2; | |
535 | sub s2 { | |
536 | my $x = 3; | |
537 | my sub s3 { eval '$x' } | |
538 | s3; | |
539 | } | |
0afba48f FC |
540 | is s2, 3, 'my sub inside predeclared my sub'; |
541 | } | |
542 | ||
194774c2 FC |
543 | { |
544 | my $s = make_anon_with_my_sub; | |
545 | &$s; | |
546 | ||
547 | # And make sure the my subs were actually cloned. | |
194774c2 FC |
548 | isnt make_anon_with_my_sub->(0), &$s(0), |
549 | 'my subs in anon subs are cloned'; | |
550 | isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub'; | |
194774c2 FC |
551 | } |
552 | { | |
553 | my sub BEGIN { exit }; | |
554 | pass 'my subs are never special blocks'; | |
555 | my sub END { shift } | |
556 | is END('jkqeudth'), jkqeudth, | |
557 | 'my sub END {shift} implies @_, not @ARGV'; | |
558 | } | |
559 | { | |
560 | my sub redef {} | |
64fbf0dd | 561 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
562 | my $w; |
563 | local $SIG{__WARN__} = sub { $w .= shift }; | |
564 | eval "#line 56 pygpyf\nsub redef {}"; | |
565 | is $w, "Subroutine redef redefined at pygpyf line 56.\n", | |
566 | "sub redefinition warnings from my subs"; | |
4e85e1b4 FC |
567 | |
568 | undef $w; | |
569 | sub { | |
570 | my sub x {}; | |
571 | sub { eval "#line 87 khaki\n\\&x" } | |
572 | }->()(); | |
573 | is $w, "Subroutine \"&x\" is not available at khaki line 87.\n", | |
574 | "unavailability warning during compilation of eval in closure"; | |
575 | ||
576 | undef $w; | |
577 | no warnings 'void'; | |
578 | eval <<'->()();'; | |
579 | #line 87 khaki | |
580 | sub { | |
581 | my sub x{} | |
582 | sub not_lexical8 { | |
583 | \&x | |
584 | } | |
585 | } | |
586 | ->()(); | |
587 | is $w, "Subroutine \"&x\" is not available at khaki line 90.\n", | |
588 | "unavailability warning during compilation of named sub in anon"; | |
cf748c3c FC |
589 | |
590 | undef $w; | |
591 | sub not_lexical9 { | |
592 | my sub x {}; | |
593 | format = | |
594 | @ | |
595 | &x | |
596 | . | |
597 | } | |
598 | eval { write }; | |
599 | my($f,$l) = (__FILE__,__LINE__ - 1); | |
600 | is $w, "Subroutine \"&x\" is not available at $f line $l.\n", | |
601 | 'unavailability warning during cloning'; | |
602 | $l -= 3; | |
603 | is $@, "Undefined subroutine &x called at $f line $l.\n", | |
604 | 'Vivified sub is correctly named'; | |
194774c2 | 605 | } |
ebfebee4 FC |
606 | sub not_lexical10 { |
607 | my sub foo; | |
608 | foo(); | |
609 | sub not_lexical11 { | |
610 | my sub bar { | |
611 | my $x = 'khaki car keys for the khaki car'; | |
612 | not_lexical10(); | |
613 | sub foo { | |
614 | is $x, 'khaki car keys for the khaki car', | |
615 | 'mysubs in inner clonables use the running clone of their CvOUTSIDE' | |
616 | } | |
617 | } | |
618 | bar() | |
619 | } | |
620 | } | |
621 | not_lexical11(); | |
279d09bf FC |
622 | { |
623 | my sub p (\@) { | |
624 | is ref $_[0], 'ARRAY', 'my sub with proto'; | |
625 | } | |
626 | p(my @a); | |
9a5e6f3c | 627 | p @a; |
83a72a15 FC |
628 | my sub q () { 46 } |
629 | is q(), 46, 'my constant called with parens'; | |
279d09bf FC |
630 | } |
631 | { | |
632 | my sub x; | |
633 | my $count; | |
634 | sub x { x() if $count++ < 10 } | |
635 | x(); | |
636 | is $count, 11, 'my recursive subs'; | |
637 | } | |
a70c2d56 FC |
638 | { |
639 | my sub x; | |
640 | eval 'sub x {3}'; | |
641 | is x, 3, 'my sub defined inside eval'; | |
642 | } | |
6d5c2147 | 643 | |
4ded55f3 FC |
644 | { |
645 | state $w; | |
646 | local $SIG{__WARN__} = sub { $w .= shift }; | |
647 | eval q{ my sub george () { 2 } }; | |
648 | is $w, undef, 'no double free from constant my subs'; | |
649 | } | |
fe54d63b | 650 | like runperl( |
30d9c59b | 651 | switches => [ '-Mfeature=lexical_subs,state' ], |
fe54d63b FC |
652 | prog => 'my sub a { foo ref } a()', |
653 | stderr => 1 | |
654 | ), | |
655 | qr/syntax error/, | |
656 | 'referencing a my sub after a syntax error does not crash'; | |
18691622 FC |
657 | { |
658 | state $stuff; | |
659 | package A { | |
660 | my sub foo{ $stuff .= our $AUTOLOAD } | |
661 | *A::AUTOLOAD = \&foo; | |
662 | } | |
663 | A::bar(); | |
664 | is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload'; | |
665 | } | |
56117e3e FC |
666 | { |
667 | my sub quire{qr "quires"} | |
668 | package mo { use overload qr => \&quire } | |
669 | ok "quires" =~ bless([], mo::), 'my sub used as overload method'; | |
670 | } | |
db5cc3ee FC |
671 | { |
672 | my sub foo; | |
673 | *mcvgv = \&foo; | |
674 | local *mcvgv2 = *mcvgv; | |
675 | eval 'sub mcvgv2 {42}'; # uses the stub already present | |
676 | is foo, 42, 'defining my sub body via package sub declaration'; | |
677 | } | |
678 | { | |
679 | my sub foo; | |
680 | *mcvgv3 = \&foo; | |
681 | local *mcvgv4 = *mcvgv3; | |
682 | eval 'sub mcvgv4 {42}'; # uses the stub already present | |
683 | undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference | |
684 | } | |
685 | # We would have crashed by now if it weren’t fixed. | |
686 | pass "pad taking ownership once more of packagified my-sub"; | |
4ded55f3 | 687 | |
9d8e4b9b FC |
688 | { |
689 | local $ENV{PERL5DB} = 'sub DB::DB{}'; | |
690 | is( | |
691 | runperl( | |
692 | switches => [ '-d' ], | |
693 | progs => [ split "\n", | |
694 | 'use feature qw - lexical_subs state -; | |
695 | no warnings q-experimental::lexical_subs-; | |
696 | sub DB::sub{ print qq|4\n|; goto $DB::sub } | |
697 | my sub foo {print qq|2\n|} | |
698 | foo(); | |
699 | ' | |
700 | ], | |
701 | stderr => 1 | |
702 | ), | |
703 | "4\n2\n", | |
704 | 'my subs and DB::sub under -d' | |
705 | ); | |
706 | } | |
707 | ||
6d5c2147 FC |
708 | # -------------------- Interactions (and misc tests) -------------------- # |
709 | ||
710 | is sub { | |
711 | my sub s1; | |
712 | my sub s2 { 3 }; | |
713 | sub s1 { state sub foo { \&s2 } foo } | |
714 | s1 | |
715 | }->()(), 3, 'state sub inside my sub closing over my sub uncle'; | |
716 | ||
0afba48f FC |
717 | { |
718 | my sub s2 { 3 }; | |
719 | sub not_lexical { state sub foo { \&s2 } foo } | |
720 | is not_lexical->(), 3, 'state subs that reference my sub from outside'; | |
721 | } | |
722 | ||
723 | # Test my subs inside predeclared package subs | |
724 | # This test also checks that CvOUTSIDE pointers are not mangled when the | |
725 | # inner sub’s CvOUTSIDE points to another sub. | |
726 | sub not_lexical2; | |
727 | sub not_lexical2 { | |
728 | my $x = 23; | |
729 | my sub bar; | |
730 | sub not_lexical3 { | |
731 | not_lexical2(); | |
732 | sub bar { $x } | |
733 | }; | |
734 | bar | |
735 | } | |
0afba48f FC |
736 | is not_lexical3, 23, 'my subs inside predeclared package subs'; |
737 | ||
738 | # Test my subs inside predeclared package sub, where the lexical sub is | |
739 | # declared outside the package sub. | |
740 | # This checks that CvOUTSIDE pointers are fixed up even when the sub is | |
741 | # not declared inside the sub that its CvOUTSIDE points to. | |
8d88fe29 | 742 | sub not_lexical5 { |
0afba48f FC |
743 | my sub foo; |
744 | sub not_lexical4; | |
745 | sub not_lexical4 { | |
746 | my $x = 234; | |
8d88fe29 | 747 | not_lexical5(); |
0afba48f | 748 | sub foo { $x } |
0afba48f | 749 | } |
8d88fe29 | 750 | foo |
0afba48f | 751 | } |
8d88fe29 FC |
752 | is not_lexical4, 234, |
753 | 'my sub defined in predeclared pkg sub but declared outside'; | |
1f122f9b FC |
754 | |
755 | undef *not_lexical6; | |
756 | { | |
757 | my sub foo; | |
758 | sub not_lexical6 { sub foo { } } | |
759 | pass 'no crash when cloning a mysub declared inside an undef pack sub'; | |
760 | } | |
9ccc915e FC |
761 | |
762 | undef ¬_lexical7; | |
763 | eval 'sub not_lexical7 { my @x }'; | |
764 | { | |
765 | my sub foo; | |
766 | foo(); | |
767 | sub not_lexical7 { | |
768 | state $x; | |
769 | sub foo { | |
770 | is ref \$x, 'SCALAR', | |
771 | "redeffing a mysub's outside does not make it use the wrong pad" | |
772 | } | |
773 | } | |
774 | } | |
07b2687d LM |
775 | |
776 | like runperl( | |
30d9c59b | 777 | switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], |
07b2687d LM |
778 | prog => 'my sub foo; sub foo { foo } foo', |
779 | stderr => 1 | |
780 | ), | |
781 | qr/Deep recursion on subroutine "foo"/, | |
782 | 'deep recursion warnings for lexical subs do not crash'; | |
bdbfc51a FC |
783 | |
784 | like runperl( | |
30d9c59b | 785 | switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], |
bdbfc51a FC |
786 | prog => 'my sub foo() { 42 } undef &foo', |
787 | stderr => 1 | |
788 | ), | |
789 | qr/Constant subroutine foo undefined at /, | |
790 | 'constant undefinition warnings for lexical subs do not crash'; | |
8bfda0d7 FC |
791 | |
792 | { | |
793 | my sub foo; | |
794 | *AutoloadTestSuper::blah = \&foo; | |
795 | sub AutoloadTestSuper::AUTOLOAD { | |
796 | is $AutoloadTestSuper::AUTOLOAD, "AutoloadTestSuper::blah", | |
797 | "Autoloading via inherited lex stub"; | |
798 | } | |
799 | @AutoloadTest::ISA = AutoloadTestSuper::; | |
800 | AutoloadTest->blah; | |
801 | } |