1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9plan(tests => 169); 10 11eval 'pass();'; 12 13is($@, ''); 14 15eval "\$foo\n = # this is a comment\n'ok 3';"; 16is($foo, 'ok 3'); 17 18eval "\$foo\n = # this is a comment\n'ok 4\n';"; 19is($foo, "ok 4\n"); 20 21print eval ' 22$foo =;'; # this tests for a call through yyerror() 23like($@, qr/line 2/); 24 25print eval '$foo = /'; # this tests for a call through fatal() 26like($@, qr/Search/); 27 28is scalar(eval '++'), undef, 'eval syntax error in scalar context'; 29is scalar(eval 'die'), undef, 'eval run-time error in scalar context'; 30is +()=eval '++', 0, 'eval syntax error in list context'; 31is +()=eval 'die', 0, 'eval run-time error in list context'; 32 33is(eval '"ok 7\n";', "ok 7\n"); 34 35$foo = 5; 36$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}'; 37$ans = eval $fact; 38is($ans, 120, 'calculate a factorial with recursive evals'); 39 40$foo = 5; 41$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);'; 42$ans = eval $fact; 43is($ans, 120, 'calculate a factorial with recursive evals'); 44 45my $curr_test = curr_test(); 46my $tempfile = tempfile(); 47open(try,'>',$tempfile); 48print try 'print "ok $curr_test\n";',"\n"; 49close try; 50 51do "./$tempfile"; print $@; 52 53# Test the singlequoted eval optimizer 54 55$i = $curr_test + 1; 56for (1..3) { 57 eval 'print "ok ", $i++, "\n"'; 58} 59 60$curr_test += 4; 61 62eval { 63 print "ok $curr_test\n"; 64 die sprintf "ok %d\n", $curr_test + 2; 65 1; 66} || printf "ok %d\n$@", $curr_test + 1; 67 68curr_test($curr_test + 3); 69 70# check whether eval EXPR determines value of EXPR correctly 71 72{ 73 my @a = qw(a b c d); 74 my @b = eval @a; 75 is("@b", '4'); 76 is($@, ''); 77 78 my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')]; 79 my $b; 80 @a = eval $a; 81 is("@a", 'A'); 82 is( $b, 'A'); 83 $_ = eval $a; 84 is( $b, 'S'); 85 eval $a; 86 is( $b, 'V'); 87 88 $b = 'wrong'; 89 $x = sub { 90 my $b = "right"; 91 is(eval('"$b"'), $b); 92 }; 93 &$x(); 94} 95 96{ 97 my $b = 'wrong'; 98 my $X = sub { 99 my $b = "right"; 100 is(eval('"$b"'), $b); 101 }; 102 &$X(); 103} 104 105# check navigation of multiple eval boundaries to find lexicals 106 107my $x = 'aa'; 108eval <<'EOT'; die if $@; 109 print "# $x\n"; # clone into eval's pad 110 sub do_eval1 { 111 eval $_[0]; die if $@; 112 } 113EOT 114do_eval1('is($x, "aa")'); 115$x++; 116do_eval1('eval q[is($x, "ab")]'); 117$x++; 118do_eval1('sub { print "# $x\n"; eval q[is($x, "ac")] }->()'); 119$x++; 120 121# calls from within eval'' should clone outer lexicals 122 123eval <<'EOT'; die if $@; 124 sub do_eval2 { 125 eval $_[0]; die if $@; 126 } 127do_eval2('is($x, "ad")'); 128$x++; 129do_eval2('eval q[is($x, "ae")]'); 130$x++; 131do_eval2('sub { print "# $x\n"; eval q[is($x, "af")] }->()'); 132EOT 133 134# calls outside eval'' should NOT clone lexicals from called context 135 136$main::ok = 'not ok'; 137my $ok = 'ok'; 138eval <<'EOT'; die if $@; 139 # $x unbound here 140 sub do_eval3 { 141 eval $_[0]; die if $@; 142 } 143EOT 144{ 145 my $ok = 'not ok'; 146 do_eval3('is($ok, q{ok})'); 147 do_eval3('eval q[is($ok, q{ok})]'); 148 do_eval3('sub { eval q[is($ok, q{ok})] }->()'); 149} 150 151{ 152 my $x = curr_test(); 153 my $got; 154 sub recurse { 155 my $l = shift; 156 if ($l < $x) { 157 ++$l; 158 eval 'print "# level $l\n"; recurse($l);'; 159 die if $@; 160 } 161 else { 162 $got = "ok $l"; 163 } 164 } 165 local $SIG{__WARN__} = sub { fail() if $_[0] =~ /^Deep recurs/ }; 166 recurse(curr_test() - 5); 167 168 is($got, "ok $x", 169 "recursive subroutine-call inside eval'' see its own lexicals"); 170} 171 172 173eval <<'EOT'; 174 sub create_closure { 175 my $self = shift; 176 return sub { 177 return $self; 178 }; 179 } 180EOT 181is(create_closure("good")->(), "good", 182 'closures created within eval bind correctly'); 183 184$main::r = "good"; 185sub terminal { eval '$r . q{!}' } 186is(do { 187 my $r = "bad"; 188 eval 'terminal($r)'; 189}, 'good!', 'lexical search terminates correctly at subroutine boundary'); 190 191{ 192 # Have we cured panic which occurred with require/eval in die handler ? 193 local $SIG{__DIE__} = sub { eval {1}; die shift }; 194 eval { die "wham_eth\n" }; 195 is($@, "wham_eth\n"); 196} 197 198{ 199 my $c = eval "(1,2)x10"; 200 is($c, '2222222222', 'scalar eval"" pops stack correctly'); 201} 202 203# return from eval {} should clear $@ correctly 204{ 205 my $status = eval { 206 eval { die }; 207 print "# eval { return } test\n"; 208 return; # removing this changes behavior 209 }; 210 is($@, '', 'return from eval {} should clear $@ correctly'); 211} 212 213# ditto for eval "" 214{ 215 my $status = eval q{ 216 eval q{ die }; 217 print "# eval q{ return } test\n"; 218 return; # removing this changes behavior 219 }; 220 is($@, '', 'return from eval "" should clear $@ correctly'); 221} 222 223# Check that eval catches bad goto calls 224# (BUG ID 20010305.003 (#5963)) 225{ 226 eval { 227 eval { goto foo; }; 228 like($@, qr/Can't "goto" into the middle of a foreach loop/, 229 'eval catches bad goto calls'); 230 last; 231 foreach my $i (1) { 232 foo: fail('jumped into foreach'); 233 } 234 }; 235 fail("Outer eval didn't execute the last"); 236 diag($@); 237} 238 239# Make sure that "my $$x" is forbidden 240# 20011224 MJD 241{ 242 foreach (qw($$x @$x %$x $$$x)) { 243 eval 'my ' . $_; 244 isnt($@, '', "my $_ is forbidden"); 245 } 246} 247 248{ 249 $@ = 5; 250 eval q{}; 251 cmp_ok(length $@, '==', 0, '[ID 20020623.002 (#9721)] eval "" doesn\'t clear $@'); 252} 253 254# DAPM Nov-2002. Perl should now capture the full lexical context during 255# evals. 256 257$::zzz = $::zzz = 0; 258my $zzz = 1; 259 260eval q{ 261 sub fred1 { 262 eval q{ is(eval '$zzz', 1); } 263 } 264 fred1(47); 265 { my $zzz = 2; fred1(48) } 266}; 267 268eval q{ 269 sub fred2 { 270 is(eval('$zzz'), 1); 271 } 272}; 273fred2(49); 274{ my $zzz = 2; fred2(50) } 275 276# sort() starts a new context stack. Make sure we can still find 277# the lexically enclosing sub 278 279sub do_sort { 280 my $zzz = 2; 281 my @a = sort 282 { is(eval('$zzz'), 2); $a <=> $b } 283 2, 1; 284} 285do_sort(); 286 287# more recursion and lexical scope leak tests 288 289eval q{ 290 my $r = -1; 291 my $yyy = 9; 292 sub fred3 { 293 my $l = shift; 294 my $r = -2; 295 return 1 if $l < 1; 296 return 0 if eval '$zzz' != 1; 297 return 0 if $yyy != 9; 298 return 0 if eval '$yyy' != 9; 299 return 0 if eval '$l' != $l; 300 return $l * fred3($l-1); 301 } 302 my $r = fred3(5); 303 is($r, 120); 304 $r = eval'fred3(5)'; 305 is($r, 120); 306 $r = 0; 307 eval '$r = fred3(5)'; 308 is($r, 120); 309 $r = 0; 310 { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; 311 is($r, 120); 312}; 313my $r = fred3(5); 314is($r, 120); 315$r = eval'fred3(5)'; 316is($r, 120); 317$r = 0; 318eval'$r = fred3(5)'; 319is($r, 120); 320$r = 0; 321{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' }; 322is($r, 120); 323 324# check that goto &sub within evals doesn't leak lexical scope 325 326my $yyy = 2; 327 328sub fred4 { 329 my $zzz = 3; 330 is($zzz, 3); 331 is(eval '$zzz', 3); 332 is(eval '$yyy', 2); 333} 334 335eval q{ 336 fred4(); 337 sub fred5 { 338 my $zzz = 4; 339 is($zzz, 4); 340 is(eval '$zzz', 4); 341 is(eval '$yyy', 2); 342 goto &fred4; 343 } 344 fred5(); 345}; 346fred5(); 347{ my $yyy = 88; my $zzz = 99; fred5(); } 348eval q{ my $yyy = 888; my $zzz = 999; fred5(); }; 349 350{ 351 $eval = eval 'sub { eval "sub { %S }" }'; 352 $eval->({}); 353 pass('[perl #9728] used to dump core'); 354} 355 356# evals that appear in the DB package should see the lexical scope of the 357# thing outside DB that called them (usually the debugged code), rather 358# than the usual surrounding scope 359 360our $x = 1; 361{ 362 my $x=2; 363 sub db1 { $x; eval '$x' } 364 sub DB::db2 { $x; eval '$x' } 365 package DB; 366 sub db3 { eval '$x' } 367 sub DB::db4 { eval '$x' } 368 sub db5 { my $x=4; eval '$x' } 369 package main; 370 sub db6 { my $x=4; eval '$x' } 371} 372{ 373 my $x = 3; 374 is(db1(), 2); 375 is(DB::db2(), 2); 376 is(DB::db3(), 3); 377 is(DB::db4(), 3); 378 is(DB::db5(), 3); 379 is(db6(), 4); 380 381 # [GH #19370] 382 my sub d6 { 383 DB::db3(); 384 } 385 is(d6(), 3); 386 my $y; 387 my $d7 = sub { 388 $y; 389 DB::db3(); 390 }; 391 is($d7->(), 3); 392} 393 394# [perl #19022] used to end up with shared hash warnings 395# The program should generate no output, so anything we see is on stderr 396my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}', 397 stderr => 1); 398is ($got, ''); 399 400# And a buggy way of fixing #19022 made this fail - $k became undef after the 401# eval for a build with copy on write 402{ 403 my %h; 404 $h{a}=1; 405 foreach my $k (keys %h) { 406 is($k, 'a'); 407 408 eval "\$k"; 409 410 is($k, 'a'); 411 } 412} 413 414sub Foo {} print Foo(eval {}); 415pass('#20798 (used to dump core)'); 416 417# check for context in string eval 418{ 419 my(@r,$r,$c); 420 sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') } 421 422 my $code = q{ context() }; 423 @r = qw( a b ); 424 $r = 'ab'; 425 @r = eval $code; 426 is("@r$c", 'AA', 'string eval list context'); 427 $r = eval $code; 428 is("$r$c", 'SS', 'string eval scalar context'); 429 eval $code; 430 is("$c", 'V', 'string eval void context'); 431} 432 433# [perl #34682] escaping an eval with last could coredump or dup output 434 435$got = runperl ( 436 prog => 437 'sub A::TIEARRAY { L: { eval { last L } } } tie @a, A; warn qq(ok\n)', 438stderr => 1); 439 440is($got, "ok\n", 'eval and last'); 441 442# eval undef should be the same as eval "" barring any warnings 443 444{ 445 local $@ = "foo"; 446 eval undef; 447 is($@, "", 'eval undef'); 448} 449 450{ 451 no warnings; 452 eval "&& $b;"; 453 like($@, qr/^syntax error/, 'eval syntax error, no warnings'); 454} 455 456# a syntax error in an eval called magically (eg via tie or overload) 457# resulted in an assertion failure in S_docatch, since doeval_compile had 458# already popped the EVAL context due to the failure, but S_docatch 459# expected the context to still be there. 460 461{ 462 my $ok = 0; 463 package Eval1; 464 sub STORE { eval '('; $ok = 1 } 465 sub TIESCALAR { bless [] } 466 467 my $x; 468 tie $x, bless []; 469 $x = 1; 470 ::is($ok, 1, 'eval docatch'); 471} 472 473# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset 474# length $@ 475$@ = ""; 476eval { die "\x{a10d}"; }; 477$_ = length $@; 478eval { 1 }; 479 480cmp_ok($@, 'eq', "", 'length of $@ after eval'); 481cmp_ok(length $@, '==', 0, 'length of $@ after eval'); 482 483# Check if eval { 1 }; completely resets $@ 484SKIP: { 485 skip_if_miniperl('no dynamic loading on miniperl, no Devel::Peek', 2); 486 require Config; 487 skip('Devel::Peek was not built', 2) 488 unless $Config::Config{extensions} =~ /\bDevel\/Peek\b/; 489 490 my $tempfile = tempfile(); 491 open $prog, ">", $tempfile or die "Can't create test file"; 492 print $prog <<'END_EVAL_TEST'; 493 use Devel::Peek; 494 $! = 0; 495 $@ = $!; 496 Dump($@); 497 print STDERR "******\n"; 498 eval { die "\x{a10d}"; }; 499 $_ = length $@; 500 eval { 1 }; 501 Dump($@); 502 print STDERR "******\n"; 503 print STDERR "Done\n"; 504END_EVAL_TEST 505 close $prog or die "Can't close $tempfile: $!"; 506 my $got = runperl(progfile => $tempfile, stderr => 1); 507 my ($first, $second, $tombstone) = split (/\*\*\*\*\*\*\n/, $got); 508 509 is($tombstone, "Done\n", 'Program completed successfully'); 510 511 $first =~ s/p?[NI]OK,//g; 512 s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second; 513 s/ LEN = [0-9]+/ LEN = / foreach $first, $second; 514 # Dump may double newlines through pipes, though not files 515 # which is what this test used to use. 516 $second =~ s/ IV = 0\n\n/ IV = 0\n/ if $^O eq 'VMS'; 517 518 is($second, $first, 'eval { 1 } completely resets $@'); 519} 520 521# Test that "use feature" and other hint transmission in evals and s///ee 522# don't leak memory 523{ 524 use feature qw(:5.10); 525 my $count_expected = ($^H & 0x20000) ? 2 : 1; 526 my $t; 527 my $s = "a"; 528 $s =~ s/a/$t = \%^H; qq( qq() );/ee; 529 refcount_is $t, $count_expected, 'RT 63110'; 530} 531 532# make sure default arg eval only adds a hints hash once to entereval 533# 534{ 535 local $_ = "21+12"; 536 is(eval, 33, 'argless eval without hints'); 537 use feature qw(:5.10); 538 local $_ = "42+24"; 539 is(eval, 66, 'argless eval with hints'); 540} 541 542{ 543 # test that the CV compiled for the eval is freed by checking that no additional 544 # reference to outside lexicals are made. 545 my $x; 546 refcount_is \$x, 1+1, "originally only 1 reference"; # + 1 to account for the ref here 547 eval '$x'; 548 refcount_is \$x, 1+1, "execution eval doesn't create new references"; # + 1 the same 549} 550 551fresh_perl_is(<<'EOP', "ok\n", undef, 'RT #70862'); 552$::{'@'}=''; 553eval {}; 554print "ok\n"; 555EOP 556 557fresh_perl_is(<<'EOP', "ok\n", undef, 'variant of RT #70862'); 558eval { 559 $::{'@'}=''; 560}; 561print "ok\n"; 562EOP 563 564fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); 565$::{'@'}=\3; 566eval {}; 567print "ok\n"; 568EOP 569 570fresh_perl_is(<<'EOP', "ok\n", undef, 'related to RT #70862'); 571eval { 572 $::{'@'}=\3; 573}; 574print "ok\n"; 575EOP 576 577 fresh_perl_is(<<'EOP', "ok\n", undef, 'segfault on syntax errors in block evals'); 578# localize the hits hash so the eval ends up with the pad offset of a copy of it in its targ 579BEGIN { $^H |= 0x00020000 } 580eval q{ eval { + } }; 581print "ok\n"; 582EOP 583 584fresh_perl_is(<<'EOP', "ok\n", undef, 'assert fail on non-string in Perl_lex_start'); 585use overload '""' => sub { '1;' }; 586my $ov = bless []; 587eval $ov; 588print "ok\n"; 589EOP 590 591for my $k (!0) { 592 eval 'my $do_something_with = $k'; 593 eval { $k = 'mon' }; 594 is "a" =~ /a/, "1", 595 "string eval leaves readonly lexicals readonly [perl #19135]"; 596} 597 598# [perl #68750] 599fresh_perl_is(<<'EOP', "ok\nok\nok\n", undef, 'eval clears %^H'); 600 BEGIN { 601 require re; re->import('/x'); # should only affect surrounding scope 602 eval ' 603 print "a b" =~ /a b/ ? "ok\n" : "nokay\n"; 604 use re "/m"; 605 print "a b" =~ /a b/ ? "ok\n" : "nokay\n"; 606 '; 607 } 608 print "ab" =~ /a b/ ? "ok\n" : "nokay\n"; 609EOP 610 611# [perl #70151] 612{ 613 BEGIN { eval 'require re; import re "/x"' } 614 ok "ab" =~ /a b/, 'eval does not localise %^H at run time'; 615} 616 617# The fix for perl #70151 caused an assertion failure that broke 618# SNMP::Trapinfo, when toke.c finds no syntax errors but perly.y fails. 619eval(q|""!=!~//|); 620pass("phew! dodged the assertion after a parsing (not lexing) error"); 621 622# [perl #111462] 623{ 624 local $ENV{PERL_DESTRUCT_LEVEL} = 1; 625 unlike 626 runperl( 627 prog => 'BEGIN { $^H{foo} = bar }' 628 .'our %FIELDS; my main $x; eval q[$x->{foo}]', 629 stderr => 1, 630 ), 631 qr/Unbalanced string table/, 632 'Errors in finalize_optree do not leak string eval op tree'; 633} 634 635# [perl #114658] Line numbers at end of string eval 636for("{;", "{") { 637 eval $_; is $@ =~ s/eval \d+/eval 1/rag, <<'EOE', 638Missing right curly or square bracket at (eval 1) line 1, at end of line 639syntax error at (eval 1) line 1, at EOF 640Execution of (eval 1) aborted due to compilation errors. 641EOE 642 qq'Right line number for eval "$_"'; 643} 644 645{ 646 my $w; 647 local $SIG{__WARN__} = sub { $w .= shift }; 648 649 eval "\${\nfoobar\n} = 10; warn q{should be line 3}"; 650 is( 651 $w =~ s/eval \d+/eval 1/ra, 652 "should be line 3 at (eval 1) line 3.\n", 653 'eval qq{\${\nfoo\n}; warn} updates the line number correctly' 654 ); 655} 656 657sub _117941 { package _117941; eval '$a' } 658delete $::{"_117941::"}; 659_117941(); 660pass("eval in freed package does not crash"); 661 662# eval is supposed normally to clear $@ on success 663 664{ 665 $@ = 1; 666 eval q{$@ = 2}; 667 ok(!$@, 'eval clearing $@'); 668} 669 670# RT #127786 671# this used to give an assertion failure 672 673{ 674 package DB { 675 sub f127786 { eval q/\$s/ } 676 } 677 my $s; 678 sub { $s; DB::f127786}->(); 679 pass("RT #127786"); 680} 681 682# Late calling of destructors overwriting $@. 683# When leaving an eval scope (either by falling off the end or dying), 684# we must ensure that any temps are freed before the end of the eval 685# leave: in particular before $@ is set (to either "" or the error), 686# because otherwise the tmps freeing may call a destructor which 687# will change $@ (e.g. due to a successful eval) *after* its been set. 688# Some extra nested scopes are included in the tests to ensure they don't 689# affect the tmps freeing. 690 691{ 692 package TMPS; 693 sub DESTROY { eval { die "died in DESTROY"; } } # alters $@ 694 695 eval { { 1; { 1; bless []; } } }; 696 ::is ($@, "", "FREETMPS: normal try exit"); 697 698 eval q{ { 1; { 1; bless []; } } }; 699 ::is ($@, "", "FREETMPS: normal string eval exit"); 700 701 eval { { 1; { 1; return bless []; } } }; 702 ::is ($@, "", "FREETMPS: return try exit"); 703 704 eval q{ { 1; { 1; return bless []; } } }; 705 ::is ($@, "", "FREETMPS: return string eval exit"); 706 707 eval { { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } }; 708 ::like ($@, qr/die in eval/, "FREETMPS: die try exit"); 709 710 eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } }; 711 ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit"); 712} 713 714{ 715 local ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 0; 716 my ($x, $ok); 717 $x = 0; 718 $ok= eval 'BEGIN { $x++ } 1'; 719 ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 0 blocks BEGIN blocks entirely'); 720 ::like($@,qr/Too many nested BEGIN blocks, maximum of 0 allowed/, 721 'Blocked BEGIN results in expected error'); 722 ::is($x,0,'BEGIN really did nothing'); 723 724 ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}= 2; 725 $ok= eval 'sub f { my $n= shift; eval q[BEGIN { $x++; f($n-1) if $n>0 } 1] or die $@ } f(3); 1'; 726 ::ok(!$ok,'${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 2 blocked three nested BEGIN blocks'); 727 ::like($@,qr/Too many nested BEGIN blocks, maximum of 2 allowed/, 728 'Blocked BEGIN results in expected error'); 729 ::is($x,2,'BEGIN really did nothing'); 730 731} 732 733{ 734 # make sure that none of these segfault. 735 foreach my $line ( 736 'eval "UNITCHECK { eval q(UNITCHECK { die; }); print q(A-) }";', 737 'eval "UNITCHECK { eval q(BEGIN { die; }); print q(A-) }";', 738 'eval "BEGIN { eval q(UNITCHECK { die; }); print q(A-) }";', 739 'CHECK { eval "]" } print q"A-";', 740 'INIT { eval "]" } print q"A-";', 741 'UNITCHECK { eval "]" } print q"A-";', 742 'BEGIN { eval "]" } print q"A-";', 743 'INIT { eval q(UNITCHECK { die; } print 0;); print q(A-); }', 744 ) { 745 fresh_perl_is($line . ' print "ok";', "A-ok", {}, "No segfault: $line"); 746 747 # sort blocks are somewhat special and things that work in normal blocks 748 # can blow up in sort blocks, so test these constructs specially. 749 my $sort_line= 'my @x= sort { ' . $line . ' } 1,2;'; 750 fresh_perl_is($sort_line . ' print "ok";', "A-ok", {}, 751 "No segfault inside sort: $sort_line"); 752 } 753} 754{ 755 # test that all of these cases behave the same 756 for my $fragment ('bar', '1+;', '1+;' x 11, 's/', ']') { 757 fresh_perl_is( 758 # code: 759 'use strict; use warnings; $SIG{__DIE__} = sub { die "X" }; ' . 760 'eval { eval "'.$fragment.'"; print "after eval $@"; };' . 761 'if ($@) { print "outer eval $@" }', 762 # wanted: 763 "after eval X at - line 1.", 764 # opts: 765 {}, 766 # name: 767 "test that nested eval '$fragment' calls sig die as expected" 768 ); 769 } 770} 771