From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 17 Apr 2010 19:11:49 +0000 (+0100)
Subject: Fix RT #74290 - regression for labels immediately before string evals.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=47550813adf9ff4023595a3d439a9080e8fa9040;p=p5sagit%2Fp5-mst-13.2.git

Fix RT #74290 - regression for labels immediately before string evals.

Fix location identified by Father Chrysostomos, who also offered a patch, but
this patch is more efficient, as it avoids any allocation. Test code based on
his test example.
---

diff --git a/hv.c b/hv.c
index 477b11e..89c6456 100644
--- a/hv.c
+++ b/hv.c
@@ -2972,6 +2972,8 @@ Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
     }
 }
 
+/* pp_entereval is aware that labels are stored with a key ':' at the top of
+   the linked list.  */
 const char *
 Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len,
 		     U32 *flags) {
diff --git a/pp_ctl.c b/pp_ctl.c
index e766d7d..d62d58a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3814,7 +3814,18 @@ PP(pp_entereval)
     if (PL_compiling.cop_hints_hash) {
 	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
     }
-    PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+    if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
+	/* The label, if present, is the first entry on the chain. So rather
+	   than writing a blank label in front of it (which involves an
+	   allocation), just use the next entry in the chain.  */
+	PL_compiling.cop_hints_hash
+	    = PL_curcop->cop_hints_hash->refcounted_he_next;
+	/* Check the assumption that this removed the label.  */
+	assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
+				    NULL) == NULL);
+    }
+    else
+	PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
     if (PL_compiling.cop_hints_hash) {
 	HINTS_REFCNT_LOCK;
 	PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
diff --git a/t/op/goto.t b/t/op/goto.t
index 5aaf630..0a8aeee 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use warnings;
 use strict;
-plan tests => 66;
+plan tests => 67;
 our $TODO;
 
 my $deprecated = 0;
@@ -474,3 +474,12 @@ TODO: {
 }
 
 is($deprecated, 0);
+
+#74290
+{
+    my $x;
+    my $y;
+    F1:++$x and eval 'return if ++$y == 10; goto F1;';
+    is($x, 10,
+       'labels outside evals can be distinguished from the start of the eval');
+}