1*0Sstevel@tonic-gate#!./perl 2*0Sstevel@tonic-gate# -*- Mode: Perl -*- 3*0Sstevel@tonic-gate# closure.t: 4*0Sstevel@tonic-gate# Original written by Ulrich Pfeifer on 2 Jan 1997. 5*0Sstevel@tonic-gate# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. 6*0Sstevel@tonic-gate# 7*0Sstevel@tonic-gate# Run with -debug for debugging output. 8*0Sstevel@tonic-gate 9*0Sstevel@tonic-gateBEGIN { 10*0Sstevel@tonic-gate chdir 't' if -d 't'; 11*0Sstevel@tonic-gate @INC = '../lib'; 12*0Sstevel@tonic-gate} 13*0Sstevel@tonic-gate 14*0Sstevel@tonic-gateuse Config; 15*0Sstevel@tonic-gate 16*0Sstevel@tonic-gateprint "1..187\n"; 17*0Sstevel@tonic-gate 18*0Sstevel@tonic-gatemy $test = 1; 19*0Sstevel@tonic-gatesub test (&) { 20*0Sstevel@tonic-gate my $ok = &{$_[0]}; 21*0Sstevel@tonic-gate print $ok ? "ok $test\n" : "not ok $test\n"; 22*0Sstevel@tonic-gate printf "# Failed at line %d\n", (caller)[2] unless $ok; 23*0Sstevel@tonic-gate $test++; 24*0Sstevel@tonic-gate} 25*0Sstevel@tonic-gate 26*0Sstevel@tonic-gatemy $i = 1; 27*0Sstevel@tonic-gatesub foo { $i = shift if @_; $i } 28*0Sstevel@tonic-gate 29*0Sstevel@tonic-gate# no closure 30*0Sstevel@tonic-gatetest { foo == 1 }; 31*0Sstevel@tonic-gatefoo(2); 32*0Sstevel@tonic-gatetest { foo == 2 }; 33*0Sstevel@tonic-gate 34*0Sstevel@tonic-gate# closure: lexical outside sub 35*0Sstevel@tonic-gatemy $foo = sub {$i = shift if @_; $i }; 36*0Sstevel@tonic-gatemy $bar = sub {$i = shift if @_; $i }; 37*0Sstevel@tonic-gatetest {&$foo() == 2 }; 38*0Sstevel@tonic-gate&$foo(3); 39*0Sstevel@tonic-gatetest {&$foo() == 3 }; 40*0Sstevel@tonic-gate# did the lexical change? 41*0Sstevel@tonic-gatetest { foo == 3 and $i == 3}; 42*0Sstevel@tonic-gate# did the second closure notice? 43*0Sstevel@tonic-gatetest {&$bar() == 3 }; 44*0Sstevel@tonic-gate 45*0Sstevel@tonic-gate# closure: lexical inside sub 46*0Sstevel@tonic-gatesub bar { 47*0Sstevel@tonic-gate my $i = shift; 48*0Sstevel@tonic-gate sub { $i = shift if @_; $i } 49*0Sstevel@tonic-gate} 50*0Sstevel@tonic-gate 51*0Sstevel@tonic-gate$foo = bar(4); 52*0Sstevel@tonic-gate$bar = bar(5); 53*0Sstevel@tonic-gatetest {&$foo() == 4 }; 54*0Sstevel@tonic-gate&$foo(6); 55*0Sstevel@tonic-gatetest {&$foo() == 6 }; 56*0Sstevel@tonic-gatetest {&$bar() == 5 }; 57*0Sstevel@tonic-gate 58*0Sstevel@tonic-gate# nested closures 59*0Sstevel@tonic-gatesub bizz { 60*0Sstevel@tonic-gate my $i = 7; 61*0Sstevel@tonic-gate if (@_) { 62*0Sstevel@tonic-gate my $i = shift; 63*0Sstevel@tonic-gate sub {$i = shift if @_; $i }; 64*0Sstevel@tonic-gate } else { 65*0Sstevel@tonic-gate my $i = $i; 66*0Sstevel@tonic-gate sub {$i = shift if @_; $i }; 67*0Sstevel@tonic-gate } 68*0Sstevel@tonic-gate} 69*0Sstevel@tonic-gate$foo = bizz(); 70*0Sstevel@tonic-gate$bar = bizz(); 71*0Sstevel@tonic-gatetest {&$foo() == 7 }; 72*0Sstevel@tonic-gate&$foo(8); 73*0Sstevel@tonic-gatetest {&$foo() == 8 }; 74*0Sstevel@tonic-gatetest {&$bar() == 7 }; 75*0Sstevel@tonic-gate 76*0Sstevel@tonic-gate$foo = bizz(9); 77*0Sstevel@tonic-gate$bar = bizz(10); 78*0Sstevel@tonic-gatetest {&$foo(11)-1 == &$bar()}; 79*0Sstevel@tonic-gate 80*0Sstevel@tonic-gatemy @foo; 81*0Sstevel@tonic-gatefor (qw(0 1 2 3 4)) { 82*0Sstevel@tonic-gate my $i = $_; 83*0Sstevel@tonic-gate $foo[$_] = sub {$i = shift if @_; $i }; 84*0Sstevel@tonic-gate} 85*0Sstevel@tonic-gate 86*0Sstevel@tonic-gatetest { 87*0Sstevel@tonic-gate &{$foo[0]}() == 0 and 88*0Sstevel@tonic-gate &{$foo[1]}() == 1 and 89*0Sstevel@tonic-gate &{$foo[2]}() == 2 and 90*0Sstevel@tonic-gate &{$foo[3]}() == 3 and 91*0Sstevel@tonic-gate &{$foo[4]}() == 4 92*0Sstevel@tonic-gate }; 93*0Sstevel@tonic-gate 94*0Sstevel@tonic-gatefor (0 .. 4) { 95*0Sstevel@tonic-gate &{$foo[$_]}(4-$_); 96*0Sstevel@tonic-gate} 97*0Sstevel@tonic-gate 98*0Sstevel@tonic-gatetest { 99*0Sstevel@tonic-gate &{$foo[0]}() == 4 and 100*0Sstevel@tonic-gate &{$foo[1]}() == 3 and 101*0Sstevel@tonic-gate &{$foo[2]}() == 2 and 102*0Sstevel@tonic-gate &{$foo[3]}() == 1 and 103*0Sstevel@tonic-gate &{$foo[4]}() == 0 104*0Sstevel@tonic-gate }; 105*0Sstevel@tonic-gate 106*0Sstevel@tonic-gatesub barf { 107*0Sstevel@tonic-gate my @foo; 108*0Sstevel@tonic-gate for (qw(0 1 2 3 4)) { 109*0Sstevel@tonic-gate my $i = $_; 110*0Sstevel@tonic-gate $foo[$_] = sub {$i = shift if @_; $i }; 111*0Sstevel@tonic-gate } 112*0Sstevel@tonic-gate @foo; 113*0Sstevel@tonic-gate} 114*0Sstevel@tonic-gate 115*0Sstevel@tonic-gate@foo = barf(); 116*0Sstevel@tonic-gatetest { 117*0Sstevel@tonic-gate &{$foo[0]}() == 0 and 118*0Sstevel@tonic-gate &{$foo[1]}() == 1 and 119*0Sstevel@tonic-gate &{$foo[2]}() == 2 and 120*0Sstevel@tonic-gate &{$foo[3]}() == 3 and 121*0Sstevel@tonic-gate &{$foo[4]}() == 4 122*0Sstevel@tonic-gate }; 123*0Sstevel@tonic-gate 124*0Sstevel@tonic-gatefor (0 .. 4) { 125*0Sstevel@tonic-gate &{$foo[$_]}(4-$_); 126*0Sstevel@tonic-gate} 127*0Sstevel@tonic-gate 128*0Sstevel@tonic-gatetest { 129*0Sstevel@tonic-gate &{$foo[0]}() == 4 and 130*0Sstevel@tonic-gate &{$foo[1]}() == 3 and 131*0Sstevel@tonic-gate &{$foo[2]}() == 2 and 132*0Sstevel@tonic-gate &{$foo[3]}() == 1 and 133*0Sstevel@tonic-gate &{$foo[4]}() == 0 134*0Sstevel@tonic-gate }; 135*0Sstevel@tonic-gate 136*0Sstevel@tonic-gate# test if closures get created in optimized for loops 137*0Sstevel@tonic-gate 138*0Sstevel@tonic-gatemy %foo; 139*0Sstevel@tonic-gatefor my $n ('A'..'E') { 140*0Sstevel@tonic-gate $foo{$n} = sub { $n eq $_[0] }; 141*0Sstevel@tonic-gate} 142*0Sstevel@tonic-gate 143*0Sstevel@tonic-gatetest { 144*0Sstevel@tonic-gate &{$foo{A}}('A') and 145*0Sstevel@tonic-gate &{$foo{B}}('B') and 146*0Sstevel@tonic-gate &{$foo{C}}('C') and 147*0Sstevel@tonic-gate &{$foo{D}}('D') and 148*0Sstevel@tonic-gate &{$foo{E}}('E') 149*0Sstevel@tonic-gate}; 150*0Sstevel@tonic-gate 151*0Sstevel@tonic-gatefor my $n (0..4) { 152*0Sstevel@tonic-gate $foo[$n] = sub { $n == $_[0] }; 153*0Sstevel@tonic-gate} 154*0Sstevel@tonic-gate 155*0Sstevel@tonic-gatetest { 156*0Sstevel@tonic-gate &{$foo[0]}(0) and 157*0Sstevel@tonic-gate &{$foo[1]}(1) and 158*0Sstevel@tonic-gate &{$foo[2]}(2) and 159*0Sstevel@tonic-gate &{$foo[3]}(3) and 160*0Sstevel@tonic-gate &{$foo[4]}(4) 161*0Sstevel@tonic-gate}; 162*0Sstevel@tonic-gate 163*0Sstevel@tonic-gatefor my $n (0..4) { 164*0Sstevel@tonic-gate $foo[$n] = sub { 165*0Sstevel@tonic-gate # no intervening reference to $n here 166*0Sstevel@tonic-gate sub { $n == $_[0] } 167*0Sstevel@tonic-gate }; 168*0Sstevel@tonic-gate} 169*0Sstevel@tonic-gate 170*0Sstevel@tonic-gatetest { 171*0Sstevel@tonic-gate $foo[0]->()->(0) and 172*0Sstevel@tonic-gate $foo[1]->()->(1) and 173*0Sstevel@tonic-gate $foo[2]->()->(2) and 174*0Sstevel@tonic-gate $foo[3]->()->(3) and 175*0Sstevel@tonic-gate $foo[4]->()->(4) 176*0Sstevel@tonic-gate}; 177*0Sstevel@tonic-gate 178*0Sstevel@tonic-gate{ 179*0Sstevel@tonic-gate my $w; 180*0Sstevel@tonic-gate $w = sub { 181*0Sstevel@tonic-gate my ($i) = @_; 182*0Sstevel@tonic-gate test { $i == 10 }; 183*0Sstevel@tonic-gate sub { $w }; 184*0Sstevel@tonic-gate }; 185*0Sstevel@tonic-gate $w->(10); 186*0Sstevel@tonic-gate} 187*0Sstevel@tonic-gate 188*0Sstevel@tonic-gate# Additional tests by Tom Phoenix <rootbeer@teleport.com>. 189*0Sstevel@tonic-gate 190*0Sstevel@tonic-gate{ 191*0Sstevel@tonic-gate use strict; 192*0Sstevel@tonic-gate 193*0Sstevel@tonic-gate use vars qw!$test!; 194*0Sstevel@tonic-gate my($debugging, %expected, $inner_type, $where_declared, $within); 195*0Sstevel@tonic-gate my($nc_attempt, $call_outer, $call_inner, $undef_outer); 196*0Sstevel@tonic-gate my($code, $inner_sub_test, $expected, $line, $errors, $output); 197*0Sstevel@tonic-gate my(@inners, $sub_test, $pid); 198*0Sstevel@tonic-gate $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; 199*0Sstevel@tonic-gate 200*0Sstevel@tonic-gate # The expected values for these tests 201*0Sstevel@tonic-gate %expected = ( 202*0Sstevel@tonic-gate 'global_scalar' => 1001, 203*0Sstevel@tonic-gate 'global_array' => 2101, 204*0Sstevel@tonic-gate 'global_hash' => 3004, 205*0Sstevel@tonic-gate 'fs_scalar' => 4001, 206*0Sstevel@tonic-gate 'fs_array' => 5101, 207*0Sstevel@tonic-gate 'fs_hash' => 6004, 208*0Sstevel@tonic-gate 'sub_scalar' => 7001, 209*0Sstevel@tonic-gate 'sub_array' => 8101, 210*0Sstevel@tonic-gate 'sub_hash' => 9004, 211*0Sstevel@tonic-gate 'foreach' => 10011, 212*0Sstevel@tonic-gate ); 213*0Sstevel@tonic-gate 214*0Sstevel@tonic-gate # Our innermost sub is either named or anonymous 215*0Sstevel@tonic-gate for $inner_type (qw!named anon!) { 216*0Sstevel@tonic-gate # And it may be declared at filescope, within a named 217*0Sstevel@tonic-gate # sub, or within an anon sub 218*0Sstevel@tonic-gate for $where_declared (qw!filescope in_named in_anon!) { 219*0Sstevel@tonic-gate # And that, in turn, may be within a foreach loop, 220*0Sstevel@tonic-gate # a naked block, or another named sub 221*0Sstevel@tonic-gate for $within (qw!foreach naked other_sub!) { 222*0Sstevel@tonic-gate 223*0Sstevel@tonic-gate # Here are a number of variables which show what's 224*0Sstevel@tonic-gate # going on, in a way. 225*0Sstevel@tonic-gate $nc_attempt = 0+ # Named closure attempted 226*0Sstevel@tonic-gate ( ($inner_type eq 'named') || 227*0Sstevel@tonic-gate ($within eq 'other_sub') ) ; 228*0Sstevel@tonic-gate $call_inner = 0+ # Need to call &inner 229*0Sstevel@tonic-gate ( ($inner_type eq 'anon') && 230*0Sstevel@tonic-gate ($within eq 'other_sub') ) ; 231*0Sstevel@tonic-gate $call_outer = 0+ # Need to call &outer or &$outer 232*0Sstevel@tonic-gate ( ($inner_type eq 'anon') && 233*0Sstevel@tonic-gate ($within ne 'other_sub') ) ; 234*0Sstevel@tonic-gate $undef_outer = 0+ # $outer is created but unused 235*0Sstevel@tonic-gate ( ($where_declared eq 'in_anon') && 236*0Sstevel@tonic-gate (not $call_outer) ) ; 237*0Sstevel@tonic-gate 238*0Sstevel@tonic-gate $code = "# This is a test script built by t/op/closure.t\n\n"; 239*0Sstevel@tonic-gate 240*0Sstevel@tonic-gate print <<"DEBUG_INFO" if $debugging; 241*0Sstevel@tonic-gate# inner_type: $inner_type 242*0Sstevel@tonic-gate# where_declared: $where_declared 243*0Sstevel@tonic-gate# within: $within 244*0Sstevel@tonic-gate# nc_attempt: $nc_attempt 245*0Sstevel@tonic-gate# call_inner: $call_inner 246*0Sstevel@tonic-gate# call_outer: $call_outer 247*0Sstevel@tonic-gate# undef_outer: $undef_outer 248*0Sstevel@tonic-gateDEBUG_INFO 249*0Sstevel@tonic-gate 250*0Sstevel@tonic-gate $code .= <<"END_MARK_ONE"; 251*0Sstevel@tonic-gate 252*0Sstevel@tonic-gateBEGIN { \$SIG{__WARN__} = sub { 253*0Sstevel@tonic-gate my \$msg = \$_[0]; 254*0Sstevel@tonic-gateEND_MARK_ONE 255*0Sstevel@tonic-gate 256*0Sstevel@tonic-gate $code .= <<"END_MARK_TWO" if $nc_attempt; 257*0Sstevel@tonic-gate return if index(\$msg, 'will not stay shared') != -1; 258*0Sstevel@tonic-gate return if index(\$msg, 'may be unavailable') != -1; 259*0Sstevel@tonic-gateEND_MARK_TWO 260*0Sstevel@tonic-gate 261*0Sstevel@tonic-gate $code .= <<"END_MARK_THREE"; # Backwhack a lot! 262*0Sstevel@tonic-gate print "not ok: got unexpected warning \$msg\\n"; 263*0Sstevel@tonic-gate} } 264*0Sstevel@tonic-gate 265*0Sstevel@tonic-gate{ 266*0Sstevel@tonic-gate my \$test = $test; 267*0Sstevel@tonic-gate sub test (&) { 268*0Sstevel@tonic-gate my \$ok = &{\$_[0]}; 269*0Sstevel@tonic-gate print \$ok ? "ok \$test\n" : "not ok \$test\n"; 270*0Sstevel@tonic-gate printf "# Failed at line %d\n", (caller)[2] unless \$ok; 271*0Sstevel@tonic-gate \$test++; 272*0Sstevel@tonic-gate } 273*0Sstevel@tonic-gate} 274*0Sstevel@tonic-gate 275*0Sstevel@tonic-gate# some of the variables which the closure will access 276*0Sstevel@tonic-gate\$global_scalar = 1000; 277*0Sstevel@tonic-gate\@global_array = (2000, 2100, 2200, 2300); 278*0Sstevel@tonic-gate%global_hash = 3000..3009; 279*0Sstevel@tonic-gate 280*0Sstevel@tonic-gatemy \$fs_scalar = 4000; 281*0Sstevel@tonic-gatemy \@fs_array = (5000, 5100, 5200, 5300); 282*0Sstevel@tonic-gatemy %fs_hash = 6000..6009; 283*0Sstevel@tonic-gate 284*0Sstevel@tonic-gateEND_MARK_THREE 285*0Sstevel@tonic-gate 286*0Sstevel@tonic-gate if ($where_declared eq 'filescope') { 287*0Sstevel@tonic-gate # Nothing here 288*0Sstevel@tonic-gate } elsif ($where_declared eq 'in_named') { 289*0Sstevel@tonic-gate $code .= <<'END'; 290*0Sstevel@tonic-gatesub outer { 291*0Sstevel@tonic-gate my $sub_scalar = 7000; 292*0Sstevel@tonic-gate my @sub_array = (8000, 8100, 8200, 8300); 293*0Sstevel@tonic-gate my %sub_hash = 9000..9009; 294*0Sstevel@tonic-gateEND 295*0Sstevel@tonic-gate # } 296*0Sstevel@tonic-gate } elsif ($where_declared eq 'in_anon') { 297*0Sstevel@tonic-gate $code .= <<'END'; 298*0Sstevel@tonic-gate$outer = sub { 299*0Sstevel@tonic-gate my $sub_scalar = 7000; 300*0Sstevel@tonic-gate my @sub_array = (8000, 8100, 8200, 8300); 301*0Sstevel@tonic-gate my %sub_hash = 9000..9009; 302*0Sstevel@tonic-gateEND 303*0Sstevel@tonic-gate # } 304*0Sstevel@tonic-gate } else { 305*0Sstevel@tonic-gate die "What was $where_declared?" 306*0Sstevel@tonic-gate } 307*0Sstevel@tonic-gate 308*0Sstevel@tonic-gate if ($within eq 'foreach') { 309*0Sstevel@tonic-gate $code .= " 310*0Sstevel@tonic-gate my \$foreach = 12000; 311*0Sstevel@tonic-gate my \@list = (10000, 10010); 312*0Sstevel@tonic-gate foreach \$foreach (\@list) { 313*0Sstevel@tonic-gate " # } 314*0Sstevel@tonic-gate } elsif ($within eq 'naked') { 315*0Sstevel@tonic-gate $code .= " { # naked block\n" # } 316*0Sstevel@tonic-gate } elsif ($within eq 'other_sub') { 317*0Sstevel@tonic-gate $code .= " sub inner_sub {\n" # } 318*0Sstevel@tonic-gate } else { 319*0Sstevel@tonic-gate die "What was $within?" 320*0Sstevel@tonic-gate } 321*0Sstevel@tonic-gate 322*0Sstevel@tonic-gate $sub_test = $test; 323*0Sstevel@tonic-gate @inners = ( qw!global_scalar global_array global_hash! , 324*0Sstevel@tonic-gate qw!fs_scalar fs_array fs_hash! ); 325*0Sstevel@tonic-gate push @inners, 'foreach' if $within eq 'foreach'; 326*0Sstevel@tonic-gate if ($where_declared ne 'filescope') { 327*0Sstevel@tonic-gate push @inners, qw!sub_scalar sub_array sub_hash!; 328*0Sstevel@tonic-gate } 329*0Sstevel@tonic-gate for $inner_sub_test (@inners) { 330*0Sstevel@tonic-gate 331*0Sstevel@tonic-gate if ($inner_type eq 'named') { 332*0Sstevel@tonic-gate $code .= " sub named_$sub_test " 333*0Sstevel@tonic-gate } elsif ($inner_type eq 'anon') { 334*0Sstevel@tonic-gate $code .= " \$anon_$sub_test = sub " 335*0Sstevel@tonic-gate } else { 336*0Sstevel@tonic-gate die "What was $inner_type?" 337*0Sstevel@tonic-gate } 338*0Sstevel@tonic-gate 339*0Sstevel@tonic-gate # Now to write the body of the test sub 340*0Sstevel@tonic-gate if ($inner_sub_test eq 'global_scalar') { 341*0Sstevel@tonic-gate $code .= '{ ++$global_scalar }' 342*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'fs_scalar') { 343*0Sstevel@tonic-gate $code .= '{ ++$fs_scalar }' 344*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'sub_scalar') { 345*0Sstevel@tonic-gate $code .= '{ ++$sub_scalar }' 346*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'global_array') { 347*0Sstevel@tonic-gate $code .= '{ ++$global_array[1] }' 348*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'fs_array') { 349*0Sstevel@tonic-gate $code .= '{ ++$fs_array[1] }' 350*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'sub_array') { 351*0Sstevel@tonic-gate $code .= '{ ++$sub_array[1] }' 352*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'global_hash') { 353*0Sstevel@tonic-gate $code .= '{ ++$global_hash{3002} }' 354*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'fs_hash') { 355*0Sstevel@tonic-gate $code .= '{ ++$fs_hash{6002} }' 356*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'sub_hash') { 357*0Sstevel@tonic-gate $code .= '{ ++$sub_hash{9002} }' 358*0Sstevel@tonic-gate } elsif ($inner_sub_test eq 'foreach') { 359*0Sstevel@tonic-gate $code .= '{ ++$foreach }' 360*0Sstevel@tonic-gate } else { 361*0Sstevel@tonic-gate die "What was $inner_sub_test?" 362*0Sstevel@tonic-gate } 363*0Sstevel@tonic-gate 364*0Sstevel@tonic-gate # Close up 365*0Sstevel@tonic-gate if ($inner_type eq 'anon') { 366*0Sstevel@tonic-gate $code .= ';' 367*0Sstevel@tonic-gate } 368*0Sstevel@tonic-gate $code .= "\n"; 369*0Sstevel@tonic-gate $sub_test++; # sub name sequence number 370*0Sstevel@tonic-gate 371*0Sstevel@tonic-gate } # End of foreach $inner_sub_test 372*0Sstevel@tonic-gate 373*0Sstevel@tonic-gate # Close up $within block # { 374*0Sstevel@tonic-gate $code .= " }\n\n"; 375*0Sstevel@tonic-gate 376*0Sstevel@tonic-gate # Close up $where_declared block 377*0Sstevel@tonic-gate if ($where_declared eq 'in_named') { # { 378*0Sstevel@tonic-gate $code .= "}\n\n"; 379*0Sstevel@tonic-gate } elsif ($where_declared eq 'in_anon') { # { 380*0Sstevel@tonic-gate $code .= "};\n\n"; 381*0Sstevel@tonic-gate } 382*0Sstevel@tonic-gate 383*0Sstevel@tonic-gate # We may need to do something with the sub we just made... 384*0Sstevel@tonic-gate $code .= "undef \$outer;\n" if $undef_outer; 385*0Sstevel@tonic-gate $code .= "&inner_sub;\n" if $call_inner; 386*0Sstevel@tonic-gate if ($call_outer) { 387*0Sstevel@tonic-gate if ($where_declared eq 'in_named') { 388*0Sstevel@tonic-gate $code .= "&outer;\n\n"; 389*0Sstevel@tonic-gate } elsif ($where_declared eq 'in_anon') { 390*0Sstevel@tonic-gate $code .= "&\$outer;\n\n" 391*0Sstevel@tonic-gate } 392*0Sstevel@tonic-gate } 393*0Sstevel@tonic-gate 394*0Sstevel@tonic-gate # Now, we can actually prep to run the tests. 395*0Sstevel@tonic-gate for $inner_sub_test (@inners) { 396*0Sstevel@tonic-gate $expected = $expected{$inner_sub_test} or 397*0Sstevel@tonic-gate die "expected $inner_sub_test missing"; 398*0Sstevel@tonic-gate 399*0Sstevel@tonic-gate # Named closures won't access the expected vars 400*0Sstevel@tonic-gate if ( $nc_attempt and 401*0Sstevel@tonic-gate substr($inner_sub_test, 0, 4) eq "sub_" ) { 402*0Sstevel@tonic-gate $expected = 1; 403*0Sstevel@tonic-gate } 404*0Sstevel@tonic-gate 405*0Sstevel@tonic-gate # If you make a sub within a foreach loop, 406*0Sstevel@tonic-gate # what happens if it tries to access the 407*0Sstevel@tonic-gate # foreach index variable? If it's a named 408*0Sstevel@tonic-gate # sub, it gets the var from "outside" the loop, 409*0Sstevel@tonic-gate # but if it's anon, it gets the value to which 410*0Sstevel@tonic-gate # the index variable is aliased. 411*0Sstevel@tonic-gate # 412*0Sstevel@tonic-gate # Of course, if the value was set only 413*0Sstevel@tonic-gate # within another sub which was never called, 414*0Sstevel@tonic-gate # the value has not been set yet. 415*0Sstevel@tonic-gate # 416*0Sstevel@tonic-gate if ($inner_sub_test eq 'foreach') { 417*0Sstevel@tonic-gate if ($inner_type eq 'named') { 418*0Sstevel@tonic-gate if ($call_outer || ($where_declared eq 'filescope')) { 419*0Sstevel@tonic-gate $expected = 12001 420*0Sstevel@tonic-gate } else { 421*0Sstevel@tonic-gate $expected = 1 422*0Sstevel@tonic-gate } 423*0Sstevel@tonic-gate } 424*0Sstevel@tonic-gate } 425*0Sstevel@tonic-gate 426*0Sstevel@tonic-gate # Here's the test: 427*0Sstevel@tonic-gate if ($inner_type eq 'anon') { 428*0Sstevel@tonic-gate $code .= "test { &\$anon_$test == $expected };\n" 429*0Sstevel@tonic-gate } else { 430*0Sstevel@tonic-gate $code .= "test { &named_$test == $expected };\n" 431*0Sstevel@tonic-gate } 432*0Sstevel@tonic-gate $test++; 433*0Sstevel@tonic-gate } 434*0Sstevel@tonic-gate 435*0Sstevel@tonic-gate if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { 436*0Sstevel@tonic-gate # Fork off a new perl to run the tests. 437*0Sstevel@tonic-gate # (This is so we can catch spurious warnings.) 438*0Sstevel@tonic-gate $| = 1; print ""; $| = 0; # flush output before forking 439*0Sstevel@tonic-gate pipe READ, WRITE or die "Can't make pipe: $!"; 440*0Sstevel@tonic-gate pipe READ2, WRITE2 or die "Can't make second pipe: $!"; 441*0Sstevel@tonic-gate die "Can't fork: $!" unless defined($pid = open PERL, "|-"); 442*0Sstevel@tonic-gate unless ($pid) { 443*0Sstevel@tonic-gate # Child process here. We're going to send errors back 444*0Sstevel@tonic-gate # through the extra pipe. 445*0Sstevel@tonic-gate close READ; 446*0Sstevel@tonic-gate close READ2; 447*0Sstevel@tonic-gate open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; 448*0Sstevel@tonic-gate open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; 449*0Sstevel@tonic-gate exec './perl', '-w', '-' 450*0Sstevel@tonic-gate or die "Can't exec ./perl: $!"; 451*0Sstevel@tonic-gate } else { 452*0Sstevel@tonic-gate # Parent process here. 453*0Sstevel@tonic-gate close WRITE; 454*0Sstevel@tonic-gate close WRITE2; 455*0Sstevel@tonic-gate print PERL $code; 456*0Sstevel@tonic-gate close PERL; 457*0Sstevel@tonic-gate { local $/; 458*0Sstevel@tonic-gate $output = join '', <READ>; 459*0Sstevel@tonic-gate $errors = join '', <READ2>; } 460*0Sstevel@tonic-gate close READ; 461*0Sstevel@tonic-gate close READ2; 462*0Sstevel@tonic-gate } 463*0Sstevel@tonic-gate } else { 464*0Sstevel@tonic-gate # No fork(). Do it the hard way. 465*0Sstevel@tonic-gate my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; 466*0Sstevel@tonic-gate my $errfile = "terr$$"; $errfile++ while -e $errfile; 467*0Sstevel@tonic-gate my @tmpfiles = ($cmdfile, $errfile); 468*0Sstevel@tonic-gate open CMD, ">$cmdfile"; print CMD $code; close CMD; 469*0Sstevel@tonic-gate my $cmd = (($^O eq 'VMS') ? "MCR $^X" 470*0Sstevel@tonic-gate : ($^O eq 'MSWin32') ? '.\perl' 471*0Sstevel@tonic-gate : ($^O eq 'MacOS') ? $^X 472*0Sstevel@tonic-gate : ($^O eq 'NetWare') ? 'perl' 473*0Sstevel@tonic-gate : './perl'); 474*0Sstevel@tonic-gate $cmd .= " -w $cmdfile 2>$errfile"; 475*0Sstevel@tonic-gate if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { 476*0Sstevel@tonic-gate # Use pipe instead of system so we don't inherit STD* from 477*0Sstevel@tonic-gate # this process, and then foul our pipe back to parent by 478*0Sstevel@tonic-gate # redirecting output in the child. 479*0Sstevel@tonic-gate open PERL,"$cmd |" or die "Can't open pipe: $!\n"; 480*0Sstevel@tonic-gate { local $/; $output = join '', <PERL> } 481*0Sstevel@tonic-gate close PERL; 482*0Sstevel@tonic-gate } else { 483*0Sstevel@tonic-gate my $outfile = "tout$$"; $outfile++ while -e $outfile; 484*0Sstevel@tonic-gate push @tmpfiles, $outfile; 485*0Sstevel@tonic-gate system "$cmd >$outfile"; 486*0Sstevel@tonic-gate { local $/; open IN, $outfile; $output = <IN>; close IN } 487*0Sstevel@tonic-gate } 488*0Sstevel@tonic-gate if ($?) { 489*0Sstevel@tonic-gate printf "not ok: exited with error code %04X\n", $?; 490*0Sstevel@tonic-gate $debugging or do { 1 while unlink @tmpfiles }; 491*0Sstevel@tonic-gate exit; 492*0Sstevel@tonic-gate } 493*0Sstevel@tonic-gate { local $/; open IN, $errfile; $errors = <IN>; close IN } 494*0Sstevel@tonic-gate 1 while unlink @tmpfiles; 495*0Sstevel@tonic-gate } 496*0Sstevel@tonic-gate print $output; 497*0Sstevel@tonic-gate print STDERR $errors; 498*0Sstevel@tonic-gate if ($debugging && ($errors || $? || ($output =~ /not ok/))) { 499*0Sstevel@tonic-gate my $lnum = 0; 500*0Sstevel@tonic-gate for $line (split '\n', $code) { 501*0Sstevel@tonic-gate printf "%3d: %s\n", ++$lnum, $line; 502*0Sstevel@tonic-gate } 503*0Sstevel@tonic-gate } 504*0Sstevel@tonic-gate printf "not ok: exited with error code %04X\n", $? if $?; 505*0Sstevel@tonic-gate print '#', "-" x 30, "\n" if $debugging; 506*0Sstevel@tonic-gate 507*0Sstevel@tonic-gate } # End of foreach $within 508*0Sstevel@tonic-gate } # End of foreach $where_declared 509*0Sstevel@tonic-gate } # End of foreach $inner_type 510*0Sstevel@tonic-gate 511*0Sstevel@tonic-gate} 512*0Sstevel@tonic-gate 513*0Sstevel@tonic-gate# The following dumps core with perl <= 5.8.0 (bugid 9535) ... 514*0Sstevel@tonic-gateBEGIN { $vanishing_pad = sub { eval $_[0] } } 515*0Sstevel@tonic-gate$some_var = 123; 516*0Sstevel@tonic-gatetest { $vanishing_pad->( '$some_var' ) == 123 }; 517*0Sstevel@tonic-gate 518*0Sstevel@tonic-gate# ... and here's another coredump variant - this time we explicitly 519*0Sstevel@tonic-gate# delete the sub rather than using a BEGIN ... 520*0Sstevel@tonic-gate 521*0Sstevel@tonic-gatesub deleteme { $a = sub { eval '$newvar' } } 522*0Sstevel@tonic-gatedeleteme(); 523*0Sstevel@tonic-gate*deleteme = sub {}; # delete the sub 524*0Sstevel@tonic-gate$newvar = 123; # realloc the SV of the freed CV 525*0Sstevel@tonic-gatetest { $a->() == 123 }; 526*0Sstevel@tonic-gate 527*0Sstevel@tonic-gate# ... and a further coredump variant - the fixup of the anon sub's 528*0Sstevel@tonic-gate# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to 529*0Sstevel@tonic-gate# survive the outer eval also being freed. 530*0Sstevel@tonic-gate 531*0Sstevel@tonic-gate$x = 123; 532*0Sstevel@tonic-gate$a = eval q( 533*0Sstevel@tonic-gate eval q[ 534*0Sstevel@tonic-gate sub { eval '$x' } 535*0Sstevel@tonic-gate ] 536*0Sstevel@tonic-gate); 537*0Sstevel@tonic-gate@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs 538*0Sstevel@tonic-gatetest { $a->() == 123 }; 539*0Sstevel@tonic-gate 540*0Sstevel@tonic-gate# this coredumped on <= 5.8.0 because evaling the closure caused 541*0Sstevel@tonic-gate# an SvFAKE to be added to the outer anon's pad, which was then grown. 542*0Sstevel@tonic-gatemy $outer; 543*0Sstevel@tonic-gatesub { 544*0Sstevel@tonic-gate my $x; 545*0Sstevel@tonic-gate $x = eval 'sub { $outer }'; 546*0Sstevel@tonic-gate $x->(); 547*0Sstevel@tonic-gate $a = [ 99 ]; 548*0Sstevel@tonic-gate $x->(); 549*0Sstevel@tonic-gate}->(); 550*0Sstevel@tonic-gatetest {1}; 551*0Sstevel@tonic-gate 552*0Sstevel@tonic-gate# [perl #17605] found that an empty block called in scalar context 553*0Sstevel@tonic-gate# can lead to stack corruption 554*0Sstevel@tonic-gate{ 555*0Sstevel@tonic-gate my $x = "foooobar"; 556*0Sstevel@tonic-gate $x =~ s/o//eg; 557*0Sstevel@tonic-gate test { $x eq 'fbar' } 558*0Sstevel@tonic-gate} 559*0Sstevel@tonic-gate 560*0Sstevel@tonic-gate# DAPM 24-Nov-02 561*0Sstevel@tonic-gate# SvFAKE lexicals should be visible thoughout a function. 562*0Sstevel@tonic-gate# On <= 5.8.0, the third test failed, eg bugid #18286 563*0Sstevel@tonic-gate 564*0Sstevel@tonic-gate{ 565*0Sstevel@tonic-gate my $x = 1; 566*0Sstevel@tonic-gate sub fake { 567*0Sstevel@tonic-gate test { sub {eval'$x'}->() == 1 }; 568*0Sstevel@tonic-gate { $x; test { sub {eval'$x'}->() == 1 } } 569*0Sstevel@tonic-gate test { sub {eval'$x'}->() == 1 }; 570*0Sstevel@tonic-gate } 571*0Sstevel@tonic-gate} 572*0Sstevel@tonic-gatefake(); 573*0Sstevel@tonic-gate 574*0Sstevel@tonic-gate# undefining a sub shouldn't alter visibility of outer lexicals 575*0Sstevel@tonic-gate 576*0Sstevel@tonic-gate{ 577*0Sstevel@tonic-gate $x = 1; 578*0Sstevel@tonic-gate my $x = 2; 579*0Sstevel@tonic-gate sub tmp { sub { eval '$x' } } 580*0Sstevel@tonic-gate my $a = tmp(); 581*0Sstevel@tonic-gate undef &tmp; 582*0Sstevel@tonic-gate test { $a->() == 2 }; 583*0Sstevel@tonic-gate} 584*0Sstevel@tonic-gate 585*0Sstevel@tonic-gate# handy class: $x = Watch->new(\$foo,'bar') 586*0Sstevel@tonic-gate# causes 'bar' to be appended to $foo when $x is destroyed 587*0Sstevel@tonic-gatesub Watch::new { bless [ $_[1], $_[2] ], $_[0] } 588*0Sstevel@tonic-gatesub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } 589*0Sstevel@tonic-gate 590*0Sstevel@tonic-gate 591*0Sstevel@tonic-gate# bugid 1028: 592*0Sstevel@tonic-gate# nested anon subs (and associated lexicals) not freed early enough 593*0Sstevel@tonic-gate 594*0Sstevel@tonic-gatesub linger { 595*0Sstevel@tonic-gate my $x = Watch->new($_[0], '2'); 596*0Sstevel@tonic-gate sub { 597*0Sstevel@tonic-gate $x; 598*0Sstevel@tonic-gate my $y; 599*0Sstevel@tonic-gate sub { $y; }; 600*0Sstevel@tonic-gate }; 601*0Sstevel@tonic-gate} 602*0Sstevel@tonic-gate{ 603*0Sstevel@tonic-gate my $watch = '1'; 604*0Sstevel@tonic-gate linger(\$watch); 605*0Sstevel@tonic-gate test { $watch eq '12' } 606*0Sstevel@tonic-gate} 607*0Sstevel@tonic-gate 608*0Sstevel@tonic-gaterequire "./test.pl"; 609*0Sstevel@tonic-gate 610*0Sstevel@tonic-gatecurr_test(182); 611*0Sstevel@tonic-gate 612*0Sstevel@tonic-gate# Because change #19637 was not applied to 5.8.1. 613*0Sstevel@tonic-gateSKIP: { skip("tests not in 5.8.", 3) } 614*0Sstevel@tonic-gate 615*0Sstevel@tonic-gate$test= 185; 616*0Sstevel@tonic-gate 617*0Sstevel@tonic-gaterequire './test.pl'; # for runperl() 618*0Sstevel@tonic-gate 619*0Sstevel@tonic-gate{ 620*0Sstevel@tonic-gate # bugid #23265 - this used to coredump during destruction of PL_maincv 621*0Sstevel@tonic-gate # and its children 622*0Sstevel@tonic-gate 623*0Sstevel@tonic-gate my $progfile = "b23265.pl"; 624*0Sstevel@tonic-gate open(T, ">$progfile") or die "$0: $!\n"; 625*0Sstevel@tonic-gate print T << '__EOF__'; 626*0Sstevel@tonic-gate print 627*0Sstevel@tonic-gate sub {$_[0]->(@_)} -> ( 628*0Sstevel@tonic-gate sub { 629*0Sstevel@tonic-gate $_[1] 630*0Sstevel@tonic-gate ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() 631*0Sstevel@tonic-gate : "y" 632*0Sstevel@tonic-gate }, 633*0Sstevel@tonic-gate 2 634*0Sstevel@tonic-gate ) 635*0Sstevel@tonic-gate , "\n" 636*0Sstevel@tonic-gate ; 637*0Sstevel@tonic-gate__EOF__ 638*0Sstevel@tonic-gate close T; 639*0Sstevel@tonic-gate my $got = runperl(progfile => $progfile); 640*0Sstevel@tonic-gate test { chomp $got; $got eq "yxx" }; 641*0Sstevel@tonic-gate END { 1 while unlink $progfile } 642*0Sstevel@tonic-gate} 643*0Sstevel@tonic-gate 644*0Sstevel@tonic-gate{ 645*0Sstevel@tonic-gate # bugid #24914 = used to coredump restoring PL_comppad in the 646*0Sstevel@tonic-gate # savestack, due to the early freeing of the anon closure 647*0Sstevel@tonic-gate 648*0Sstevel@tonic-gate my $got = runperl(stderr => 1, prog => 649*0Sstevel@tonic-gate'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)' 650*0Sstevel@tonic-gate ); 651*0Sstevel@tonic-gate test { $got eq "ok\n" }; 652*0Sstevel@tonic-gate} 653*0Sstevel@tonic-gate 654*0Sstevel@tonic-gate# After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point 655*0Sstevel@tonic-gate# to main rather than BEGIN, and BEGIN should be freed. 656*0Sstevel@tonic-gate 657*0Sstevel@tonic-gate{ 658*0Sstevel@tonic-gate my $flag = 0; 659*0Sstevel@tonic-gate sub X::DESTROY { $flag = 1 } 660*0Sstevel@tonic-gate { 661*0Sstevel@tonic-gate my $x; 662*0Sstevel@tonic-gate BEGIN {$x = \&newsub } 663*0Sstevel@tonic-gate sub newsub {}; 664*0Sstevel@tonic-gate $x = bless {}, 'X'; 665*0Sstevel@tonic-gate } 666*0Sstevel@tonic-gate test { $flag == 1 }; 667*0Sstevel@tonic-gate} 668