heap-use-after-free in Perl_sv_catpvn_flags (sv.c:5455)

[p5pRT]

Migrated from rt.perl.org#129995 (status was 'resolved')

Searchable as RT129995$

[p5pRT]

From @geeknik

Triggered with Perl v5.25.7 (v5.25.6-134-g11327fa) and AFL+ASAN. Doesn't
fail with Valgrind and non-ASAN builds.

perl -e '$^X^=r'

==2379==ERROR​: AddressSanitizer​: heap-use-after-free on address
0x60300000eec1 at pc 0x0000004a9dd2 bp 0x7ffc27edf870 sp 0x7ffc27edf030
READ of size 14 at 0x60300000eec1 thread T0
  #0 0x4a9dd1 in __asan_memmove (/root/perl/perl+0x4a9dd1)
  #1 0x93f26e in Perl_sv_catpvn_flags /root/perl/sv.c​:5455​:7
  #2 0xb1f18e in Perl_do_vop /root/perl/doop.c​:1222​:3
  #3 0x9cf4af in Perl_pp_bit_or /root/perl/pp.c​:2471​:2
  #4 0x7f4cbb in Perl_runops_debug /root/perl/dump.c​:2249​:23
  #5 0x5a1523 in S_run_body /root/perl/perl.c​:2538​:2
  #6 0x5a1523 in perl_run /root/perl/perl.c​:2461
  #7 0x4de63d in main /root/perl/perlmain.c​:123​:9
  #8 0x7fbb85561b44 in __libc_start_main /build/glibc-daoqzt/glibc-2.
19/csu/libc-start.c​:287
  #9 0x4de2ac in _start (/root/perl/perl+0x4de2ac)

0x60300000eec1 is located 1 bytes inside of 17-byte region [0x60300000eec0,
0x60300000eed1)
freed by thread T0 here​:
  #0 0x4c0f1e in realloc (/root/perl/perl+0x4c0f1e)
  #1 0x7f9216 in Perl_safesysrealloc /root/perl/util.c​:274​:18

previously allocated by thread T0 here​:
  #0 0x4c0c2b in malloc (/root/perl/perl+0x4c0c2b)
  #1 0x7f8b27 in Perl_safesysmalloc /root/perl/util.c​:153​:21

SUMMARY​: AddressSanitizer​: heap-use-after-free ??​:0 __asan_memmove
Shadow bytes around the buggy address​:
  0x0c067fff9d80​: fd fd fa fa 00 00 00 00 fa fa fd fd fd fd fa fa
  0x0c067fff9d90​: 00 00 00 00 fa fa 00 00 00 00 fa fa fd fd fd fd
  0x0c067fff9da0​: fa fa fd fd fd fd fa fa 00 00 00 00 fa fa 00 00
  0x0c067fff9db0​: 00 00 fa fa 00 00 00 00 fa fa 00 00 00 fa fa fa
  0x0c067fff9dc0​: 00 00 00 00 fa fa 00 00 00 00 fa fa 00 00 00 05
=>0x0c067fff9dd0​: fa fa fd fd fd fd fa fa[fd]fd fd fa fa fa fd fd
  0x0c067fff9de0​: fd fd fa fa 00 00 01 fa fa fa 00 00 00 07 fa fa
  0x0c067fff9df0​: 00 00 04 fa fa fa 00 00 03 fa fa fa 00 00 00 02
  0x0c067fff9e00​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9e10​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9e20​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
Shadow byte legend (one shadow byte represents 8 application bytes)​:
  Addressable​: 00
  Partially addressable​: 01 02 03 04 05 06 07
  Heap left redzone​: fa
  Heap right redzone​: fb
  Freed heap region​: fd
  Stack left redzone​: f1
  Stack mid redzone​: f2
  Stack right redzone​: f3
  Stack partial redzone​: f4
  Stack after return​: f5
  Stack use after scope​: f8
  Global redzone​: f9
  Global init order​: f6
  Poisoned by user​: f7
  Container overflow​: fc
  ASan internal​: fe
==2379==ABORTING

[p5pRT]

From @tonycoz

Created by @tonycoz

The call to Perl_sv_catpvn_flags() from Perl_do_vop() can use memory
after it's been freed.

Encountered as crashes in warnings.pm as it updated the warnings
bitmap.

tony@​mars​:.../git/perl$ ./perl -Ilib -e '$x = "UUUUUUUUUU\325UUUUUU\0"; $y = "\0\0\0\0\0\0\0\0\0\0\200\0\0\0\0\0\0"; $x |= $y'

==1334==ERROR​: AddressSanitizer​: heap-use-after-free on address 0x60300000e3f1 at pc 0x8afbc5 bp 0x7ffe50e25e40 sp 0x7ffe50e25e38
READ of size 1 at 0x60300000e3f1 thread T0
  #0 0x8afbc4 in Perl_sv_catpvn_flags /home/tony/dev/perl/git/perl/sv.c​:5455
  #1 0xaa3983 in Perl_do_vop /home/tony/dev/perl/git/perl/doop.c​:1222
  #2 0x953fbd in Perl_pp_bit_or /home/tony/dev/perl/git/perl/pp.c​:2471
  #3 0x73cf00 in Perl_runops_debug /home/tony/dev/perl/git/perl/dump.c​:2249
  #4 0x4c129b in S_run_body /home/tony/dev/perl/git/perl/perl.c​:2538
  #5 0x4bf626 in perl_run /home/tony/dev/perl/git/perl/perl.c​:2461
  #6 0x41f9eb in main /home/tony/dev/perl/git/perl/perlmain.c​:123
  #7 0x7faefb2e7b44 in __libc_start_main (/lib/x86_64-linux-gnu/libc.so.6+0x21b44)
  #8 0x41f768 (/home/tony/dev/perl/git/perl/perl+0x41f768)

0x60300000e3f1 is located 17 bytes inside of 20-byte region [0x60300000e3e0,0x60300000e3f4)
freed by thread T0 here​:
  #0 0x7faefc4399f6 in __interceptor_realloc (/usr/lib/x86_64-linux-gnu/libasan.so.1+0x549f6)
  #1 0x740a25 in Perl_safesysrealloc /home/tony/dev/perl/git/perl/util.c​:274
  #2 0x84fa2b in Perl_sv_grow /home/tony/dev/perl/git/perl/sv.c​:1598
  #3 0x8af606 in Perl_sv_catpvn_flags /home/tony/dev/perl/git/perl/sv.c​:5452
  #4 0xaa3983 in Perl_do_vop /home/tony/dev/perl/git/perl/doop.c​:1222
  #5 0x953fbd in Perl_pp_bit_or /home/tony/dev/perl/git/perl/pp.c​:2471
  #6 0x73cf00 in Perl_runops_debug /home/tony/dev/perl/git/perl/dump.c​:2249
  #7 0x4c129b in S_run_body /home/tony/dev/perl/git/perl/perl.c​:2538
  #8 0x4bf626 in perl_run /home/tony/dev/perl/git/perl/perl.c​:2461
  #9 0x41f9eb in main /home/tony/dev/perl/git/perl/perlmain.c​:123
  #10 0x7faefb2e7b44 in __libc_start_main (/lib/x86_64-linux-gnu/libc.so.6+0x21b44)

previously allocated by thread T0 here​:
  #0 0x7faefc43973f in malloc (/usr/lib/x86_64-linux-gnu/libasan.so.1+0x5473f)
  #1 0x7407db in Perl_safesysmalloc /home/tony/dev/perl/git/perl/util.c​:153
  #2 0x84fa40 in Perl_sv_grow /home/tony/dev/perl/git/perl/sv.c​:1601
  #3 0x8a9a9b in S_sv_uncow /home/tony/dev/perl/git/perl/sv.c​:5210
  #4 0x8aa514 in Perl_sv_force_normal_flags /home/tony/dev/perl/git/perl/sv.c​:5250
  #5 0x8f1708 in Perl_sv_pvn_force_flags /home/tony/dev/perl/git/perl/sv.c​:9953
  #6 0xa9f08f in Perl_do_vop /home/tony/dev/perl/git/perl/doop.c​:1013
  #7 0x953fbd in Perl_pp_bit_or /home/tony/dev/perl/git/perl/pp.c​:2471
  #8 0x73cf00 in Perl_runops_debug /home/tony/dev/perl/git/perl/dump.c​:2249
  #9 0x4c129b in S_run_body /home/tony/dev/perl/git/perl/perl.c​:2538
  #10 0x4bf626 in perl_run /home/tony/dev/perl/git/perl/perl.c​:2461
  #11 0x41f9eb in main /home/tony/dev/perl/git/perl/perlmain.c​:123
  #12 0x7faefb2e7b44 in __libc_start_main (/lib/x86_64-linux-gnu/libc.so.6+0x21b44)

SUMMARY​: AddressSanitizer​: heap-use-after-free /home/tony/dev/perl/git/perl/sv.c​:5455 Perl_sv_catpvn_flags
Shadow bytes around the buggy address​:
  0x0c067fff9c20​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9c30​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9c40​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9c50​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
  0x0c067fff9c60​: fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa fa
=>0x0c067fff9c70​: fa fa fa fa fa fa 00 00 00 00 fa fa fd fd[fd]fa
  0x0c067fff9c80​: fa fa 00 00 00 00 fa fa 00 00 00 00 fa fa 00 00
  0x0c067fff9c90​: 03 fa fa fa fd fd fd fa fa fa 00 00 04 fa fa fa
  0x0c067fff9ca0​: fd fd fd fa fa fa fd fd fd fa fa fa fd fd fd fa
  0x0c067fff9cb0​: fa fa fd fd fd fd fa fa 00 00 00 01 fa fa 00 00
  0x0c067fff9cc0​: 00 fa fa fa 00 00 00 07 fa fa 00 00 01 fa fa fa
Shadow byte legend (one shadow byte represents 8 application bytes)​:
  Addressable​: 00
  Partially addressable​: 01 02 03 04 05 06 07
  Heap left redzone​: fa
  Heap right redzone​: fb
  Freed heap region​: fd
  Stack left redzone​: f1
  Stack mid redzone​: f2
  Stack right redzone​: f3
  Stack partial redzone​: f4
  Stack after return​: f5
  Stack use after scope​: f8
  Global redzone​: f9
  Global init order​: f6
  Poisoned by user​: f7
  Contiguous container OOB​:fc
  ASan internal​: fe
==1334==ABORTING

This seems to have been introduced by
7fdc4f5, since the pointers supplied
to sv_catpvn() are being invalidated by the SvGROW() on line 5452.

While this change introduce the problem, I'm not inclined to blame the
change, since the code seem involved seems very fragile to me​:
appending pv data from a supplied SV into the same SV.

I'm not sure of the correct fix here.

The simplest and least fragile is probably a mortal copy of the "left"
sv when it's the same as the target sv to avoid sv_catpvn_flags() from
modifying our "source" data.

Perl Info

Flags:
    category=core
    severity=high

Site configuration information for perl 5.25.7:

Configured by tony at Wed Nov  2 10:06:02 AEDT 2016.

Summary of my perl5 (revision 5 version 25 subversion 7) configuration:
  Derived from: fcd4e2f8c97d60e18fb7288412b1903388692000
  Platform:
    osname=linux
    osvers=3.16.0-4-amd64
    archname=x86_64-linux
    uname='linux mars 3.16.0-4-amd64 #1 smp debian 3.16.36-1+deb8u2 (2016-10-19) x86_64 gnulinux '
    config_args='-des -Dusedevel -Doptimize=-O0 -g -Accflags=-fsanitize=address -Alddlflags=-fsanitize=address -shared -Aldflags=-fsanitize=address -DDEBUGGING'
    hint=recommended
    useposix=true
    d_sigaction=define
    useithreads=undef
    usemultiplicity=undef
    use64bitint=define
    use64bitall=define
    uselongdouble=undef
    usemymalloc=n
    bincompat5005=undef
  Compiler:
    cc='cc'
    ccflags ='-fsanitize=address -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2'
    optimize='-O0 -g'
    cppflags='-fsanitize=address -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include'
    ccversion=''
    gccversion='4.9.2'
    gccosandvers=''
    intsize=4
    longsize=8
    ptrsize=8
    doublesize=8
    byteorder=12345678
    doublekind=3
    d_longlong=define
    longlongsize=8
    d_longdbl=define
    longdblsize=16
    longdblkind=3
    ivtype='long'
    ivsize=8
    nvtype='double'
    nvsize=8
    Off_t='off_t'
    lseeksize=8
    alignbytes=8
    prototype=define
  Linker and Libraries:
    ld='cc'
    ldflags =' -fsanitize=address -fstack-protector-strong -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/4.9/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib
    libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
    perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
    libc=libc-2.19.so
    so=so
    useshrplib=false
    libperl=libperl.a
    gnulibc_version='2.19'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs
    dlext=so
    d_dlsymun=undef
    ccdlflags='-Wl,-E'
    cccdlflags='-fPIC'
    lddlflags=' -fsanitize=address -shared -L/usr/local/lib -fstack-protector-strong'

Locally applied patches:
    uncommitted-changes


@INC for perl 5.25.7:
    lib
    /usr/local/lib/perl5/site_perl/5.25.7/x86_64-linux
    /usr/local/lib/perl5/site_perl/5.25.7
    /usr/local/lib/perl5/5.25.7/x86_64-linux
    /usr/local/lib/perl5/5.25.7


Environment for perl 5.25.7:
    HOME=/home/tony
    LANG=en_AU.UTF-8
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/tony/perl5/perlbrew/bin:/home/tony/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/games:/usr/games
    PERLBREW_BASHRC_VERSION=0.43
    PERLBREW_HOME=/home/tony/.perlbrew
    PERLBREW_MANPATH=
    PERLBREW_PATH=/home/tony/perl5/perlbrew/bin
    PERLBREW_ROOT=/home/tony/perl5/perlbrew
    PERLBREW_VERSION=0.67
    PERL_BADLANG (unset)
    SHELL=/bin/bash

[p5pRT]

From @cpansprout

On Tue Nov 01 21​:18​:01 2016, tonyc wrote​:

The call to Perl_sv_catpvn_flags() from Perl_do_vop() can use memory
after it's been freed.

the code seem involved seems very fragile to me​:
appending pv data from a supplied SV into the same SV.

I'm not sure of the correct fix here.

The simplest and least fragile is probably a mortal copy of the "left"
sv when it's the same as the target sv to avoid sv_catpvn_flags() from
modifying our "source" data.

Wouldn’t it be simpler to grow the scalar by the amount that is about to be appended before appending it (and, of course, update the pointer in between)?

--

Father Chrysostomos

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @tonycoz

On Wed Nov 02 15​:43​:05 2016, sprout wrote​:

On Tue Nov 01 21​:18​:01 2016, tonyc wrote​:

The call to Perl_sv_catpvn_flags() from Perl_do_vop() can use memory
after it's been freed.

the code seem involved seems very fragile to me​:
appending pv data from a supplied SV into the same SV.

I'm not sure of the correct fix here.

The simplest and least fragile is probably a mortal copy of the
"left"
sv when it's the same as the target sv to avoid sv_catpvn_flags()
from
modifying our "source" data.

Wouldn’t it be simpler to grow the scalar by the amount that is about
to be appended before appending it (and, of course, update the pointer
in between)?

My main problem is that it's fragile - it broke this time because 7fdc4f5
made the argument to SvGROW() a little larger.

It turns out there's a simple non-fragile fix, attached.

Tony

[p5pRT]

From @tonycoz

0001-perl-129997-avoid-sv_catpvn-in-do_vop-when-unneeded.patch

From e6cb268e1f28cb9bc8ce4c21c554fd155c13d90a Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 3 Nov 2016 16:07:35 +1100
Subject: (perl #129997) avoid sv_catpvn() in do_vop() when unneeded

---
 doop.c | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/doop.c b/doop.c
index 5525c47..bc23c9e 100644
--- a/doop.c
+++ b/doop.c
@@ -1218,8 +1218,17 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 	    len = lensave;
 	    if (rightlen > len)
 		sv_catpvn_nomg(sv, rsave + len, rightlen - len);
-	    else if (leftlen > (STRLEN)len)
-		sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+	    else if (leftlen > (STRLEN)len) {
+                if (sv == left) {
+                    /* sv_catpvn() might move the source from under us,
+                       and the data is already in place, just adjust to
+                       include it */
+                    SvCUR_set(sv, leftlen);
+                    *SvEND(sv) = '\0';
+                }
+                else
+                    sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+            }
 	    else
 		*SvEND(sv) = '\0';
 	    break;
-- 
2.1.4

[p5pRT]

From @tonycoz

On Tue, 01 Nov 2016 12​:39​:09 -0700, brian.carpenter@​gmail.com wrote​:

Triggered with Perl v5.25.7 (v5.25.6-134-g11327fa) and AFL+ASAN. Doesn't
fail with Valgrind and non-ASAN builds.

perl -e '$^X^=r'

As Brian pointed out in IRC, this is the same issue as 129997, so I've merged
them.

This *is* potentially a security issue, but it's only present in a development
release.

Fixed by dc529e6.

Tony

[p5pRT]

@tonycoz - Status changed from 'new' to 'pending release'

[p5pRT]

From @iabyn

On Wed, Nov 02, 2016 at 10​:11​:33PM -0700, Tony Cook via RT wrote​:

diff --git a/doop.c b/doop.c
index 5525c47..bc23c9e 100644
--- a/doop.c
+++ b/doop.c
@​@​ -1218,8 +1218,17 @​@​ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
len = lensave;
if (rightlen > len)
sv_catpvn_nomg(sv, rsave + len, rightlen - len);
- else if (leftlen > (STRLEN)len)
- sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ else if (leftlen > (STRLEN)len) {
+ if (sv == left) {
+ /* sv_catpvn() might move the source from under us,
+ and the data is already in place, just adjust to
+ include it */
+ SvCUR_set(sv, leftlen);
+ *SvEND(sv) = '\0';
+ }
+ else
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ }
else
*SvEND(sv) = '\0';
break;

Hi Tony, I didn't spot this while working on the same issue (I saw ASAN
failures rather than this ticket). I have a fix too, which is a bit
different, and (I speculate) is slightly more comprehensive.

I fixed up the rhs-longer branch in addition to the lhs-longer branch.
In practice, do_vop() doesn't currently get called by the test suite with
sv == right unless sv == left also, but that might change.

Secondly, rather than testing that sv == left etc, I checked whether the
buffer pointers matched, e.g. dc == lc. This is because in theory the SVs
could be the same, but the buffers could be different (e.g. an overloaded
string returning a temporary buffer), so a valid concat could be
incorrectly skipped. Again, I don't *think* that's possible with the
current code, but in principle someone could alter the earlier part of
do_vop() and break that assumption.

Do you have any opinion whether I should apply a reworked version of this
on top of your fix?

Inline Patch

diff --git a/doop.c b/doop.c
index 5525c47..1aea1ea 100644
--- a/doop.c
+++ b/doop.c
@@ -1216,12 +1216,19 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 		*dc++ = *lc++ | *rc++;
 	  mop_up:
 	    len = lensave;
-	    if (rightlen > len)
-		sv_catpvn_nomg(sv, rsave + len, rightlen - len);
-	    else if (leftlen > (STRLEN)len)
-		sv_catpvn_nomg(sv, lsave + len, leftlen - len);
-	    else
-		*SvEND(sv) = '\0';
+	    if (rightlen > len) {
+                if (dc == rc)
+                    SvCUR(sv) = rightlen;
+                else
+                    sv_catpvn_nomg(sv, rsave + len, rightlen - len);
+            }
+	    else if (leftlen > (STRLEN)len) {
+                if (dc == lc)
+                    SvCUR(sv) = leftlen;
+                else
+                    sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+            }
+            *SvEND(sv) = '\0';


-- 

More than any other time in history, mankind faces a crossroads. One path
leads to despair and utter hopelessness. The other, to total extinction.
Let us pray we have the wisdom to choose correctly.
  -- Woody Allen

[p5pRT]

From @demerphq

On 8 November 2016 at 10​:54, Dave Mitchell <davem@​iabyn.com> wrote​:

On Wed, Nov 02, 2016 at 10​:11​:33PM -0700, Tony Cook via RT wrote​:

diff --git a/doop.c b/doop.c
index 5525c47..bc23c9e 100644
--- a/doop.c
+++ b/doop.c
@​@​ -1218,8 +1218,17 @​@​ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
len = lensave;
if (rightlen > len)
sv_catpvn_nomg(sv, rsave + len, rightlen - len);
- else if (leftlen > (STRLEN)len)
- sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ else if (leftlen > (STRLEN)len) {
+ if (sv == left) {
+ /* sv_catpvn() might move the source from under us,
+ and the data is already in place, just adjust to
+ include it */
+ SvCUR_set(sv, leftlen);
+ *SvEND(sv) = '\0';
+ }
+ else
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ }
else
*SvEND(sv) = '\0';
break;

Hi Tony, I didn't spot this while working on the same issue (I saw ASAN
failures rather than this ticket). I have a fix too, which is a bit
different, and (I speculate) is slightly more comprehensive.

I fixed up the rhs-longer branch in addition to the lhs-longer branch.
In practice, do_vop() doesn't currently get called by the test suite with
sv == right unless sv == left also, but that might change.

Secondly, rather than testing that sv == left etc, I checked whether the
buffer pointers matched, e.g. dc == lc. This is because in theory the SVs
could be the same, but the buffers could be different (e.g. an overloaded
string returning a temporary buffer), so a valid concat could be
incorrectly skipped. Again, I don't *think* that's possible with the
current code, but in principle someone could alter the earlier part of
do_vop() and break that assumption.

Do you have any opinion whether I should apply a reworked version of this
on top of your fix?

diff --git a/doop.c b/doop.c
index 5525c47..1aea1ea 100644
--- a/doop.c
+++ b/doop.c
@​@​ -1216,12 +1216,19 @​@​ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
*dc++ = *lc++ | *rc++;
mop_up​:
len = lensave;
- if (rightlen > len)
- sv_catpvn_nomg(sv, rsave + len, rightlen - len);
- else if (leftlen > (STRLEN)len)
- sv_catpvn_nomg(sv, lsave + len, leftlen - len);
- else
- *SvEND(sv) = '\0';
+ if (rightlen > len) {
+ if (dc == rc)
+ SvCUR(sv) = rightlen;
+ else
+ sv_catpvn_nomg(sv, rsave + len, rightlen - len);
+ }
+ else if (leftlen > (STRLEN)len) {
+ if (dc == lc)
+ SvCUR(sv) = leftlen;
+ else
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ }
+ *SvEND(sv) = '\0';

Leaving aside the patch to doop.c it looks to me like sv_catpvn in
sv.c needs the following patch​:

@​@​ -5507,7 +5497,7 @​@​ void
Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const
STRLEN slen, const I32 flags)
{
  STRLEN dlen;
- const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
+ char * dstr = SvPV_force_flags(dsv, dlen, flags);

  PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
  assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
@​@​ -5517,7 +5507,8 @​@​ Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const
char *sstr, const STRLEN slen,
  sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
  dlen = SvCUR(dsv);
  }
- else SvGROW(dsv, dlen + slen + 3);
+ else dstr = SvGROW(dsv, dlen + slen + 3);
+
  if (sstr == dstr)
  sstr = SvPVX_const(dsv);
  Move(sstr, SvPVX(dsv) + dlen, slen, char);
--
perl -Mre=debug -e "/just|another|perl|hacker/"

[p5pRT]

From @tonycoz

On Tue, 08 Nov 2016 01​:54​:59 -0800, davem wrote​:

On Wed, Nov 02, 2016 at 10​:11​:33PM -0700, Tony Cook via RT wrote​:

diff --git a/doop.c b/doop.c
index 5525c47..bc23c9e 100644
--- a/doop.c
+++ b/doop.c
@​@​ -1218,8 +1218,17 @​@​ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV
*left, SV *right)
len = lensave;
if (rightlen > len)
sv_catpvn_nomg(sv, rsave + len, rightlen - len);
- else if (leftlen > (STRLEN)len)
- sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ else if (leftlen > (STRLEN)len) {
+ if (sv == left) {
+ /* sv_catpvn() might move the source from under
us,
+ and the data is already in place, just adjust
to
+ include it */
+ SvCUR_set(sv, leftlen);
+ *SvEND(sv) = '\0';
+ }
+ else
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
+ }
else
*SvEND(sv) = '\0';
break;

Hi Tony, I didn't spot this while working on the same issue (I saw
ASAN
failures rather than this ticket). I have a fix too, which is a bit
different, and (I speculate) is slightly more comprehensive.

I fixed up the rhs-longer branch in addition to the lhs-longer branch.
In practice, do_vop() doesn't currently get called by the test suite
with
sv == right unless sv == left also, but that might change.

Secondly, rather than testing that sv == left etc, I checked whether
the
buffer pointers matched, e.g. dc == lc. This is because in theory the
SVs
could be the same, but the buffers could be different (e.g. an
overloaded
string returning a temporary buffer), so a valid concat could be
incorrectly skipped. Again, I don't *think* that's possible with the
current code, but in principle someone could alter the earlier part of
do_vop() and break that assumption.

It won't do any harm, though as you say it can't happen with the current
code (any overloading is removed from sv by the SvPV_force_*() calls.)

I don't think Perl_do_vop() can currently be called with sv == right,
even if the test suite is modified (we'd need to add an optimization to
make $x = $y | $x skip the aassign and work directly, which seems an
unlikely optimization to bother with.)

Do you have any opinion whether I should apply a reworked version of
this
on top of your fix?

It won't do any harm.

Tony

[p5pRT]

From @tonycoz

On Tue, 08 Nov 2016 02​:17​:28 -0800, demerphq wrote​:

Leaving aside the patch to doop.c it looks to me like sv_catpvn in
sv.c needs the following patch​:

@​@​ -5507,7 +5497,7 @​@​ void
Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const
STRLEN slen, const I32 flags)
{
STRLEN dlen;
- const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
+ char * dstr = SvPV_force_flags(dsv, dlen, flags);

PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
assert((flags & (SV_CATBYTES|SV_CATUTF8)) !=
(SV_CATBYTES|SV_CATUTF8));
@​@​ -5517,7 +5507,8 @​@​ Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const
char *sstr, const STRLEN slen,
sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
dlen = SvCUR(dsv);
}
- else SvGROW(dsv, dlen + slen + 3);
+ else dstr = SvGROW(dsv, dlen + slen + 3);
+
if (sstr == dstr)
sstr = SvPVX_const(dsv);
Move(sstr, SvPVX(dsv) + dlen, slen, char);

That would break the check done on the next line, which appears to be
ensuring something like​:

  STRLEN len;
  s = SvPV(sv, len);
  sv_catpvn(sv, s, len);

adjusts sstr to point at the new buffer for sv if that moves.

This could have been extended to fix this particular problem, instead of​:

  if (sstr == dstr)
  sstr = SvPVX_const(dsv);

something like​:

  if (sstr >= dstr && sstr + slen <= dstr + SvLEN(sv))
  sstr = SvPVX_const(dsv) + (sstr - dstr);

Tony

[p5pRT]

From @iabyn

On Tue, Nov 08, 2016 at 04​:36​:46PM -0800, Tony Cook via RT wrote​:

I don't think Perl_do_vop() can currently be called with sv == right,
even if the test suite is modified (we'd need to add an optimization to
make $x = $y | $x skip the aassign and work directly, which seems an
unlikely optimization to bother with.)

Some of the bitwise tests under t/lib/warnings do​: IIRC its ones testing
the new '|.' etc bitwise ops. I put in an assert and some of those failed.
But only where sv == left too.

--
It's not that I'm afraid to die, I just don't want to be there when it
happens.
  -- Woody Allen

[p5pRT]

From @iabyn

On Tue, Nov 08, 2016 at 09​:54​:25AM +0000, Dave Mitchell wrote​:

Do you have any opinion whether I should apply a reworked version of this
on top of your fix?

I've now applied it as v5.25.6-185-g392582f

--
Indomitable in retreat, invincible in advance, insufferable in victory
  -- Churchill on Montgomery

[p5pRT]

From @khwilliamson

Thank you for filing this report. You have helped make Perl better.

With the release today of Perl 5.26.0, this and 210 other issues have been
resolved.

Perl 5.26.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.26.0

If you find that the problem persists, feel free to reopen this ticket.