Perl_op_sibling_splice(0 remove dead code
[perl.git] / t / op / closure.t
1 #!./perl
2 #                              -*- Mode: Perl -*-
3 # closure.t:
4 #   Original written by Ulrich Pfeifer on 2 Jan 1997.
5 #   Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
6 #
7 #   Run with -debug for debugging output.
8
9 BEGIN {
10     chdir 't' if -d 't';
11     require './test.pl';
12     set_up_inc('../lib');
13 }
14
15 use Config;
16
17 my $i = 1;
18 sub foo { $i = shift if @_; $i }
19
20 # no closure
21 is(foo, 1);
22 foo(2);
23 is(foo, 2);
24
25 # closure: lexical outside sub
26 my $foo = sub {$i = shift if @_; $i };
27 my $bar = sub {$i = shift if @_; $i };
28 is(&$foo(), 2);
29 &$foo(3);
30 is(&$foo(), 3);
31 # did the lexical change?
32 is(foo, 3, 'lexical changed');
33 is($i, 3, 'lexical changed');
34 # did the second closure notice?
35 is(&$bar(), 3, 'second closure noticed');
36
37 # closure: lexical inside sub
38 sub bar {
39   my $i = shift;
40   sub { $i = shift if @_; $i }
41 }
42
43 $foo = bar(4);
44 $bar = bar(5);
45 is(&$foo(), 4);
46 &$foo(6);
47 is(&$foo(), 6);
48 is(&$bar(), 5);
49
50 # nested closures
51 sub bizz {
52   my $i = 7;
53   if (@_) {
54     my $i = shift;
55     sub {$i = shift if @_; $i };
56   } else {
57     my $i = $i;
58     sub {$i = shift if @_; $i };
59   }
60 }
61 $foo = bizz();
62 $bar = bizz();
63 is(&$foo(), 7);
64 &$foo(8);
65 is(&$foo(), 8);
66 is(&$bar(), 7);
67
68 $foo = bizz(9);
69 $bar = bizz(10);
70 is(&$foo(11)-1, &$bar());
71
72 my @foo;
73 for (qw(0 1 2 3 4)) {
74   my $i = $_;
75   $foo[$_] = sub {$i = shift if @_; $i };
76 }
77
78 is(&{$foo[0]}(), 0);
79 is(&{$foo[1]}(), 1);
80 is(&{$foo[2]}(), 2);
81 is(&{$foo[3]}(), 3);
82 is(&{$foo[4]}(), 4);
83
84 for (0 .. 4) {
85   &{$foo[$_]}(4-$_);
86 }
87
88 is(&{$foo[0]}(), 4);
89 is(&{$foo[1]}(), 3);
90 is(&{$foo[2]}(), 2);
91 is(&{$foo[3]}(), 1);
92 is(&{$foo[4]}(), 0);
93
94 sub barf {
95   my @foo;
96   for (qw(0 1 2 3 4)) {
97     my $i = $_;
98     $foo[$_] = sub {$i = shift if @_; $i };
99   }
100   @foo;
101 }
102
103 @foo = barf();
104 is(&{$foo[0]}(), 0);
105 is(&{$foo[1]}(), 1);
106 is(&{$foo[2]}(), 2);
107 is(&{$foo[3]}(), 3);
108 is(&{$foo[4]}(), 4);
109
110 for (0 .. 4) {
111   &{$foo[$_]}(4-$_);
112 }
113
114 is(&{$foo[0]}(), 4);
115 is(&{$foo[1]}(), 3);
116 is(&{$foo[2]}(), 2);
117 is(&{$foo[3]}(), 1);
118 is(&{$foo[4]}(), 0);
119
120 # test if closures get created in optimized for loops
121
122 my %foo;
123 for my $n ('A'..'E') {
124     $foo{$n} = sub { $n eq $_[0] };
125 }
126
127 ok(&{$foo{A}}('A'));
128 ok(&{$foo{B}}('B'));
129 ok(&{$foo{C}}('C'));
130 ok(&{$foo{D}}('D'));
131 ok(&{$foo{E}}('E'));
132
133 for my $n (0..4) {
134     $foo[$n] = sub { $n == $_[0] };
135 }
136
137 ok(&{$foo[0]}(0));
138 ok(&{$foo[1]}(1));
139 ok(&{$foo[2]}(2));
140 ok(&{$foo[3]}(3));
141 ok(&{$foo[4]}(4));
142
143 for my $n (0..4) {
144     $foo[$n] = sub {
145                      # no intervening reference to $n here
146                      sub { $n == $_[0] }
147                    };
148 }
149
150 ok($foo[0]->()->(0));
151 ok($foo[1]->()->(1));
152 ok($foo[2]->()->(2));
153 ok($foo[3]->()->(3));
154 ok($foo[4]->()->(4));
155
156 {
157     my $w;
158     $w = sub {
159         my ($i) = @_;
160         is($i, 10);
161         sub { $w };
162     };
163     $w->(10);
164 }
165
166 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
167
168 {
169     use strict;
170
171     our $test;
172     my($debugging, %expected, $inner_type, $where_declared, $within);
173     my($nc_attempt, $call_outer, $call_inner, $undef_outer);
174     my($code, $inner_sub_test, $expected, $line, $errors, $output);
175     my(@inners, $sub_test, $pid);
176     $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
177
178     # The expected values for these tests
179     %expected = (
180         'global_scalar' => 1001,
181         'global_array'  => 2101,
182         'global_hash'   => 3004,
183         'fs_scalar'     => 4001,
184         'fs_array'      => 5101,
185         'fs_hash'       => 6004,
186         'sub_scalar'    => 7001,
187         'sub_array'     => 8101,
188         'sub_hash'      => 9004,
189         'foreach'       => 10011,
190     );
191
192     # Our innermost sub is either named or anonymous
193     for $inner_type (qw!named anon!) {
194       # And it may be declared at filescope, within a named
195       # sub, or within an anon sub
196       for $where_declared (qw!filescope in_named in_anon!) {
197         # And that, in turn, may be within a foreach loop,
198         # a naked block, or another named sub
199         for $within (qw!foreach naked other_sub!) {
200
201           my $test = curr_test();
202           # Here are a number of variables which show what's
203           # going on, in a way.
204           $nc_attempt = 0+              # Named closure attempted
205               ( ($inner_type eq 'named') ||
206               ($within eq 'other_sub') ) ;
207           $call_inner = 0+              # Need to call &inner
208               ( ($inner_type eq 'anon') &&
209               ($within eq 'other_sub') ) ;
210           $call_outer = 0+              # Need to call &outer or &$outer
211               ( ($inner_type eq 'anon') &&
212               ($within ne 'other_sub') ) ;
213           $undef_outer = 0+             # $outer is created but unused
214               ( ($where_declared eq 'in_anon') &&
215               (not $call_outer) ) ;
216
217           $code = "# This is a test script built by t/op/closure.t\n\n";
218
219           print <<"DEBUG_INFO" if $debugging;
220 # inner_type:     $inner_type 
221 # where_declared: $where_declared 
222 # within:         $within
223 # nc_attempt:     $nc_attempt
224 # call_inner:     $call_inner
225 # call_outer:     $call_outer
226 # undef_outer:    $undef_outer
227 DEBUG_INFO
228
229           $code .= <<"END_MARK_ONE";
230
231 BEGIN { \$SIG{__WARN__} = sub { 
232     my \$msg = \$_[0];
233 END_MARK_ONE
234
235           $code .=  <<"END_MARK_TWO" if $nc_attempt;
236     return if index(\$msg, 'will not stay shared') != -1;
237     return if index(\$msg, 'is not available') != -1;
238 END_MARK_TWO
239
240           $code .= <<"END_MARK_THREE";          # Backwhack a lot!
241     print "not ok: got unexpected warning \$msg\\n";
242 } }
243
244 require './test.pl';
245 curr_test($test);
246
247 # some of the variables which the closure will access
248 \$global_scalar = 1000;
249 \@global_array = (2000, 2100, 2200, 2300);
250 %global_hash = 3000..3009;
251
252 my \$fs_scalar = 4000;
253 my \@fs_array = (5000, 5100, 5200, 5300);
254 my %fs_hash = 6000..6009;
255
256 END_MARK_THREE
257
258           if ($where_declared eq 'filescope') {
259             # Nothing here
260           } elsif ($where_declared eq 'in_named') {
261             $code .= <<'END';
262 sub outer {
263   my $sub_scalar = 7000;
264   my @sub_array = (8000, 8100, 8200, 8300);
265   my %sub_hash = 9000..9009;
266 END
267     # }
268           } elsif ($where_declared eq 'in_anon') {
269             $code .= <<'END';
270 $outer = sub {
271   my $sub_scalar = 7000;
272   my @sub_array = (8000, 8100, 8200, 8300);
273   my %sub_hash = 9000..9009;
274 END
275     # }
276           } else {
277             die "What was $where_declared?"
278           }
279
280           if ($within eq 'foreach') {
281             $code .= "
282       my \$foreach = 12000;
283       my \@list = (10000, 10010);
284       foreach \$foreach (\@list) {
285     " # }
286           } elsif ($within eq 'naked') {
287             $code .= "  { # naked block\n"      # }
288           } elsif ($within eq 'other_sub') {
289             $code .= "  sub inner_sub {\n"      # }
290           } else {
291             die "What was $within?"
292           }
293
294           $sub_test = $test;
295           @inners = ( qw!global_scalar global_array global_hash! ,
296             qw!fs_scalar fs_array fs_hash! );
297           push @inners, 'foreach' if $within eq 'foreach';
298           if ($where_declared ne 'filescope') {
299             push @inners, qw!sub_scalar sub_array sub_hash!;
300           }
301           for $inner_sub_test (@inners) {
302
303             if ($inner_type eq 'named') {
304               $code .= "    sub named_$sub_test "
305             } elsif ($inner_type eq 'anon') {
306               $code .= "    \$anon_$sub_test = sub "
307             } else {
308               die "What was $inner_type?"
309             }
310
311             # Now to write the body of the test sub
312             if ($inner_sub_test eq 'global_scalar') {
313               $code .= '{ ++$global_scalar }'
314             } elsif ($inner_sub_test eq 'fs_scalar') {
315               $code .= '{ ++$fs_scalar }'
316             } elsif ($inner_sub_test eq 'sub_scalar') {
317               $code .= '{ ++$sub_scalar }'
318             } elsif ($inner_sub_test eq 'global_array') {
319               $code .= '{ ++$global_array[1] }'
320             } elsif ($inner_sub_test eq 'fs_array') {
321               $code .= '{ ++$fs_array[1] }'
322             } elsif ($inner_sub_test eq 'sub_array') {
323               $code .= '{ ++$sub_array[1] }'
324             } elsif ($inner_sub_test eq 'global_hash') {
325               $code .= '{ ++$global_hash{3002} }'
326             } elsif ($inner_sub_test eq 'fs_hash') {
327               $code .= '{ ++$fs_hash{6002} }'
328             } elsif ($inner_sub_test eq 'sub_hash') {
329               $code .= '{ ++$sub_hash{9002} }'
330             } elsif ($inner_sub_test eq 'foreach') {
331               $code .= '{ ++$foreach }'
332             } else {
333               die "What was $inner_sub_test?"
334             }
335           
336             # Close up
337             if ($inner_type eq 'anon') {
338               $code .= ';'
339             }
340             $code .= "\n";
341             $sub_test++;        # sub name sequence number
342
343           } # End of foreach $inner_sub_test
344
345           # Close up $within block              # {
346           $code .= "  }\n\n";
347
348           # Close up $where_declared block
349           if ($where_declared eq 'in_named') {  # {
350             $code .= "}\n\n";
351           } elsif ($where_declared eq 'in_anon') {      # {
352             $code .= "};\n\n";
353           }
354
355           # We may need to do something with the sub we just made...
356           $code .= "undef \$outer;\n" if $undef_outer;
357           $code .= "&inner_sub;\n" if $call_inner;
358           if ($call_outer) {
359             if ($where_declared eq 'in_named') {
360               $code .= "&outer;\n\n";
361             } elsif ($where_declared eq 'in_anon') {
362               $code .= "&\$outer;\n\n"
363             }
364           }
365
366           # Now, we can actually prep to run the tests.
367           for $inner_sub_test (@inners) {
368             $expected = $expected{$inner_sub_test} or
369               die "expected $inner_sub_test missing";
370
371             # Named closures won't access the expected vars
372             if ( $nc_attempt and 
373                 substr($inner_sub_test, 0, 4) eq "sub_" ) {
374               $expected = 1;
375             }
376
377             # If you make a sub within a foreach loop,
378             # what happens if it tries to access the 
379             # foreach index variable? If it's a named
380             # sub, it gets the var from "outside" the loop,
381             # but if it's anon, it gets the value to which
382             # the index variable is aliased.
383             #
384             # Of course, if the value was set only
385             # within another sub which was never called,
386             # the value has not been set yet.
387             #
388             if ($inner_sub_test eq 'foreach') {
389               if ($inner_type eq 'named') {
390                 if ($call_outer || ($where_declared eq 'filescope')) {
391                   $expected = 12001
392                 } else {
393                   $expected = 1
394                 }
395               }
396             }
397
398             # Here's the test:
399             my $desc = "$inner_type $where_declared $within $inner_sub_test";
400             if ($inner_type eq 'anon') {
401               $code .= "is(&\$anon_$test, $expected, '$desc');\n"
402             } else {
403               $code .= "is(&named_$test, $expected, '$desc');\n"
404             }
405             $test++;
406           }
407
408           if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
409             # Fork off a new perl to run the tests.
410             # (This is so we can catch spurious warnings.)
411             $| = 1; print ""; $| = 0; # flush output before forking
412             pipe READ, WRITE or die "Can't make pipe: $!";
413             pipe READ2, WRITE2 or die "Can't make second pipe: $!";
414             die "Can't fork: $!" unless defined($pid = open PERL, "|-");
415             unless ($pid) {
416               # Child process here. We're going to send errors back
417               # through the extra pipe.
418               close READ;
419               close READ2;
420               open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
421               open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
422               exec which_perl(), '-w', '-'
423                 or die "Can't exec perl: $!";
424             } else {
425               # Parent process here.
426               close WRITE;
427               close WRITE2;
428               print PERL $code;
429               close PERL;
430               { local $/;
431                 $output = join '', <READ>;
432                 $errors = join '', <READ2>; }
433               close READ;
434               close READ2;
435             }
436           } else {
437             # No fork().  Do it the hard way.
438             my $cmdfile = tempfile();
439             my $errfile = tempfile();
440             open CMD, ">$cmdfile"; print CMD $code; close CMD;
441             my $cmd = which_perl();
442             $cmd .= " -w $cmdfile 2>$errfile";
443             if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
444               # Use pipe instead of system so we don't inherit STD* from
445               # this process, and then foul our pipe back to parent by
446               # redirecting output in the child.
447               open PERL,"$cmd |" or die "Can't open pipe: $!\n";
448               { local $/; $output = join '', <PERL> }
449               close PERL;
450             } else {
451               my $outfile = tempfile();
452               system "$cmd >$outfile";
453               { local $/; open IN, $outfile; $output = <IN>; close IN }
454             }
455             if ($?) {
456               printf "not ok: exited with error code %04X\n", $?;
457               exit;
458             }
459             { local $/; open IN, $errfile; $errors = <IN>; close IN }
460           }
461           print $output;
462           curr_test($test);
463           print STDERR $errors;
464           # This has the side effect of alerting *our* test.pl to the state of
465           # what has just been passed to STDOUT, so that if anything there has
466           # failed, our test.pl will print a diagnostic and exit uncleanly.
467           unlike($output, qr/not ok/, 'All good');
468           is($errors, '', 'STDERR is silent');
469           if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
470             my $lnum = 0;
471             for $line (split '\n', $code) {
472               printf "%3d:  %s\n", ++$lnum, $line;
473             }
474           }
475           is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?);
476           print '#', "-" x 30, "\n" if $debugging;
477
478         }       # End of foreach $within
479       } # End of foreach $where_declared
480     }   # End of foreach $inner_type
481
482 }
483
484 # The following dumps core with perl <= 5.8.0 (bugid 9535) ...
485 BEGIN { $vanishing_pad = sub { eval $_[0] } }
486 $some_var = 123;
487 is($vanishing_pad->('$some_var'), 123, 'RT #9535');
488
489 # ... and here's another coredump variant - this time we explicitly
490 # delete the sub rather than using a BEGIN ...
491
492 sub deleteme { $a = sub { eval '$newvar' } }
493 deleteme();
494 *deleteme = sub {}; # delete the sub
495 $newvar = 123; # realloc the SV of the freed CV
496 is($a->(), 123, 'RT #9535');
497
498 # ... and a further coredump variant - the fixup of the anon sub's
499 # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
500 # survive the outer eval also being freed.
501
502 $x = 123;
503 $a = eval q(
504     eval q[
505         sub { eval '$x' }
506     ]
507 );
508 @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
509 is($a->(), 123, 'RT #9535');
510
511 # this coredumped on <= 5.8.0 because evaling the closure caused
512 # an SvFAKE to be added to the outer anon's pad, which was then grown.
513 my $outer;
514 sub {
515     my $x;
516     $x = eval 'sub { $outer }';
517     $x->();
518     $a = [ 99 ];
519     $x->();
520 }->();
521 pass();
522
523 # [perl #17605] found that an empty block called in scalar context
524 # can lead to stack corruption
525 {
526     my $x = "foooobar";
527     $x =~ s/o//eg;
528     is($x, 'fbar', 'RT #17605');
529 }
530
531 # DAPM 24-Nov-02
532 # SvFAKE lexicals should be visible thoughout a function.
533 # On <= 5.8.0, the third test failed,  eg bugid #18286
534
535 {
536     my $x = 1;
537     sub fake {
538                 is(sub {eval'$x'}->(), 1, 'RT #18286');
539         { $x;   is(sub {eval'$x'}->(), 1, 'RT #18286'); }
540                 is(sub {eval'$x'}->(), 1, 'RT #18286');
541     }
542 }
543 fake();
544
545 {
546     $x = 1;
547     my $x = 2;
548     sub tmp { sub { eval '$x' } }
549     my $a = tmp();
550     undef &tmp;
551     is($a->(), 2,
552        "undefining a sub shouldn't alter visibility of outer lexicals");
553 }
554
555 # handy class: $x = Watch->new(\$foo,'bar')
556 # causes 'bar' to be appended to $foo when $x is destroyed
557 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
558 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
559
560 # bugid 1028:
561 # nested anon subs (and associated lexicals) not freed early enough
562
563 sub linger {
564     my $x = Watch->new($_[0], '2');
565     sub {
566         $x;
567         my $y;
568         sub { $y; };
569     };
570 }
571 {
572     my $watch = '1';
573     linger(\$watch);
574     is($watch, '12', 'RT #1028');
575 }
576
577 # bugid 10085
578 # obj not freed early enough
579
580 sub linger2 { 
581     my $obj = Watch->new($_[0], '2');
582     sub { sub { $obj } };
583 }   
584 {
585     my $watch = '1';
586     linger2(\$watch);
587     is($watch, 12, 'RT #10085');
588 }
589
590 # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
591
592 {
593     my $x = 1;
594     sub f16302 {
595         sub {
596             is($x, 1, 'RT #16302');
597         }->();
598     }
599 }
600 f16302();
601
602 # The presence of an eval should turn cloneless anon subs into clonable
603 # subs - otherwise the CvOUTSIDE of that sub may be wrong
604
605 {
606     my %a;
607     for my $x (7,11) {
608         $a{$x} = sub { $x=$x; sub { eval '$x' } };
609     }
610     is($a{7}->()->() + $a{11}->()->(), 18);
611 }
612
613 {
614    # bugid #23265 - this used to coredump during destruction of PL_main_cv
615    # and its children
616
617     fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265');
618         print
619             sub {$_[0]->(@_)} -> (
620                 sub {
621                     $_[1]
622                         ?  $_[0]->($_[0], $_[1] - 1) .  sub {"x"}->()
623                         : "y"
624                 },   
625                 2
626             )
627             , "\n"
628         ;
629 __EOF__
630 }
631
632 {
633     # bugid #24914 = used to coredump restoring PL_comppad in the
634     # savestack, due to the early freeing of the anon closure
635
636     fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)',
637                   "ok\n", {stderr => 1}, 'RT #24914');
638 }
639
640
641 # After newsub is redefined outside the BEGIN, its CvOUTSIDE should point
642 # to main rather than BEGIN, and BEGIN should be freed.
643
644 {
645     my $flag = 0;
646     sub  X::DESTROY { $flag = 1 }
647     {
648         my $x;
649         BEGIN {$x = \&newsub }
650         sub newsub {};
651         $x = bless {}, 'X';
652     }
653     is($flag, 1);
654 }
655
656 sub f {
657     my $x;
658     format ff =
659 @
660 $r = \$x
661 .
662 }
663
664 {
665     fileno ff;
666     write ff;
667     my $r1 = $r;
668     write ff;
669     my $r2 = $r;
670     isnt($r1, $r2,
671          "don't copy a stale lexical; create a fresh undef one instead");
672 }
673
674 # test PL_cv_has_eval.  Any anon sub that could conceivably contain an
675 # eval, should be marked as cloneable
676
677 {
678
679     my @s;
680     push @s, sub {  eval '1' } for 1,2;
681     isnt($s[0], $s[1], "cloneable with eval");
682     @s = ();
683     push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2;
684     isnt($s[0], $s[1], "cloneable with use re eval");
685     @s = ();
686     push @s, sub { s/1/1/ee; } for 1,2;
687     isnt($s[0], $s[1], "cloneable with //ee");
688 }
689
690 # [perl #89544]
691 {
692    sub trace::DESTROY {
693        push @trace::trace, "destroyed";
694    }
695
696    my $outer2 = sub {
697        my $a = bless \my $dummy, trace::;
698
699        my $outer = sub {
700            my $b;
701            my $inner = sub {
702                undef $b;
703            };
704
705            $a;
706
707            $inner
708        };
709
710        $outer->()
711    };
712
713    my $inner = $outer2->();
714    is "@trace::trace", "destroyed",
715       'closures only close over named variables, not entire subs';
716 }
717
718 # [perl #113812] Closure prototypes with no CvOUTSIDE (crash caused by the
719 #                fix for #89544)
720 do "./op/closure_test.pl" or die $@||$!;
721 is $closure_test::s2->()(), '10 cubes',
722   'cloning closure proto with no CvOUTSIDE';
723
724 # Also brought up in #113812: Even when being cloned, a closure prototype
725 # might have its CvOUTSIDE pointing to the wrong thing.
726 {
727     package main::113812;
728     $s1 = sub {
729         my $x = 3;
730         $s2 = sub {
731             $x;
732             $s3 = sub { $x };
733         };
734     };
735     $s1->();
736     undef &$s1; # frees $s2's prototype, causing the $s3 proto to have its
737                 # CvOUTSIDE point to $s1
738     ::is $s2->()(), 3, 'cloning closure proto whose CvOUTSIDE has changed';
739 }
740
741 # This should never emit two different values:
742 #     print $x, "\n";
743 #     print sub { $x }->(), "\n";
744 # This test case started to do just that in commit 33894c1aa3e
745 # (5.10.1/5.12.0):
746 sub mosquito {
747     my $x if @_;
748     return if @_;
749
750     $x = 17;
751     is sub { $x }->(), $x, 'closing over stale var in 2nd sub call';
752 }
753 mosquito(1);
754 mosquito;
755 # And this case in commit adf8f095c588 (5.14):
756 sub anything {
757     my $x;
758     sub gnat {
759         $x = 3;
760         is sub { $x }->(), $x,
761             'closing over stale var before 1st sub call';
762     }
763 }
764 gnat();
765
766 # [perl #114018] Similar to the above, but with string eval
767 sub staleval {
768     my $x if @_;
769     return if @_;
770
771     $x = 3;
772     is eval '$x', $x, 'eval closing over stale var in active sub';
773     return # 
774 }
775 staleval 1;
776 staleval;
777
778 # [perl #114888]
779 # Test that closure creation localises PL_comppad_name properly.  Usually
780 # at compile time a BEGIN block will localise PL_comppad_name for use, so
781 # pp_anoncode can mess with it without any visible effects.
782 # But inside a source filter, it affects the directly enclosing compila-
783 # tion scope.
784 SKIP: {
785     skip_if_miniperl("no XS on miniperl (for source filters)");
786     fresh_perl_is <<'    [perl #114888]', "ok\n", {stderr=>1},
787         use strict;
788         BEGIN {
789             package Foo;
790             use Filter::Util::Call;
791             sub import { filter_add( sub {
792                 my $status = filter_read();
793                 sub { $status };
794                 $status;
795             })}
796             Foo->import
797         }
798         my $x = "ok\n"; # stores $x in the wrong padnamelist
799         print $x;       # cannot find it - strict violation
800     [perl #114888]
801         'closures in source filters do not interfere with pad names';
802 }
803
804 sub {
805     my $f;
806     sub test_ref_to_unavailable {
807         my $ref = \$f;
808         $$ref = 7;
809         is $f, 7, 'taking a ref to unavailable var should not copy it';
810     }
811 };
812 test_ref_to_unavailable();
813
814 done_testing();