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.

diff --git a/MANIFEST b/MANIFEST
index 1a9de2d..ad0660d 100644 (file)
--- 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 (file)
--- 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 (file)
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;