1#!./perl -w 2 3require './test.pl'; 4use strict; 5 6# 7# This test checks for $@ being set early during an exceptional 8# unwinding, and that this early setting does not affect the late 9# setting used to emit the exception from eval{}. The early setting is 10# a backward-compatibility hack to satisfy modules that were relying on 11# the historical early setting in order to detect exceptional unwinding. 12# This hack should be removed when a proper way to detect exceptional 13# unwinding has been developed. 14# 15 16{ 17 package End; 18 sub DESTROY { $_[0]->() } 19 sub main::end(&) { 20 my($cleanup) = @_; 21 return bless(sub { $cleanup->() }, "End"); 22 } 23} 24 25my($uerr, $val, $err); 26 27$@ = ""; 28$val = eval { 29 my $c = end { $uerr = $@; $@ = "t2\n"; }; 30 1; 31}; $err = $@; 32is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block"); 33is($val, 1, "successful return from 'eval' block"); 34is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 35 36$@ = "t0\n"; 37$val = eval { 38 $@ = "t1\n"; 39 my $c = end { $uerr = $@; $@ = "t2\n"; }; 40 1; 41}; $err = $@; 42is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block"); 43is($val, 1, "successful return from 'eval' block"); 44is($err, "", "\$@ still false after 'end' block inside 'eval' block"); 45 46$@ = ""; 47$val = eval { 48 my $c = end { $uerr = $@; $@ = "t2\n"; }; 49 do { 50 die "t3\n"; 51 }; 52 1; 53}; $err = $@; 54is($uerr, "t3\n"); 55is($val, undef, "undefined return value from 'eval' block with 'die'"); 56is($err, "t3\n"); 57 58$@ = "t0\n"; 59$val = eval { 60 $@ = "t1\n"; 61 my $c = end { $uerr = $@; $@ = "t2\n"; }; 62 do { 63 die "t3\n"; 64 }; 65 1; 66}; $err = $@; 67is($uerr, "t3\n"); 68is($val, undef, "undefined return value from 'eval' block with 'die'"); 69is($err, "t3\n"); 70 71done_testing(); 72