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 (file)
--- 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 (file)
--- 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 (file)
--- 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');
+}