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