From: David Mitchell <davem@iabyn.com>
Date: Mon, 17 May 2010 23:54:50 +0000 (+0100)
Subject: further fix for RT #23810
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c86ffc3299ed26fc3616b4d2bb0abdf2e70a0ad1;p=p5sagit%2Fp5-mst-13.2.git

further fix for RT #23810

The fix for #23810, 27e904532594b7fb, introduced a regression, spotted by
Nicholas as RT #75146.

Basically, in S_doeval() if the yyparse() fails due to dying (rather than
just bailing out with with a syntax error, say), then the topmost EVAL
context will have been popped. My improved error handling code mostly
understood the difference, but forgot that in the die case, PL_eval_root
will have been restored to its previous value by the CX pop, and thus
its value shouldn't be messed with.
---

diff --git a/pp_ctl.c b/pp_ctl.c
index 37a585c..d203960 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3139,12 +3139,14 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 	PERL_UNUSED_VAR(newsp);
 	PERL_UNUSED_VAR(optype);
 
+	/* note that if yystatus == 3, then the EVAL CX block has already
+	 * been popped, and various vars restored */
 	PL_op = saveop;
-	if (PL_eval_root) {
-	    op_free(PL_eval_root);
-	    PL_eval_root = NULL;
-	}
 	if (yystatus != 3) {
+	    if (PL_eval_root) {
+		op_free(PL_eval_root);
+		PL_eval_root = NULL;
+	    }
 	    SP = PL_stack_base + POPMARK;	/* pop original mark */
 	    if (!startop) {
 		POPBLOCK(cx,PL_curpm);
diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t
index f22e170..2019d9b 100644
--- a/t/run/fresh_perl.t
+++ b/t/run/fresh_perl.t
@@ -857,3 +857,43 @@ $@ =~ s/ at .*/ at/;
 print $@
 EXPECT
 Malformed UTF-8 character (unexpected end of string) in substitution (s///) at
+######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression"
+use strict;
+
+unshift @INC, sub {
+    my ($self, $fn) = @_;
+
+    (my $pkg = $fn) =~ s{/}{::}g;
+    $pkg =~ s{.pm$}{};
+
+    if ($pkg eq 'Credit') {
+        my $code = <<'EOC';
+package Credit;
+
+use NonsenseAndBalderdash;
+
+1;
+EOC
+        eval $code;
+        die "\$@ is $@";
+    }
+
+    #print STDERR "Generator: not one of mine, ignoring\n";
+    return undef;
+};
+
+# create load-on-demand new() constructors
+{
+    package Credit;
+    sub new {
+        eval "use Credit";
+    }
+};
+
+eval {
+    my $credit = new Credit;
+};
+
+print "If you get here, you didn't crash\n";
+EXPECT
+If you get here, you didn't crash