In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/22a30693fc87702395761f2f556d3f49e6c89c3d?hp=095a5c3e83eb5f5932cdf8d475a61091dbf274e3>
- Log -----------------------------------------------------------------
commit 22a30693fc87702395761f2f556d3f49e6c89c3d
Author: Zefram <zef...@fysh.org>
Date: Mon Dec 6 22:21:19 2010 +0000
stopgap hack for $@ as unwinding reason indicator
Set $@ early in a die as well as late, so that it continues to function
as an unreliable indicator of whether unwinding in progress is due to
an exception. This is a stopgap arrangement, until the unwinding process
can be introspected properly.
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
pp_ctl.c | 34 ++++++++++++++++++++++++
t/op/die_unwind.t | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 109 insertions(+), 0 deletions(-)
create mode 100644 t/op/die_unwind.t
diff --git a/MANIFEST b/MANIFEST
index 1a9de2d..ad0660d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4652,6 +4652,7 @@ t/op/die_except.t See if die/eval avoids $@
clobberage
t/op/die_exit.t See if die and exit status interaction
works
t/op/die_keeperr.t See if G_KEEPERR works for destructors
t/op/die.t See if die works
+t/op/die_unwind.t Check die/eval early-$@ backcompat hack
t/op/dor.t See if defined-or (//) works
t/op/do.t See if subroutines work
t/op/each_array.t See if array iterators work
diff --git a/pp_ctl.c b/pp_ctl.c
index fa25681..48a4e41 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1645,6 +1645,40 @@ Perl_die_unwind(pTHX_ SV *msv)
I32 cxix;
I32 gimme;
+ /*
+ * Historically, perl used to set ERRSV ($@) early in the die
+ * process and rely on it not getting clobbered during unwinding.
+ * That sucked, because it was liable to get clobbered, so the
+ * setting of ERRSV used to emit the exception from eval{} has
+ * been moved to much later, after unwinding (see just before
+ * JMPENV_JUMP below). However, some modules were relying on the
+ * early setting, by examining $@ during unwinding to use it as
+ * a flag indicating whether the current unwinding was caused by
+ * an exception. It was never a reliable flag for that purpose,
+ * being totally open to false positives even without actual
+ * clobberage, but was useful enough for production code to
+ * semantically rely on it.
+ *
+ * We'd like to have a proper introspective interface that
+ * explicitly describes the reason for whatever unwinding
+ * operations are currently in progress, so that those modules
+ * work reliably and $@ isn't further overloaded. But we don't
+ * have one yet. In its absence, as a stopgap measure, ERRSV is
+ * now *additionally* set here, before unwinding, to serve as the
+ * (unreliable) flag that it used to.
+ *
+ * This behaviour is temporary, and should be removed when a
+ * proper way to detect exceptional unwinding has been developed.
+ * As of 2010-12, the authors of modules relying on the hack
+ * are aware of the issue, because the modules failed on
+ * perls 5.13.{1..7} which had late setting of $@ without this
+ * early-setting hack.
+ */
+ if (!(in_eval & EVAL_KEEPERR)) {
+ SvTEMP_off(exceptsv);
+ sv_setsv(ERRSV, exceptsv);
+ }
+
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
diff --git a/t/op/die_unwind.t b/t/op/die_unwind.t
new file mode 100644
index 0000000..36772c4
--- /dev/null
+++ b/t/op/die_unwind.t
@@ -0,0 +1,74 @@
+#!./perl
+
+#
+# This test checks for $@ being set early during an exceptional
+# unwinding, and that this early setting doesn't affect the late
+# setting used to emit the exception from eval{}. The early setting is
+# a backward-compatibility hack to satisfy modules that were relying on
+# the historical early setting in order to detect exceptional unwinding.
+# This hack should be removed when a proper way to detect exceptional
+# unwinding has been developed.
+#
+
+print "1..12\n";
+my $test_num = 0;
+sub ok {
+ print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n";
+}
+
+{
+ package End;
+ sub DESTROY { $_[0]->() }
+ sub main::end(&) {
+ my($cleanup) = @_;
+ return bless(sub { $cleanup->() }, "End");
+ }
+}
+
+my($uerr, $val, $err);
+
+$@ = "";
+$val = eval {
+ my $c = end { $uerr = $@; $@ = "t2\n"; };
+ 1;
+}; $err = $@;
+ok $uerr eq "";
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+ $@ = "t1\n";
+ my $c = end { $uerr = $@; $@ = "t2\n"; };
+ 1;
+}; $err = $@;
+ok $uerr eq "t1\n";
+ok $val == 1;
+ok $err eq "";
+
+$@ = "";
+$val = eval {
+ my $c = end { $uerr = $@; $@ = "t2\n"; };
+ do {
+ die "t3\n";
+ };
+ 1;
+}; $err = $@;
+ok $uerr eq "t3\n";
+ok !defined($val);
+ok $err eq "t3\n";
+
+$@ = "t0\n";
+$val = eval {
+ $@ = "t1\n";
+ my $c = end { $uerr = $@; $@ = "t2\n"; };
+ do {
+ die "t3\n";
+ };
+ 1;
+}; $err = $@;
+ok $uerr eq "t3\n";
+ok !defined($val);
+ok $err eq "t3\n";
+
+1;
--
Perl5 Master Repository
