Commit | Line | Data |
---|---|---|
c07656ed FC |
1 | #!perl |
2 | ||
39075fb1 | 3 | BEGIN { |
a817e89d | 4 | chdir 't' if -d 't'; |
39075fb1 | 5 | require './test.pl'; |
43ece5b1 | 6 | set_up_inc('../lib'); |
39075fb1 | 7 | *bar::is = *is; |
21452252 | 8 | *bar::like = *like; |
39075fb1 | 9 | } |
e0c6a6b8 | 10 | plan 151; |
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 | } | |
a14c24d0 FC |
99 | # our sub and method confusion |
100 | sub F::h { 4242 } | |
101 | { | |
102 | my $called; | |
103 | our sub h { ++$called; 4343 }; | |
104 | is((h F),4242, 'our sub symbol translation does not affect meth names'); | |
105 | undef $called; | |
106 | print "#"; | |
107 | print h F; # follows a different path through yylex to intuit_method | |
108 | print "\n"; | |
109 | is $called, undef, 'our sub symbol translation & meth names after print' | |
110 | } | |
e3a09cfb FC |
111 | our sub j; |
112 | is j | |
113 | =>, 'j', 'name_of_our_sub <newline> => is parsed properly'; | |
2872f918 FC |
114 | sub _cmp { $a cmp $b } |
115 | sub bar::_cmp { $b cmp $a } | |
116 | { | |
117 | package bar; | |
118 | our sub _cmp; | |
119 | package main; | |
120 | is join(" ", sort _cmp split //, 'oursub'), 'u u s r o b', 'sort our_sub' | |
121 | } | |
21452252 FC |
122 | |
123 | # -------------------- state -------------------- # | |
124 | ||
e7d0b801 | 125 | use feature 'state'; # state |
21452252 FC |
126 | { |
127 | state sub foo { 44 } | |
97b03d64 FC |
128 | isnt \&::foo, \&foo, 'state sub is not stored in the package'; |
129 | is eval foo, 44, 'calling state sub from same package'; | |
130 | is eval &foo, 44, 'calling state sub from same package (amper)'; | |
21452252 | 131 | package bar; |
97b03d64 FC |
132 | is eval foo, 44, 'calling state sub from another package'; |
133 | is eval &foo, 44, 'calling state sub from another package (amper)'; | |
21452252 | 134 | } |
21452252 FC |
135 | package bar; |
136 | is foo, 43, 'state sub falling out of scope'; | |
137 | is &foo, 43, 'state sub falling out of scope (called via amper)'; | |
21452252 FC |
138 | { |
139 | sub sa { 43 } | |
140 | state sub sa { | |
141 | if (shift) { | |
142 | is sa, 43, 'state sub invisible inside itself'; | |
143 | is &sa, 43, 'state sub invisible inside itself (called via amper)'; | |
21452252 FC |
144 | } |
145 | 44 | |
146 | } | |
21452252 | 147 | sa(1); |
21452252 FC |
148 | sub sb { 43 } |
149 | state sub sb; | |
150 | state sub sb { | |
151 | if (shift) { | |
152 | # ‘state sub foo{}’ creates a new pad entry, not reusing the forward | |
153 | # declaration. Being invisible inside itself, it sees the stub. | |
154 | eval{sb}; | |
155 | like $@, qr/^Undefined subroutine &sb called at /, | |
156 | 'state sub foo {} after forward declaration'; | |
157 | eval{&sb}; | |
158 | like $@, qr/^Undefined subroutine &sb called at /, | |
159 | 'state sub foo {} after forward declaration (amper)'; | |
21452252 FC |
160 | } |
161 | 44 | |
162 | } | |
21452252 | 163 | sb(1); |
21452252 FC |
164 | sub sb2 { 43 } |
165 | state sub sb2; | |
166 | sub sb2 { | |
167 | if (shift) { | |
168 | package bar; | |
97b03d64 FC |
169 | is sb2, 44, 'state sub visible inside itself after decl'; |
170 | is &sb2, 44, 'state sub visible inside itself after decl (amper)'; | |
21452252 FC |
171 | } |
172 | 44 | |
173 | } | |
21452252 | 174 | sb2(1); |
21452252 FC |
175 | state sub sb3; |
176 | { | |
177 | state sub sb3 { # new pad entry | |
178 | # The sub containing this comment is invisible inside itself. | |
179 | # So this one here will assign to the outer pad entry: | |
180 | sub sb3 { 47 } | |
181 | } | |
182 | } | |
21452252 FC |
183 | is eval{sb3}, 47, |
184 | 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; | |
10342479 FC |
185 | # Same test again, but inside an anonymous sub |
186 | sub { | |
187 | state sub sb4; | |
188 | { | |
189 | state sub sb4 { | |
190 | sub sb4 { 47 } | |
191 | } | |
192 | } | |
193 | is sb4, 47, | |
194 | 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; | |
195 | }->(); | |
21452252 FC |
196 | } |
197 | sub sc { 43 } | |
198 | { | |
199 | state sub sc; | |
200 | eval{sc}; | |
251a11d5 | 201 | like $@, qr/^Undefined subroutine &sc called at /, |
21452252 FC |
202 | 'state sub foo; makes no lex alias for existing sub'; |
203 | eval{&sc}; | |
251a11d5 | 204 | like $@, qr/^Undefined subroutine &sc called at /, |
21452252 | 205 | 'state sub foo; makes no lex alias for existing sub (amper)'; |
21452252 FC |
206 | } |
207 | package main; | |
208 | { | |
209 | state sub se ($); | |
210 | is prototype eval{\&se}, '$', 'state sub with proto'; | |
21452252 FC |
211 | is prototype "se", undef, 'prototype "..." ignores state subs'; |
212 | } | |
213 | { | |
214 | state sub if() { 44 } | |
215 | my $x = if if if; | |
216 | is $x, 44, 'state subs override all keywords'; | |
217 | package bar; | |
218 | my $y = if if if; | |
219 | is $y, 44, 'state subs from other packages override all keywords'; | |
220 | } | |
221 | { | |
64fbf0dd | 222 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
223 | state $w ; |
224 | local $SIG{__WARN__} = sub { $w .= shift }; | |
225 | eval '#line 87 squidges | |
226 | state sub foo; | |
227 | state sub foo {}; | |
228 | '; | |
21452252 | 229 | is $w, |
4eb94d7c | 230 | '"state" subroutine &foo masks earlier declaration in same scope at ' |
21452252 | 231 | . "squidges line 88.\n", |
4eb94d7c | 232 | 'warning for state sub masking earlier declaration'; |
21452252 FC |
233 | } |
234 | # Since state vars inside anonymous subs are cloned at the same time as the | |
235 | # anonymous subs containing them, the same should happen for state subs. | |
236 | sub make_closure { | |
e07561e6 | 237 | my $x = shift; |
21452252 FC |
238 | sub { |
239 | state sub foo { $x } | |
e07561e6 | 240 | foo |
21452252 FC |
241 | } |
242 | } | |
243 | $sub1 = make_closure 48; | |
244 | $sub2 = make_closure 49; | |
245 | is &$sub1, 48, 'state sub in closure (1)'; | |
97b03d64 | 246 | is &$sub2, 49, 'state sub in closure (2)'; |
21452252 FC |
247 | # But we need to test that state subs actually do persist from one invoca- |
248 | # tion of a named sub to another (i.e., that they are not my subs). | |
249 | { | |
64fbf0dd | 250 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
251 | state $w; |
252 | local $SIG{__WARN__} = sub { $w .= shift }; | |
253 | eval '#line 65 teetet | |
254 | sub foom { | |
255 | my $x = shift; | |
256 | state sub poom { $x } | |
257 | eval{\&poom} | |
258 | } | |
259 | '; | |
260 | is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n", | |
261 | 'state subs get "Variable will not stay shared" messages'; | |
262 | my $poom = foom(27); | |
263 | my $poom2 = foom(678); | |
264 | is eval{$poom->()}, eval {$poom2->()}, | |
265 | 'state subs close over the first outer my var, like pkg subs'; | |
266 | my $x = 43; | |
267 | for $x (765) { | |
268 | state sub etetetet { $x } | |
c8e83515 | 269 | is eval{etetetet}, 43, 'state sub ignores for() localisation'; |
21452252 FC |
270 | } |
271 | } | |
e07561e6 FC |
272 | # And we also need to test that multiple state subs can close over each |
273 | # other’s entries in the parent subs pad, and that cv_clone is not con- | |
274 | # fused by that. | |
275 | sub make_anon_with_state_sub{ | |
276 | sub { | |
277 | state sub s1; | |
278 | state sub s2 { \&s1 } | |
279 | sub s1 { \&s2 } | |
280 | if (@_) { return \&s1 } | |
281 | is s1,\&s2, 'state sub in anon closure closing over sibling state sub'; | |
282 | is s2,\&s1, 'state sub in anon closure closing over sibling state sub'; | |
283 | } | |
284 | } | |
285 | { | |
286 | my $s = make_anon_with_state_sub; | |
287 | &$s; | |
288 | ||
289 | # And make sure the state subs were actually cloned. | |
290 | isnt make_anon_with_state_sub->(0), &$s(0), | |
291 | 'state subs in anon subs are cloned'; | |
292 | is &$s(0), &$s(0), 'but only when the anon sub is cloned'; | |
293 | } | |
e0c6a6b8 FC |
294 | # Check that nested state subs close over variables properly |
295 | { | |
296 | is sub { | |
297 | state sub a; | |
298 | state sub b { | |
299 | state sub c { | |
300 | state $x = 42; | |
301 | sub a { $x } | |
302 | } | |
303 | c(); | |
304 | } | |
305 | b(); | |
306 | a(); | |
307 | }->(), 42, 'state sub with body defined in doubly-nested state subs'; | |
308 | is sub { | |
309 | state sub a; | |
310 | state sub b; | |
311 | state sub c { | |
312 | sub b { | |
313 | state $x = 42; | |
314 | sub a { $x } | |
315 | } | |
316 | } | |
317 | b(); | |
318 | a(); | |
319 | }->(), 42, 'nested state subs declared in same scope'; | |
320 | state $w; | |
321 | local $SIG{__WARN__} = sub { $w .= shift }; | |
322 | use warnings 'closure'; | |
323 | my $sub = sub { | |
324 | state sub a; | |
325 | sub { | |
326 | my $x; | |
327 | sub a { $x } | |
328 | } | |
329 | }; | |
330 | like $w, qr/Variable \"\$x\" is not available at /, | |
331 | "unavailability warning when state closure is defined in anon sub"; | |
332 | } | |
21452252 FC |
333 | { |
334 | state sub BEGIN { exit }; | |
335 | pass 'state subs are never special blocks'; | |
336 | state sub END { shift } | |
21452252 FC |
337 | is eval{END('jkqeudth')}, jkqeudth, |
338 | 'state sub END {shift} implies @_, not @ARGV'; | |
a96df643 FC |
339 | state sub CORE { scalar reverse shift } |
340 | is CORE::uc("hello"), "HELLO", | |
341 | 'lexical CORE does not interfere with CORE::...'; | |
21452252 FC |
342 | } |
343 | { | |
344 | state sub redef {} | |
64fbf0dd | 345 | use warnings; no warnings "experimental::lexical_subs"; |
21452252 FC |
346 | state $w; |
347 | local $SIG{__WARN__} = sub { $w .= shift }; | |
348 | eval "#line 56 pygpyf\nsub redef {}"; | |
349 | is $w, "Subroutine redef redefined at pygpyf line 56.\n", | |
350 | "sub redefinition warnings from state subs"; | |
351 | } | |
279d09bf FC |
352 | { |
353 | state sub p (\@) { | |
354 | is ref $_[0], 'ARRAY', 'state sub with proto'; | |
355 | } | |
356 | p(my @a); | |
9a5e6f3c | 357 | p my @b; |
83a72a15 FC |
358 | state sub q () { 45 } |
359 | is q(), 45, 'state constant called with parens'; | |
279d09bf | 360 | } |
c388b213 FC |
361 | { |
362 | state sub x; | |
363 | eval 'sub x {3}'; | |
364 | is x, 3, 'state sub defined inside eval'; | |
a70c2d56 FC |
365 | |
366 | sub r { | |
367 | state sub foo { 3 }; | |
368 | if (@_) { # outer call | |
369 | r(); | |
370 | is foo(), 42, | |
371 | 'state sub run-time redefinition applies to all recursion levels'; | |
372 | } | |
373 | else { # inner call | |
374 | eval 'sub foo { 42 }'; | |
375 | } | |
376 | } | |
377 | r(1); | |
c388b213 | 378 | } |
fe54d63b | 379 | like runperl( |
30d9c59b | 380 | switches => [ '-Mfeature=lexical_subs,state' ], |
fe54d63b FC |
381 | prog => 'state sub a { foo ref } a()', |
382 | stderr => 1 | |
383 | ), | |
384 | qr/syntax error/, | |
385 | 'referencing a state sub after a syntax error does not crash'; | |
18691622 FC |
386 | { |
387 | state $stuff; | |
388 | package A { | |
389 | state sub foo{ $stuff .= our $AUTOLOAD } | |
390 | *A::AUTOLOAD = \&foo; | |
391 | } | |
392 | A::bar(); | |
393 | is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload'; | |
394 | } | |
56117e3e FC |
395 | { |
396 | state sub quire{qr "quires"} | |
397 | package o { use overload qr => \&quire } | |
398 | ok "quires" =~ bless([], o::), 'state sub used as overload method'; | |
399 | } | |
db5cc3ee FC |
400 | { |
401 | state sub foo; | |
402 | *cvgv = \&foo; | |
403 | local *cvgv2 = *cvgv; | |
404 | eval 'sub cvgv2 {42}'; # uses the stub already present | |
405 | is foo, 42, 'defining state sub body via package sub declaration'; | |
406 | } | |
9d8e4b9b FC |
407 | { |
408 | local $ENV{PERL5DB} = 'sub DB::DB{}'; | |
409 | is( | |
410 | runperl( | |
411 | switches => [ '-d' ], | |
412 | progs => [ split "\n", | |
413 | 'use feature qw - lexical_subs state -; | |
414 | no warnings q-experimental::lexical_subs-; | |
96d7c888 FC |
415 | sub DB::sub{ |
416 | print qq|4\n| unless $DB::sub =~ DESTROY; | |
417 | goto $DB::sub | |
418 | } | |
9d8e4b9b FC |
419 | state sub foo {print qq|2\n|} |
420 | foo(); | |
421 | ' | |
422 | ], | |
423 | stderr => 1 | |
424 | ), | |
425 | "4\n2\n", | |
426 | 'state subs and DB::sub under -d' | |
427 | ); | |
e0a18850 FC |
428 | is( |
429 | runperl( | |
430 | switches => [ '-d' ], | |
431 | progs => [ split "\n", | |
432 | 'use feature qw - lexical_subs state -; | |
433 | no warnings q-experimental::lexical_subs-; | |
434 | sub DB::goto{ print qq|4\n|; $_ = $DB::sub } | |
435 | state sub foo {print qq|2\n|} | |
436 | $^P|=0x80; | |
437 | sub { goto &foo }->(); | |
438 | print $_ == \&foo ? qq|ok\n| : qq|$_\n|; | |
439 | ' | |
440 | ], | |
441 | stderr => 1 | |
442 | ), | |
443 | "4\n2\nok\n", | |
444 | 'state subs and DB::goto under -d' | |
445 | ); | |
9d8e4b9b | 446 | } |
7fcb4126 FC |
447 | # This used to fail an assertion, but only as a standalone script |
448 | is runperl(switches => ['-lXMfeature=:all'], | |
449 | prog => 'state sub x {}; undef &x; print defined &x', | |
450 | stderr => 1), "\n", 'undefining state sub'; | |
a5f47741 FC |
451 | { |
452 | state sub x { is +(caller 0)[3], 'x', 'state sub name in caller' } | |
453 | x | |
454 | } | |
1402e1eb | 455 | { |
1402e1eb FC |
456 | state sub _cmp { $b cmp $a } |
457 | is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b', | |
458 | 'sort state_sub LIST' | |
459 | } | |
dffc5024 FC |
460 | { |
461 | state sub handel { "" } | |
462 | print handel, "ok ", curr_test(), | |
463 | " - no 'No comma allowed' after state sub\n"; | |
464 | curr_test(curr_test()+1); | |
465 | } | |
ed996a54 FC |
466 | { |
467 | use utf8; | |
468 | state sub φου; | |
469 | eval { φου }; | |
470 | like $@, qr/^Undefined subroutine &φου called at /, | |
471 | 'state sub with utf8 name'; | |
472 | } | |
307cbb9f FC |
473 | # This used to crash, but only as a standalone script |
474 | is runperl(switches => ['-lXMfeature=:all'], | |
475 | prog => '$::x = global=>; | |
476 | sub x; | |
477 | sub x { | |
478 | state $x = 42; | |
479 | state sub x { print eval q|$x| } | |
480 | x() | |
481 | } | |
482 | x()', | |
483 | stderr => 1), "42\n", | |
484 | 'closure behaviour of state sub in predeclared package sub'; | |
194774c2 FC |
485 | |
486 | # -------------------- my -------------------- # | |
487 | ||
488 | { | |
489 | my sub foo { 44 } | |
490 | isnt \&::foo, \&foo, 'my sub is not stored in the package'; | |
491 | is foo, 44, 'calling my sub from same package'; | |
492 | is &foo, 44, 'calling my sub from same package (amper)'; | |
194774c2 FC |
493 | package bar; |
494 | is foo, 44, 'calling my sub from another package'; | |
495 | is &foo, 44, 'calling my sub from another package (amper)'; | |
194774c2 FC |
496 | } |
497 | package bar; | |
498 | is foo, 43, 'my sub falling out of scope'; | |
499 | is &foo, 43, 'my sub falling out of scope (called via amper)'; | |
194774c2 FC |
500 | { |
501 | sub ma { 43 } | |
502 | my sub ma { | |
503 | if (shift) { | |
504 | is ma, 43, 'my sub invisible inside itself'; | |
505 | is &ma, 43, 'my sub invisible inside itself (called via amper)'; | |
194774c2 FC |
506 | } |
507 | 44 | |
508 | } | |
509 | ma(1); | |
510 | sub mb { 43 } | |
511 | my sub mb; | |
512 | my sub mb { | |
513 | if (shift) { | |
514 | # ‘my sub foo{}’ creates a new pad entry, not reusing the forward | |
515 | # declaration. Being invisible inside itself, it sees the stub. | |
516 | eval{mb}; | |
517 | like $@, qr/^Undefined subroutine &mb called at /, | |
518 | 'my sub foo {} after forward declaration'; | |
519 | eval{&mb}; | |
520 | like $@, qr/^Undefined subroutine &mb called at /, | |
521 | 'my sub foo {} after forward declaration (amper)'; | |
194774c2 FC |
522 | } |
523 | 44 | |
524 | } | |
525 | mb(1); | |
526 | sub mb2 { 43 } | |
527 | my sub sb2; | |
528 | sub mb2 { | |
529 | if (shift) { | |
530 | package bar; | |
531 | is mb2, 44, 'my sub visible inside itself after decl'; | |
532 | is &mb2, 44, 'my sub visible inside itself after decl (amper)'; | |
194774c2 FC |
533 | } |
534 | 44 | |
535 | } | |
536 | mb2(1); | |
537 | my sub mb3; | |
538 | { | |
539 | my sub mb3 { # new pad entry | |
540 | # The sub containing this comment is invisible inside itself. | |
541 | # So this one here will assign to the outer pad entry: | |
542 | sub mb3 { 47 } | |
543 | } | |
544 | } | |
545 | is eval{mb3}, 47, | |
546 | 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; | |
10342479 FC |
547 | # Same test again, but inside an anonymous sub |
548 | sub { | |
549 | my sub mb4; | |
550 | { | |
551 | my sub mb4 { | |
552 | sub mb4 { 47 } | |
553 | } | |
554 | } | |
555 | is mb4, 47, | |
556 | 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; | |
557 | }->(); | |
194774c2 FC |
558 | } |
559 | sub mc { 43 } | |
560 | { | |
561 | my sub mc; | |
562 | eval{mc}; | |
563 | like $@, qr/^Undefined subroutine &mc called at /, | |
564 | 'my sub foo; makes no lex alias for existing sub'; | |
565 | eval{&mc}; | |
566 | like $@, qr/^Undefined subroutine &mc called at /, | |
567 | 'my sub foo; makes no lex alias for existing sub (amper)'; | |
194774c2 FC |
568 | } |
569 | package main; | |
570 | { | |
571 | my sub me ($); | |
572 | is prototype eval{\&me}, '$', 'my sub with proto'; | |
573 | is prototype "me", undef, 'prototype "..." ignores my subs'; | |
fdf416b6 BF |
574 | |
575 | my $coderef = eval "my sub foo (\$\x{30cd}) {1}; \\&foo"; | |
576 | my $proto = prototype $coderef; | |
577 | ok(utf8::is_utf8($proto), "my sub with UTF8 proto maintains the UTF8ness"); | |
72e8be86 | 578 | is($proto, "\$\x{30cd}", "check the prototypes actually match"); |
194774c2 FC |
579 | } |
580 | { | |
581 | my sub if() { 44 } | |
582 | my $x = if if if; | |
583 | is $x, 44, 'my subs override all keywords'; | |
584 | package bar; | |
585 | my $y = if if if; | |
586 | is $y, 44, 'my subs from other packages override all keywords'; | |
587 | } | |
588 | { | |
64fbf0dd | 589 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
590 | my $w ; |
591 | local $SIG{__WARN__} = sub { $w .= shift }; | |
592 | eval '#line 87 squidges | |
593 | my sub foo; | |
594 | my sub foo {}; | |
595 | '; | |
596 | is $w, | |
597 | '"my" subroutine &foo masks earlier declaration in same scope at ' | |
598 | . "squidges line 88.\n", | |
599 | 'warning for my sub masking earlier declaration'; | |
600 | } | |
601 | # Test that my subs are cloned inside anonymous subs. | |
602 | sub mmake_closure { | |
603 | my $x = shift; | |
604 | sub { | |
605 | my sub foo { $x } | |
606 | foo | |
607 | } | |
608 | } | |
609 | $sub1 = mmake_closure 48; | |
610 | $sub2 = mmake_closure 49; | |
6d5c2147 FC |
611 | is &$sub1, 48, 'my sub in closure (1)'; |
612 | is &$sub2, 49, 'my sub in closure (2)'; | |
194774c2 FC |
613 | # Test that they are cloned in named subs. |
614 | { | |
64fbf0dd | 615 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
616 | my $w; |
617 | local $SIG{__WARN__} = sub { $w .= shift }; | |
618 | eval '#line 65 teetet | |
6d5c2147 | 619 | sub mfoom { |
194774c2 FC |
620 | my $x = shift; |
621 | my sub poom { $x } | |
6d5c2147 | 622 | \&poom |
194774c2 FC |
623 | } |
624 | '; | |
625 | is $w, undef, 'my subs get no "Variable will not stay shared" messages'; | |
6d5c2147 FC |
626 | my $poom = mfoom(27); |
627 | my $poom2 = mfoom(678); | |
628 | is $poom->(), 27, 'my subs closing over outer my var (1)'; | |
629 | is $poom2->(), 678, 'my subs closing over outer my var (2)'; | |
194774c2 FC |
630 | my $x = 43; |
631 | my sub aoeu; | |
632 | for $x (765) { | |
633 | my sub etetetet { $x } | |
6d5c2147 | 634 | sub aoeu { $x } |
194774c2 | 635 | is etetetet, 765, 'my sub respects for() localisation'; |
194774c2 FC |
636 | is aoeu, 43, 'unless it is declared outside the for loop'; |
637 | } | |
638 | } | |
639 | # And we also need to test that multiple my subs can close over each | |
640 | # other’s entries in the parent subs pad, and that cv_clone is not con- | |
641 | # fused by that. | |
642 | sub make_anon_with_my_sub{ | |
643 | sub { | |
644 | my sub s1; | |
645 | my sub s2 { \&s1 } | |
646 | sub s1 { \&s2 } | |
647 | if (@_) { return eval { \&s1 } } | |
648 | is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub'; | |
649 | is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub'; | |
650 | } | |
651 | } | |
0afba48f FC |
652 | |
653 | # Test my subs inside predeclared my subs | |
654 | { | |
655 | my sub s2; | |
656 | sub s2 { | |
657 | my $x = 3; | |
658 | my sub s3 { eval '$x' } | |
659 | s3; | |
660 | } | |
0afba48f FC |
661 | is s2, 3, 'my sub inside predeclared my sub'; |
662 | } | |
663 | ||
194774c2 FC |
664 | { |
665 | my $s = make_anon_with_my_sub; | |
666 | &$s; | |
667 | ||
668 | # And make sure the my subs were actually cloned. | |
194774c2 FC |
669 | isnt make_anon_with_my_sub->(0), &$s(0), |
670 | 'my subs in anon subs are cloned'; | |
671 | isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub'; | |
194774c2 FC |
672 | } |
673 | { | |
674 | my sub BEGIN { exit }; | |
675 | pass 'my subs are never special blocks'; | |
676 | my sub END { shift } | |
677 | is END('jkqeudth'), jkqeudth, | |
678 | 'my sub END {shift} implies @_, not @ARGV'; | |
679 | } | |
680 | { | |
681 | my sub redef {} | |
64fbf0dd | 682 | use warnings; no warnings "experimental::lexical_subs"; |
194774c2 FC |
683 | my $w; |
684 | local $SIG{__WARN__} = sub { $w .= shift }; | |
685 | eval "#line 56 pygpyf\nsub redef {}"; | |
686 | is $w, "Subroutine redef redefined at pygpyf line 56.\n", | |
687 | "sub redefinition warnings from my subs"; | |
4e85e1b4 FC |
688 | |
689 | undef $w; | |
690 | sub { | |
691 | my sub x {}; | |
692 | sub { eval "#line 87 khaki\n\\&x" } | |
693 | }->()(); | |
694 | is $w, "Subroutine \"&x\" is not available at khaki line 87.\n", | |
695 | "unavailability warning during compilation of eval in closure"; | |
696 | ||
697 | undef $w; | |
698 | no warnings 'void'; | |
699 | eval <<'->()();'; | |
700 | #line 87 khaki | |
701 | sub { | |
702 | my sub x{} | |
703 | sub not_lexical8 { | |
704 | \&x | |
705 | } | |
706 | } | |
707 | ->()(); | |
708 | is $w, "Subroutine \"&x\" is not available at khaki line 90.\n", | |
709 | "unavailability warning during compilation of named sub in anon"; | |
cf748c3c FC |
710 | |
711 | undef $w; | |
712 | sub not_lexical9 { | |
713 | my sub x {}; | |
714 | format = | |
715 | @ | |
716 | &x | |
717 | . | |
718 | } | |
719 | eval { write }; | |
720 | my($f,$l) = (__FILE__,__LINE__ - 1); | |
721 | is $w, "Subroutine \"&x\" is not available at $f line $l.\n", | |
722 | 'unavailability warning during cloning'; | |
723 | $l -= 3; | |
724 | is $@, "Undefined subroutine &x called at $f line $l.\n", | |
725 | 'Vivified sub is correctly named'; | |
194774c2 | 726 | } |
ebfebee4 FC |
727 | sub not_lexical10 { |
728 | my sub foo; | |
729 | foo(); | |
730 | sub not_lexical11 { | |
731 | my sub bar { | |
732 | my $x = 'khaki car keys for the khaki car'; | |
733 | not_lexical10(); | |
734 | sub foo { | |
735 | is $x, 'khaki car keys for the khaki car', | |
736 | 'mysubs in inner clonables use the running clone of their CvOUTSIDE' | |
737 | } | |
738 | } | |
739 | bar() | |
740 | } | |
741 | } | |
742 | not_lexical11(); | |
279d09bf FC |
743 | { |
744 | my sub p (\@) { | |
745 | is ref $_[0], 'ARRAY', 'my sub with proto'; | |
746 | } | |
747 | p(my @a); | |
9a5e6f3c | 748 | p @a; |
83a72a15 FC |
749 | my sub q () { 46 } |
750 | is q(), 46, 'my constant called with parens'; | |
279d09bf FC |
751 | } |
752 | { | |
753 | my sub x; | |
754 | my $count; | |
755 | sub x { x() if $count++ < 10 } | |
756 | x(); | |
757 | is $count, 11, 'my recursive subs'; | |
758 | } | |
a70c2d56 FC |
759 | { |
760 | my sub x; | |
761 | eval 'sub x {3}'; | |
762 | is x, 3, 'my sub defined inside eval'; | |
763 | } | |
6d5c2147 | 764 | |
4ded55f3 FC |
765 | { |
766 | state $w; | |
767 | local $SIG{__WARN__} = sub { $w .= shift }; | |
768 | eval q{ my sub george () { 2 } }; | |
769 | is $w, undef, 'no double free from constant my subs'; | |
770 | } | |
fe54d63b | 771 | like runperl( |
30d9c59b | 772 | switches => [ '-Mfeature=lexical_subs,state' ], |
fe54d63b FC |
773 | prog => 'my sub a { foo ref } a()', |
774 | stderr => 1 | |
775 | ), | |
776 | qr/syntax error/, | |
777 | 'referencing a my sub after a syntax error does not crash'; | |
18691622 FC |
778 | { |
779 | state $stuff; | |
780 | package A { | |
781 | my sub foo{ $stuff .= our $AUTOLOAD } | |
782 | *A::AUTOLOAD = \&foo; | |
783 | } | |
784 | A::bar(); | |
785 | is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload'; | |
786 | } | |
56117e3e FC |
787 | { |
788 | my sub quire{qr "quires"} | |
789 | package mo { use overload qr => \&quire } | |
790 | ok "quires" =~ bless([], mo::), 'my sub used as overload method'; | |
791 | } | |
db5cc3ee FC |
792 | { |
793 | my sub foo; | |
794 | *mcvgv = \&foo; | |
795 | local *mcvgv2 = *mcvgv; | |
796 | eval 'sub mcvgv2 {42}'; # uses the stub already present | |
797 | is foo, 42, 'defining my sub body via package sub declaration'; | |
798 | } | |
799 | { | |
800 | my sub foo; | |
801 | *mcvgv3 = \&foo; | |
802 | local *mcvgv4 = *mcvgv3; | |
803 | eval 'sub mcvgv4 {42}'; # uses the stub already present | |
804 | undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference | |
805 | } | |
806 | # We would have crashed by now if it weren’t fixed. | |
807 | pass "pad taking ownership once more of packagified my-sub"; | |
4ded55f3 | 808 | |
9d8e4b9b FC |
809 | { |
810 | local $ENV{PERL5DB} = 'sub DB::DB{}'; | |
811 | is( | |
812 | runperl( | |
813 | switches => [ '-d' ], | |
814 | progs => [ split "\n", | |
815 | 'use feature qw - lexical_subs state -; | |
816 | no warnings q-experimental::lexical_subs-; | |
96d7c888 FC |
817 | sub DB::sub{ |
818 | print qq|4\n| unless $DB::sub =~ DESTROY; | |
819 | goto $DB::sub | |
820 | } | |
9d8e4b9b FC |
821 | my sub foo {print qq|2\n|} |
822 | foo(); | |
823 | ' | |
824 | ], | |
825 | stderr => 1 | |
826 | ), | |
827 | "4\n2\n", | |
828 | 'my subs and DB::sub under -d' | |
829 | ); | |
830 | } | |
7fcb4126 FC |
831 | # This used to fail an assertion, but only as a standalone script |
832 | is runperl(switches => ['-lXMfeature=:all'], | |
833 | prog => 'my sub x {}; undef &x; print defined &x', | |
834 | stderr => 1), "\n", 'undefining my sub'; | |
a5f47741 FC |
835 | { |
836 | my sub x { is +(caller 0)[3], 'x', 'my sub name in caller' } | |
837 | x | |
838 | } | |
1402e1eb | 839 | { |
1402e1eb FC |
840 | my sub _cmp { $b cmp $a } |
841 | is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b', | |
842 | 'sort my_sub LIST' | |
843 | } | |
dffc5024 FC |
844 | { |
845 | my sub handel { "" } | |
846 | print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n"; | |
847 | curr_test(curr_test()+1); | |
848 | } | |
04bae313 FC |
849 | { |
850 | my $x = 43; | |
851 | my sub y :prototype() {$x}; | |
852 | is y, 43, 'my sub that looks like constant closure'; | |
853 | } | |
ed996a54 FC |
854 | { |
855 | use utf8; | |
856 | my sub φου; | |
857 | eval { φου }; | |
858 | like $@, qr/^Undefined subroutine &φου called at /, | |
859 | 'my sub with utf8 name'; | |
860 | } | |
2a9203e9 FC |
861 | { |
862 | my $w; | |
863 | local $SIG{__WARN__} = sub { $w = shift }; | |
864 | use warnings 'closure'; | |
865 | eval 'sub stayshared { my sub x; sub notstayshared { x } } 1' or die; | |
866 | like $w, qr/^Subroutine "&x" will not stay shared at /, | |
867 | 'Subroutine will not stay shared'; | |
868 | } | |
9d8e4b9b | 869 | |
6d5c2147 FC |
870 | # -------------------- Interactions (and misc tests) -------------------- # |
871 | ||
872 | is sub { | |
873 | my sub s1; | |
874 | my sub s2 { 3 }; | |
875 | sub s1 { state sub foo { \&s2 } foo } | |
876 | s1 | |
877 | }->()(), 3, 'state sub inside my sub closing over my sub uncle'; | |
878 | ||
0afba48f FC |
879 | { |
880 | my sub s2 { 3 }; | |
881 | sub not_lexical { state sub foo { \&s2 } foo } | |
882 | is not_lexical->(), 3, 'state subs that reference my sub from outside'; | |
883 | } | |
884 | ||
885 | # Test my subs inside predeclared package subs | |
886 | # This test also checks that CvOUTSIDE pointers are not mangled when the | |
887 | # inner sub’s CvOUTSIDE points to another sub. | |
888 | sub not_lexical2; | |
889 | sub not_lexical2 { | |
890 | my $x = 23; | |
891 | my sub bar; | |
892 | sub not_lexical3 { | |
893 | not_lexical2(); | |
894 | sub bar { $x } | |
895 | }; | |
896 | bar | |
897 | } | |
0afba48f FC |
898 | is not_lexical3, 23, 'my subs inside predeclared package subs'; |
899 | ||
900 | # Test my subs inside predeclared package sub, where the lexical sub is | |
901 | # declared outside the package sub. | |
902 | # This checks that CvOUTSIDE pointers are fixed up even when the sub is | |
903 | # not declared inside the sub that its CvOUTSIDE points to. | |
8d88fe29 | 904 | sub not_lexical5 { |
0afba48f FC |
905 | my sub foo; |
906 | sub not_lexical4; | |
907 | sub not_lexical4 { | |
908 | my $x = 234; | |
8d88fe29 | 909 | not_lexical5(); |
0afba48f | 910 | sub foo { $x } |
0afba48f | 911 | } |
8d88fe29 | 912 | foo |
0afba48f | 913 | } |
8d88fe29 FC |
914 | is not_lexical4, 234, |
915 | 'my sub defined in predeclared pkg sub but declared outside'; | |
1f122f9b FC |
916 | |
917 | undef *not_lexical6; | |
918 | { | |
919 | my sub foo; | |
920 | sub not_lexical6 { sub foo { } } | |
921 | pass 'no crash when cloning a mysub declared inside an undef pack sub'; | |
922 | } | |
9ccc915e FC |
923 | |
924 | undef ¬_lexical7; | |
925 | eval 'sub not_lexical7 { my @x }'; | |
926 | { | |
927 | my sub foo; | |
928 | foo(); | |
929 | sub not_lexical7 { | |
930 | state $x; | |
931 | sub foo { | |
932 | is ref \$x, 'SCALAR', | |
933 | "redeffing a mysub's outside does not make it use the wrong pad" | |
934 | } | |
935 | } | |
936 | } | |
07b2687d LM |
937 | |
938 | like runperl( | |
30d9c59b | 939 | switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], |
07b2687d LM |
940 | prog => 'my sub foo; sub foo { foo } foo', |
941 | stderr => 1 | |
942 | ), | |
943 | qr/Deep recursion on subroutine "foo"/, | |
944 | 'deep recursion warnings for lexical subs do not crash'; | |
bdbfc51a FC |
945 | |
946 | like runperl( | |
30d9c59b | 947 | switches => [ '-Mfeature=lexical_subs,state', '-Mwarnings=FATAL,all', '-M-warnings=experimental::lexical_subs' ], |
bdbfc51a FC |
948 | prog => 'my sub foo() { 42 } undef &foo', |
949 | stderr => 1 | |
950 | ), | |
951 | qr/Constant subroutine foo undefined at /, | |
952 | 'constant undefinition warnings for lexical subs do not crash'; | |
8bfda0d7 FC |
953 | |
954 | { | |
955 | my sub foo; | |
956 | *AutoloadTestSuper::blah = \&foo; | |
957 | sub AutoloadTestSuper::AUTOLOAD { | |
958 | is $AutoloadTestSuper::AUTOLOAD, "AutoloadTestSuper::blah", | |
959 | "Autoloading via inherited lex stub"; | |
960 | } | |
961 | @AutoloadTest::ISA = AutoloadTestSuper::; | |
962 | AutoloadTest->blah; | |
963 | } | |
d655d9a2 FC |
964 | |
965 | # This used to crash because op.c:find_lexical_cv was looking at the wrong | |
966 | # CV’s OUTSIDE pointer. [perl #124099] | |
967 | { | |
968 | my sub h; sub{my $x; sub{h}} | |
969 | } |