From 0b3da58dfdc350792109691bb6c07a48109b9e12 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 1 Dec 2009 22:25:39 +1100
Subject: [PATCH 1/1] -Dmad: double free or corruption

> If your perl has -Dmad, the following program crashes:
>
> $ bleadperl -we '$x="x" x 257; eval "for $x"'
> *** glibc detected *** bleadperl: double free or corruption (!prev): 0x0000000001dca670 ***

Change 6136c704 changed S_scan_ident from:

   e = d + destlen - 3;

to:

   register char * const e = d + destlen + 3;

where e is used to mark the end of the buffer, this meant that the
various buffer end checks allowed the various buffers supplied
S_scan_ident to overflow.

Attached is a fix, various tests with fencepost checks on different
identifier lengths, and the specific case mentioned in the ticket.

Tony

Signed-off-by: H.Merijn Brand <h.m.brand@xs4all.nl>
---
 t/comp/parser.t | 50 +++++++++++++++++++++++++++++++++++++++++++++++++-
 toke.c          |  2 +-
 2 files changed, 50 insertions(+), 2 deletions(-)

diff --git a/t/comp/parser.t b/t/comp/parser.t
index 6cbba9b..05c8d65 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -3,7 +3,7 @@
 # Checks if the parser behaves correctly in edge cases
 # (including weird syntax errors)
 
-print "1..104\n";
+print "1..117\n";
 
 sub failed {
     my ($got, $expected, $name) = @_;
@@ -285,6 +285,54 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' );
 eval q[ BEGIN {\&foo4; die } ] for 1..10;
 like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' );
 
+{
+  # RT #70934
+  # check both the specific case in the ticket, and a few other paths into
+  # S_scan_ident()
+  # simplify long ids
+  my $x100 = "x" x 256;
+  my $xFE = "x" x 254;
+  my $xFD = "x" x 253;
+  my $xFC = "x" x 252;
+  my $xFB = "x" x 251;
+
+  eval qq[ \$#$xFB ];
+  is($@, "", "251 character \$# sigil ident ok");
+  eval qq[ \$#$xFC ];
+  like($@, qr/Identifier too long/, "too long id in \$# sigil ctx");
+
+  eval qq[ \$$xFB ];
+  is($@, "", "251 character \$ sigil ident ok");
+  eval qq[ \$$xFC ];
+  like($@, qr/Identifier too long/, "too long id in \$ sigil ctx");
+
+  eval qq[ %$xFB ];
+  is($@, "", "251 character % sigil ident ok");
+  eval qq[ %$xFC ];
+  like($@, qr/Identifier too long/, "too long id in % sigil ctx");
+
+  eval qq[ \\&$xFC ]; # take a ref since I don't want to call it
+  is($@, "", "252 character & sigil ident ok");
+  eval qq[ \\&$xFD ];
+  like($@, qr/Identifier too long/, "too long id in & sigil ctx");
+
+  eval qq[ *$xFC ];
+  is($@, "", "252 character glob ident ok");
+  eval qq[ *$xFD ];
+  like($@, qr/Identifier too long/, "too long id in glob ctx");
+
+  eval qq[ for $xFD ];
+  like($@, qr/Missing \$ on loop variable/,
+       "253 char id ok, but a different error");
+  eval qq[ for $xFE; ];
+  like($@, qr/Identifier too long/, "too long id in for ctx");
+
+  # the specific case from the ticket
+  my $x = "x" x 257;
+  eval qq[ for $x ];
+  like($@, qr/Identifier too long/, "too long id ticket case");
+}
+
 # Add new tests HERE:
 
 # More awkward tests for #line. Keep these at the end, as they will screw
diff --git a/toke.c b/toke.c
index 784ed7a..d498a34 100644
--- a/toke.c
+++ b/toke.c
@@ -11366,7 +11366,7 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL
     char *bracket = NULL;
     char funny = *s++;
     register char *d = dest;
-    register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
+    register char * const e = d + destlen - 3;    /* two-character token, ending NUL */
 
     PERL_ARGS_ASSERT_SCAN_IDENT;
 
-- 
1.8.3.1