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