1898184e3Ssthen#!./perl -w 2898184e3Ssthen 3898184e3Ssthenrequire './test.pl'; 4898184e3Ssthenuse strict; 5898184e3Ssthen 6898184e3Ssthen# 7898184e3Ssthen# This test checks for $@ being set early during an exceptional 8*91f110e0Safresh1# unwinding, and that this early setting does not affect the late 9898184e3Ssthen# setting used to emit the exception from eval{}. The early setting is 10898184e3Ssthen# a backward-compatibility hack to satisfy modules that were relying on 11898184e3Ssthen# the historical early setting in order to detect exceptional unwinding. 12898184e3Ssthen# This hack should be removed when a proper way to detect exceptional 13898184e3Ssthen# unwinding has been developed. 14898184e3Ssthen# 15898184e3Ssthen 16898184e3Ssthen{ 17898184e3Ssthen package End; 18898184e3Ssthen sub DESTROY { $_[0]->() } 19898184e3Ssthen sub main::end(&) { 20898184e3Ssthen my($cleanup) = @_; 21898184e3Ssthen return bless(sub { $cleanup->() }, "End"); 22898184e3Ssthen } 23898184e3Ssthen} 24898184e3Ssthen 25898184e3Ssthenmy($uerr, $val, $err); 26898184e3Ssthen 27898184e3Ssthen$@ = ""; 28898184e3Ssthen$val = eval { 29898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 30898184e3Ssthen 1; 31898184e3Ssthen}; $err = $@; 32*91f110e0Safresh1is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block"); 33*91f110e0Safresh1is($val, 1, "successful return from 'eval' block"); 34*91f110e0Safresh1is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 35898184e3Ssthen 36898184e3Ssthen$@ = "t0\n"; 37898184e3Ssthen$val = eval { 38898184e3Ssthen $@ = "t1\n"; 39898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 40898184e3Ssthen 1; 41898184e3Ssthen}; $err = $@; 42*91f110e0Safresh1is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block"); 43*91f110e0Safresh1is($val, 1, "successful return from 'eval' block"); 44*91f110e0Safresh1is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 45898184e3Ssthen 46898184e3Ssthen$@ = ""; 47898184e3Ssthen$val = eval { 48898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 49898184e3Ssthen do { 50898184e3Ssthen die "t3\n"; 51898184e3Ssthen }; 52898184e3Ssthen 1; 53898184e3Ssthen}; $err = $@; 54898184e3Ssthenis($uerr, "t3\n"); 55*91f110e0Safresh1is($val, undef, "undefined return value from 'eval' block with 'die'"); 56898184e3Ssthenis($err, "t3\n"); 57898184e3Ssthen 58898184e3Ssthen$@ = "t0\n"; 59898184e3Ssthen$val = eval { 60898184e3Ssthen $@ = "t1\n"; 61898184e3Ssthen my $c = end { $uerr = $@; $@ = "t2\n"; }; 62898184e3Ssthen do { 63898184e3Ssthen die "t3\n"; 64898184e3Ssthen }; 65898184e3Ssthen 1; 66898184e3Ssthen}; $err = $@; 67898184e3Ssthenis($uerr, "t3\n"); 68*91f110e0Safresh1is($val, undef, "undefined return value from 'eval' block with 'die'"); 69898184e3Ssthenis($err, "t3\n"); 70898184e3Ssthen 71898184e3Ssthendone_testing(); 72