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
72fresh_perl_like(<<'EOS', qr/Custom Message During Global Destruction/, { switches => ['-w'], stderr => 1 } );
73package Foo; sub DESTROY { die "Custom Message During Global Destruction" }; package main; our $wut = bless [], "Foo"
74EOS
75
76done_testing();
77