1898184e3Ssthen#!./perl -w 2898184e3Ssthen 3b8851fccSafresh1chdir 't' if -d 't'; 4898184e3Ssthenrequire './test.pl'; 5898184e3Ssthenuse strict; 6898184e3Ssthen 7898184e3Ssthen# 8898184e3Ssthen# This test checks for $@ being set early during an exceptional 991f110e0Safresh1# unwinding, and that this early setting does not affect the late 10898184e3Ssthen# setting used to emit the exception from eval{}. The early setting is 11898184e3Ssthen# a backward-compatibility hack to satisfy modules that were relying on 12898184e3Ssthen# the historical early setting in order to detect exceptional unwinding. 13898184e3Ssthen# This hack should be removed when a proper way to detect exceptional 14898184e3Ssthen# unwinding has been developed. 15898184e3Ssthen# 16898184e3Ssthen 17898184e3Ssthen{ 18898184e3Ssthen package End; 19898184e3Ssthen sub DESTROY { $_[0]->() } 20898184e3Ssthen sub main::end(&) { 21898184e3Ssthen my($cleanup) = @_; 22898184e3Ssthen return bless(sub { $cleanup->() }, "End"); 23898184e3Ssthen } 24898184e3Ssthen} 25898184e3Ssthen 26898184e3Ssthenmy($uerr, $val, $err); 27898184e3Ssthen 28898184e3Ssthen$@ = ""; 29898184e3Ssthen$val = eval { 30898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 31898184e3Ssthen 1; 32898184e3Ssthen}; $err = $@; 3391f110e0Safresh1is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block"); 3491f110e0Safresh1is($val, 1, "successful return from 'eval' block"); 3591f110e0Safresh1is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 36898184e3Ssthen 37898184e3Ssthen$@ = "t0\n"; 38898184e3Ssthen$val = eval { 39898184e3Ssthen $@ = "t1\n"; 40898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 41898184e3Ssthen 1; 42898184e3Ssthen}; $err = $@; 4391f110e0Safresh1is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block"); 4491f110e0Safresh1is($val, 1, "successful return from 'eval' block"); 4591f110e0Safresh1is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 46898184e3Ssthen 47898184e3Ssthen$@ = ""; 48898184e3Ssthen$val = eval { 49898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 50898184e3Ssthen do { 51898184e3Ssthen die "t3\n"; 52898184e3Ssthen }; 53898184e3Ssthen 1; 54898184e3Ssthen}; $err = $@; 55898184e3Ssthenis($uerr, "t3\n"); 5691f110e0Safresh1is($val, undef, "undefined return value from 'eval' block with 'die'"); 57898184e3Ssthenis($err, "t3\n"); 58898184e3Ssthen 59898184e3Ssthen$@ = "t0\n"; 60898184e3Ssthen$val = eval { 61898184e3Ssthen $@ = "t1\n"; 62898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 63898184e3Ssthen do { 64898184e3Ssthen die "t3\n"; 65898184e3Ssthen }; 66898184e3Ssthen 1; 67898184e3Ssthen}; $err = $@; 68898184e3Ssthenis($uerr, "t3\n"); 6991f110e0Safresh1is($val, undef, "undefined return value from 'eval' block with 'die'"); 70898184e3Ssthenis($err, "t3\n"); 71898184e3Ssthen 72*56d68f1eSafresh1fresh_perl_like(<<'EOS', qr/Custom Message During Global Destruction/, { switches => ['-w'], stderr => 1 } ); 73*56d68f1eSafresh1package Foo; sub DESTROY { die "Custom Message During Global Destruction" }; package main; our $wut = bless [], "Foo" 74*56d68f1eSafresh1EOS 75*56d68f1eSafresh1 76898184e3Ssthendone_testing(); 77