unpack leads to segmentation fault

[p5pRT]

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

Searchable as RT73814$

[p5pRT]

From mmaslano@redhat.com

Created by mmaslano@redhat.com

From the original report by Richard W.M. Jones
https://bugzilla.redhat.com/show_bug.cgi?id=576824

Description of problem​:

$ perl -e 'use bytes;
print join(",",split(/../,unpack("%02H*","hello world")))'
Segmentation fault

Version-Release number of selected component (if applicable)​:

perl-5.10.1-117.fc14.x86_64

How reproducible​:

Always.

Steps to Reproduce​:
1. Run the above command.

Actual results​:

Core dump.

Stack trace​:

Program received signal SIGSEGV, Segmentation fault.
0x00007ffff7d56670 in Perl_pp_split (my_perl=0x602010) at pp.c​:4619
4619 rx = PM_GETRE(pm);
(gdb) bt
#0 0x00007ffff7d56670 in Perl_pp_split (my_perl=0x602010) at pp.c​:4619
#1 0x00007ffff7d36656 in Perl_runops_standard (my_perl=0x602010) at run.c​:40
#2 0x00007ffff7cdf088 in S_run_body (oldscope=<value optimized out>,
  my_perl=<value optimized out>) at perl.c​:2431
#3 perl_run (oldscope=<value optimized out>, my_perl=<value optimized out>)
  at perl.c​:2349
#4 0x0000000000400c5c in main (argc=3, argv=0x7fffffffe448,
  env=0x7fffffffe468) at perlmain.c​:117
The segmentation faul could be also reproduced on​:
perl -e 'print split(/../,unpack("%02H*","hello world"))'

I've reproduced this bug also with perl-5.11.4.

Perl Info

Flags:
    category=library
    severity=low
    module=base

This perlbug was built using Perl 5.10.1 in the Fedora build system.
It is being executed now by Perl 5.10.1 - Sun Mar  7 06:02:09 UTC 2010.

Site configuration information for perl 5.10.1:

Configured by Red Hat, Inc. at Sun Mar  7 06:02:09 UTC 2010.

Summary of my perl5 (revision 5 version 10 subversion 1) configuration:

  Platform:
    osname=linux, osvers=2.6.18-164.6.1.el5, archname=x86_64-linux-thread-multi
    uname='linux x86-02.phx2.fedoraproject.org 2.6.18-164.6.1.el5 #1 smp tue oct 27 11:28:30 edt 2009 x86_64 x86_64 x86_64 gnulinux '
    config_args='-des -Doptimize=-O2 -g -pipe -Wall -Wp,-D_FORTIFY_SOURCE=2 -fexceptions -fstack-protector --param=ssp-buffer-size=4 -m64 -mtune=generic -DDEBUGGING=-g -Accflags=-DPERL_USE_SAFE_PUTENV -Dversion=5.10.1 -Dmyhostname=localhost -Dperladmin=root@localhost -Dcc=gcc -Dcf_by=Red Hat, Inc. -Dprefix=/usr -Dvendorprefix=/usr -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl5 -Dsitearch=/usr/local/lib64/perl5 -Dprivlib=/usr/share/perl5 -Dvendorlib=/usr/share/perl5 -Darchlib=/usr/lib64/perl5 -Dvendorarch=/usr/lib64/perl5 -Dinc_version_list=5.10.0 -Darchname=x86_64-linux-thread-multi -Dlibpth=/usr/local/lib64 /lib64 /usr/lib64 -Duseshrplib -Dusethreads -Duseithreads -Duselargefiles -Dd_dosuid -Dd_semctl_semun -Di_db -Ui_ndbm -Di_gdbm -Di_shadow -Di_syslog -Dman3ext=3pm -Duseperlio -Dinstallusrbinperl=n -Ubincompat5005 -Uversiononly -Dpager=/usr/bin/less -isr -Dd_gethostent_r_proto -Ud_endhostent_r_proto -Ud_sethostent_r_proto -Ud_endprotoent_r_proto -Ud_setprotoent_r_proto -Ud_endservent_r_proto -Ud_setservent_r_proto -Dscriptdir=/usr/bin -Dotherlibdirs=/usr/local/lib64/perl5/site_perl/5.10.0/x86_64-linux-thread-multi:/usr/local/lib/perl5/site_perl/5.10.0:/usr/lib64/perl5/vendor_perl/5.10.0/x86_64-linux-thread-multi:/usr/lib/perl5/vendor_perl:/usr/lib/perl5/site_perl'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='gcc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DPERL_USE_SAFE_PUTENV -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2 -g -pipe -Wall -Wp,-D_FORTIFY_SOURCE=2 -fexceptions -fstack-protector --param=ssp-buffer-size=4 -m64 -mtune=generic',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DPERL_USE_SAFE_PUTENV -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
    ccversion='', gccversion='4.4.3 20100211 (Red Hat 4.4.3-6)', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
    ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='gcc', ldflags =' -fstack-protector'
    libpth=/usr/local/lib64 /lib64 /usr/lib64
    libs=-lresolv -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc
    perllibs=-lresolv -lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
    libc=, so=so, useshrplib=true, libperl=libperl.so
    gnulibc_version='2.11.90'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-rpath,/usr/lib64/perl5/CORE'
    cccdlflags='-fPIC', lddlflags='-shared -O2 -g -pipe -Wall -Wp,-D_FORTIFY_SOURCE=2 -fexceptions -fstack-protector --param=ssp-buffer-size=4 -m64 -mtune=generic'

Locally applied patches:



@INC for perl 5.10.1:
    /usr/local/lib64/perl5
    /usr/local/share/perl5
    /usr/local/share/perl5
    /usr/lib64/perl5
    /usr/share/perl5
    /usr/share/perl5
    /usr/lib64/perl5
    /usr/share/perl5
    /usr/local/lib64/perl5/site_perl/5.10.0/x86_64-linux-thread-multi
    /usr/local/lib/perl5/site_perl/5.10.0
    /usr/lib64/perl5/vendor_perl/5.10.0/x86_64-linux-thread-multi
    /usr/lib/perl5/vendor_perl/5.10.0
    /usr/lib/perl5/vendor_perl
    /usr/lib/perl5/site_perl
    .


Environment for perl 5.10.1:
    HOME=/home/marca
    LANG=en_US.UTF-8
    LANGUAGE=
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/usr/lib64/ccache:/usr/lib64/qt-3.3/bin:/usr/kerberos/sbin:/usr/kerberos/bin:/usr/lib64/ccache:/usr/local/bin:/usr/bin:/bin:/usr/games:/usr/local/sbin:/usr/sbin:/sbin:/home/marca/bin
    PERL_BADLANG (unset)
    SHELL=/bin/bash

[p5pRT]

From @rgarcia

On 25 March 2010 14​:17, Marcela Maslanova <perlbug-followup@​perl.org> wrote​:

Description of problem​:

$ perl -e 'use bytes;
print join(",",split(/../,unpack("%02H*","hello world")))'
Segmentation fault

Shorter test case :

$ ./perl -e 'split/a/,unpack("%02H*","a")'
Segmentation fault

Looks like split has difficulties with its argument list there, which
boils down apparently to unpack returning too many values :

$ perl -le 'print for scalar unpack("%02H*","a")'
61
0

[p5pRT]

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

[p5pRT]

From @tonycoz

On Fri, Mar 26, 2010 at 10​:57​:27AM +0100, Rafael Garcia-Suarez wrote​:

On 25 March 2010 14​:17, Marcela Maslanova <perlbug-followup@​perl.org> wrote​:

Description of problem​:

$ perl -e 'use bytes;
print join(",",split(/../,unpack("%02H*","hello world")))'
Segmentation fault

Shorter test case :

$ ./perl -e 'split/a/,unpack("%02H*","a")'
Segmentation fault

Looks like split has difficulties with its argument list there, which
boils down apparently to unpack returning too many values :

$ perl -le 'print for scalar unpack("%02H*","a")'
61
0

The H and u formats were returning the unpack()ed text as well as the
checksum.

Patch with tests attached.

Tony

[p5pRT]

From @tonycoz

0001-RT-73814-unpack-didn-t-handle-scalar-context-cor.patch

From aee0279a5d6c3c12063e2c5488b35e88ccd13c54 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Fri, 23 Apr 2010 19:28:35 +1000
Subject: [PATCH] RT#73814 - unpack() didn't handle scalar context correctly for %32H and %32u

split() would crash because the third item on the stack wasn't the
regular expression it expected.  unpack("%2H", ...) would return both
the unpacked result and the checksum on the stack, similarly for
unpack("%2u", ...).
---
 pp_pack.c   |   33 +++++++++++++++++++++------------
 t/op/pack.t |   10 +++++++++-
 2 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/pp_pack.c b/pp_pack.c
index 0670548..0ae8afd 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -1562,9 +1562,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 	    /* Preliminary length estimate, acceptable for utf8 too */
 	    if (howlen == e_star || len > (strend - s) * 2)
 		len = (strend - s) * 2;
-	    sv = sv_2mortal(newSV(len ? len : 1));
-	    SvPOK_on(sv);
-	    str = SvPVX(sv);
+	    if (!checksum) {
+		sv = sv_2mortal(newSV(len ? len : 1));
+		SvPOK_on(sv);
+		str = SvPVX(sv);
+	    }
 	    if (datumtype == 'h') {
 		U8 bits = 0;
 		I32 ai32 = len;
@@ -1574,7 +1576,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			if (s >= strend) break;
 			bits = uni_to_byte(aTHX_ &s, strend, datumtype);
 		    } else bits = * (U8 *) s++;
-		    *str++ = PL_hexdigit[bits & 15];
+		    if (!checksum)
+			*str++ = PL_hexdigit[bits & 15];
 		}
 	    } else {
 		U8 bits = 0;
@@ -1585,12 +1588,15 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			if (s >= strend) break;
 			bits = uni_to_byte(aTHX_ &s, strend, datumtype);
 		    } else bits = *(U8 *) s++;
-		    *str++ = PL_hexdigit[(bits >> 4) & 15];
+		    if (!checksum)
+			*str++ = PL_hexdigit[(bits >> 4) & 15];
 		}
 	    }
-	    *str = '\0';
-	    SvCUR_set(sv, str - SvPVX_const(sv));
-	    XPUSHs(sv);
+	    if (!checksum) {
+		*str = '\0';
+		SvCUR_set(sv, str - SvPVX_const(sv));
+		XPUSHs(sv);
+	    }
 	    break;
 	}
 	case 'C':
@@ -2123,7 +2129,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 	    break;
 #endif
 	case 'u':
-	    {
+	    if (!checksum) {
                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
 		sv = sv_2mortal(newSV(l));
 		if (l) SvPOK_on(sv);
@@ -2141,7 +2147,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			hunk[0] = (char)((a << 2) | (b >> 4));
 			hunk[1] = (char)((b << 4) | (c >> 2));
 			hunk[2] = (char)((c << 6) | d);
-			sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+			if (!checksum)
+			    sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
 			len -= 3;
 		    }
 		    if (s < strend) {
@@ -2182,7 +2189,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			hunk[0] = (char)((a << 2) | (b >> 4));
 			hunk[1] = (char)((b << 4) | (c >> 2));
 			hunk[2] = (char)((c << 6) | d);
-			sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+			if (!checksum)
+			    sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
 			len -= 3;
 		    }
 		    if (*s == '\n')
@@ -2192,7 +2200,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c
 			    s += 2;
 		}
 	    }
-	    XPUSHs(sv);
+	    if (!checksum)
+		XPUSHs(sv);
 	    break;
 	}
 
diff --git a/t/op/pack.t b/t/op/pack.t
index 4b5f9a5..5775caf 100644
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -12,7 +12,7 @@ my $no_endianness = $] > 5.009 ? '' :
 my $no_signedness = $] > 5.009 ? '' :
   "Signed/unsigned pack modifiers not available on this perl";
 
-plan tests => 14697;
+plan tests => 14699;
 
 use strict;
 use warnings qw(FATAL all);
@@ -1985,3 +1985,11 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
     my ($v) = split //, unpack ('(B)*', 'ab');
     is($v, 0); # Doesn't SEGV :-)
 }
+{
+    #73814
+    my $x = runperl( prog => 'print split( /,/, unpack(q(%2H*), q(hello world))), qq(\n)' );
+    is($x, "0\n", "split /a/, unpack('%2H*'...) didn't crash");
+
+    my $y = runperl( prog => 'print split( /,/, unpack(q(%32u*), q(#,3,Q)), qq(\n)), qq(\n)' );
+    is($y, "0\n", "split /a/, unpack('%32u*'...) didn't crash");
+}
-- 
1.5.6.5

[p5pRT]

@rgs - Status changed from 'open' to 'resolved'

[p5pRT]

From @rgarcia

On 23 April 2010 11​:56, Tony Cook <tony@​develop-help.com> wrote​:

The H and u formats were returning the unpack()ed text as well as the
checksum.

Patch with tests attached.

Thanks, applied to bleadperl as 858fe5e.