From 75839571633feac3bfc81ebab323ce9d655edfcb Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Mon, 18 Nov 2013 06:01:56 -0800
Subject: [PATCH] =?utf8?q?Fix=20=E2=80=98panic:=20memory=20wrap=E2=80=99?=
 =?utf8?q?=20in=20reg=5Fscan=5Fname?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

reg_scan_name was not checking for end-of-string.  If the character it
read were not a word character, it would then increment the current
position (RExC_parse), so that the <-- HERE marker in the error mes-
sage would point to the bad character.

If we try to split a regexp like /(?</ into two pieces when the cur-
rent position is off the end like this:

 ( ? < \0
          ^

then the first ‘half’ of the regexp, before the <-- HERE marker is
"(?<\0" (including the trailing null), and the second ‘half’ is of
negative length.  Negative string lengths are what cause ‘panic: mem-
ory wrap’.

$ ./perl -Ilib -e '/(?</'
panic: memory wrap at -e line 1.

This commit takes advantage of the fact that, ever since 1f4f6bf1,
RExC_parse == name_start has never been true after a call to
reg_scan_name.  This is how reg_scan_name now signals EOS.
---
 regcomp.c       | 12 ++++--------
 t/re/reg_mesg.t |  8 ++++++++
 2 files changed, 12 insertions(+), 8 deletions(-)

diff --git a/regcomp.c b/regcomp.c
index 7df5767..c9464ef 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7265,7 +7265,9 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
 
     PERL_ARGS_ASSERT_REG_SCAN_NAME;
 
-    if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
+    assert (RExC_parse <= RExC_end);
+    if (RExC_parse == RExC_end) NOOP;
+    else if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
 	 /* skip IDFIRST by using do...while */
 	if (UTF)
 	    do {
@@ -9223,13 +9225,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
     		        SIZE_ONLY ?  /* reverse test from the others */
     		        REG_RSN_RETURN_NAME : 
     		        REG_RSN_RETURN_NULL);
-		    if (RExC_parse == name_start) {
-		        RExC_parse++;
-		        /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
-		        vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
-		        /*NOTREACHED*/
-                    }
-		    if (*RExC_parse != paren)
+		    if (RExC_parse == name_start || *RExC_parse != paren)
 		        vFAIL2("Sequence (?%c... not terminated",
 		            paren=='>' ? '<' : paren);
 		    if (SIZE_ONLY) {
diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
index f81d8b6..70c0b01 100644
--- a/t/re/reg_mesg.t
+++ b/t/re/reg_mesg.t
@@ -214,6 +214,14 @@ my @death =
  'm/a\97/' => 'Reference to nonexistent group {#} m/a\97{#}/',
  'm/(*DOOF)/' => 'Unknown verb pattern \'DOOF\' {#} m/(*DOOF){#}/',
  'm/(?&a/'  => 'Sequence (?&... not terminated {#} m/(?&a{#}/',
+ 'm/(?P=/' => 'Sequence ?P=... not terminated {#} m/(?P={#}/',
+ "m/(?'/"  => "Sequence (?'... not terminated {#} m/(?'{#}/",
+ "m/(?</"  => "Sequence (?<... not terminated {#} m/(?<{#}/",
+ 'm/(?&/'  => 'Sequence (?&... not terminated {#} m/(?&{#}/',
+ 'm/(?(</' => 'Sequence (?(<... not terminated {#} m/(?(<{#}/',
+ "m/(?('/" => "Sequence (?('... not terminated {#} m/(?('{#}/",
+ 'm/\g{/'  => 'Sequence \g{... not terminated {#} m/\g{{#}/',
+ 'm/\k</'  => 'Sequence \k<... not terminated {#} m/\k<{#}/',
 );
 
 my @death_utf8 = mark_as_utf8(
-- 
2.7.4