Commit | Line | Data |
---|---|---|
d7c80187 NC |
1 | #!./perl -w |
2 | ||
b5efbd1f | 3 | chdir 't' if -d 't'; |
d7c80187 NC |
4 | require './test.pl'; |
5 | use strict; | |
22a30693 Z |
6 | |
7 | # | |
8 | # This test checks for $@ being set early during an exceptional | |
d479ea79 | 9 | # unwinding, and that this early setting does not affect the late |
22a30693 Z |
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 | ||
22a30693 Z |
17 | { |
18 | package End; | |
19 | sub DESTROY { $_[0]->() } | |
20 | sub main::end(&) { | |
21 | my($cleanup) = @_; | |
22 | return bless(sub { $cleanup->() }, "End"); | |
23 | } | |
24 | } | |
25 | ||
26 | my($uerr, $val, $err); | |
27 | ||
28 | $@ = ""; | |
29 | $val = eval { | |
30 | my $c = end { $uerr = $@; $@ = "t2\n"; }; | |
31 | 1; | |
32 | }; $err = $@; | |
d479ea79 JK |
33 | is($uerr, "", "\$@ false at start of 'end' block inside 'eval' block"); |
34 | is($val, 1, "successful return from 'eval' block"); | |
35 | is($err, "", "\$@ still false after 'end' block inside 'eval' block"); | |
22a30693 Z |
36 | |
37 | $@ = "t0\n"; | |
38 | $val = eval { | |
39 | $@ = "t1\n"; | |
40 | my $c = end { $uerr = $@; $@ = "t2\n"; }; | |
41 | 1; | |
42 | }; $err = $@; | |
d479ea79 JK |
43 | is($uerr, "t1\n", "true value assigned to \$@ before 'end' block inside 'eval' block"); |
44 | is($val, 1, "successful return from 'eval' block"); | |
45 | is($err, "", "\$@ still false after 'end' block inside 'eval' block"); | |
22a30693 Z |
46 | |
47 | $@ = ""; | |
48 | $val = eval { | |
49 | my $c = end { $uerr = $@; $@ = "t2\n"; }; | |
50 | do { | |
51 | die "t3\n"; | |
52 | }; | |
53 | 1; | |
54 | }; $err = $@; | |
d7c80187 | 55 | is($uerr, "t3\n"); |
d479ea79 | 56 | is($val, undef, "undefined return value from 'eval' block with 'die'"); |
d7c80187 | 57 | is($err, "t3\n"); |
22a30693 Z |
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 = $@; | |
d7c80187 | 68 | is($uerr, "t3\n"); |
d479ea79 | 69 | is($val, undef, "undefined return value from 'eval' block with 'die'"); |
d7c80187 | 70 | is($err, "t3\n"); |
22a30693 | 71 | |
d7c80187 | 72 | done_testing(); |