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