develooper Front page | perl.perl5.porters | Postings from August 2016

[perl #129069] Fuzzer-detected use-after-free in Perl_yylex

Thread Previous | Thread Next
From:
Dan Collins
Date:
August 24, 2016 17:48
Subject:
[perl #129069] Fuzzer-detected use-after-free in Perl_yylex
Message ID:
rt-4.0.24-5741-1472060900-75.129069-75-0@perl.org
# New Ticket Created by  Dan Collins 
# Please include the string:  [perl #129069]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org/Ticket/Display.html?id=129069 >


First, the two testcases: 
Testcase 1: perl -e 'print "do\0"."000000"' | valgrind perl
Testcase 2: perl -e 'print "00my sub\0"' | valgrind perl

Detected using AFL with libdislocator, but reproducible using valgrind. The first one:

==56912== Invalid read of size 1
==56912==    at 0x5D62C8: Perl_yylex (toke.c:4880)
==56912==    by 0x660E34: Perl_yyparse (perly.c:334)
==56912==    by 0x530344: S_parse_body (perl.c:2373)
==56912==    by 0x537586: perl_parse (perl.c:1689)
==56912==    by 0x4297B7: main (perlmain.c:121)
==56912==  Address 0x61b28f3 is 3 bytes inside a block of size 10 free'd
==56912==    at 0x4C2AB5C: realloc (vg_replace_malloc.c:785)
==56912==    by 0x7F6D24: Perl_safesysrealloc (util.c:274)
==56912==    by 0x99605E: Perl_sv_grow (sv.c:1602)
==56912==    by 0xA29845: Perl_sv_gets (sv.c:8528)
==56912==    by 0x5A433B: Perl_lex_next_chunk (toke.c:1309)
==56912==    by 0x5A62BD: Perl_lex_read_space (toke.c:1529)
==56912==    by 0x5A6BB1: S_skipspace_flags (toke.c:1831)
==56912==    by 0x6333E1: Perl_yylex (toke.c:7512)
==56912==    by 0x660E34: Perl_yyparse (perly.c:334)
==56912==    by 0x530344: S_parse_body (perl.c:2373)
==56912==    by 0x537586: perl_parse (perl.c:1689)
==56912==    by 0x4297B7: main (perlmain.c:121)
==56912==  Block was alloc'd at
==56912==    at 0x4C28C0F: malloc (vg_replace_malloc.c:299)
==56912==    by 0x7EF59C: Perl_safesysmalloc (util.c:153)
==56912==    by 0x99646F: Perl_sv_grow (sv.c:1605)
==56912==    by 0x9CB173: Perl_sv_setpvn (sv.c:4898)
==56912==    by 0x9D96D7: Perl_newSVpvn (sv.c:9240)
==56912==    by 0x590F96: Perl_lex_start (toke.c:741)
==56912==    by 0x5301D1: S_parse_body (perl.c:2362)
==56912==    by 0x537586: perl_parse (perl.c:1689)
==56912==    by 0x4297B7: main (perlmain.c:121)

The second is just a write instead of a read:

==60617== Invalid write of size 1
==60617==    at 0x4BF89F: Perl_yylex (toke.c:8323)
==60617==    by 0x4D315B: Perl_yyparse (perly.c:334)
==60617==    by 0x461DD0: S_parse_body (perl.c:2373)
==60617==    by 0x4602AF: perl_parse (perl.c:1689)
==60617==    by 0x41EEB5: main (perlmain.c:121)
==60617==  Address 0x61b2748 is 8 bytes inside a block of size 10 free'd
==60617==    at 0x4C2AB5C: realloc (vg_replace_malloc.c:785)
==60617==    by 0x55A60A: Perl_safesysrealloc (util.c:274)
==60617==    by 0x5C602A: Perl_sv_grow (sv.c:1602)
==60617==    by 0x5FABD8: Perl_sv_gets (sv.c:8528)
==60617==    by 0x4A3EB9: S_filter_gets (toke.c:4347)
==60617==    by 0x4947A5: Perl_lex_next_chunk (toke.c:1309)
==60617==    by 0x49525A: Perl_lex_read_space (toke.c:1529)
==60617==    by 0x496BC1: S_skipspace_flags (toke.c:1831)
==60617==    by 0x4BF47A: Perl_yylex (toke.c:8289)
==60617==    by 0x4D315B: Perl_yyparse (perly.c:334)
==60617==    by 0x461DD0: S_parse_body (perl.c:2373)
==60617==    by 0x4602AF: perl_parse (perl.c:1689)
==60617==  Block was alloc'd at
==60617==    at 0x4C28C0F: malloc (vg_replace_malloc.c:299)
==60617==    by 0x55A4DC: Perl_safesysmalloc (util.c:153)
==60617==    by 0x5C6045: Perl_sv_grow (sv.c:1605)
==60617==    by 0x5E5B82: Perl_sv_setpvn (sv.c:4898)
==60617==    by 0x6007A9: Perl_newSVpvn (sv.c:9240)
==60617==    by 0x491BD3: Perl_lex_start (toke.c:741)
==60617==    by 0x461D76: S_parse_body (perl.c:2362)
==60617==    by 0x4602AF: perl_parse (perl.c:1689)
==60617==    by 0x41EEB5: main (perlmain.c:121)

The buffer in question is allocated by Perl_lex_start (in the else case of this conditional:

    if (line) {
        STRLEN len;
        s = SvPV_const(line, len);
        parser->linestr = flags & LEX_START_COPIED
                            ? SvREFCNT_inc_simple_NN(line)
                            : newSVpvn_flags(s, len, SvUTF8(line));
        if (!rsfp)
            sv_catpvs(parser->linestr, "\n;");
    } else {
        parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2); <<----toke.c:741
    }

It is then reallocated in a grow here:

    if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
     && !keyword(PL_tokenbuf + 1, len, 0)) {
        d = skipspace(d); <<----toke.c:7512
        if (*d == '(') {
            force_ident_maybe_lex('&');
            s = d;
        }

In the first case, we then hit this code:

    retry:
        switch (*s) { <<----toke.c:4880
        default:

In the second testcase, the error happens here:

    else {
        if (key == KEY_my || key == KEY_our || key==KEY_state)
        {
            *d = '\0'; <<----toke.c:8323
            /* diag_listed_as: Missing name in "%s sub" */
            Perl_croak(aTHX_
                      "Missing name in \"%s\"", PL_bufptr);
        }

When stepping through with libdislocator, which forces the realloc to return a new memory segment, I see the following change in Perl_sv_grow:

(gdb)
1602                s = (char*)saferealloc(s, newlen);
(gdb)
1610            SvPV_set(sv, s);
(gdb) p s
$4 = 0x7ffff63a1fe8 "do"
(gdb) p *sv
$5 = {sv_any = 0x7ffff7fe2410, sv_refcnt = 1, sv_flags = 17411, sv_u = {
    svu_pv = 0x7ffff63acff6 "do", svu_iv = 140737324437494,
    svu_uv = 140737324437494, svu_rv = 0x7ffff63acff6,
    svu_rx = 0x7ffff63acff6, svu_array = 0x7ffff63acff6,
    svu_hash = 0x7ffff63acff6, svu_gp = 0x7ffff63acff6,
    svu_fp = 0x7ffff63acff6}}
(gdb) n
1617            SvLEN_set(sv, newlen);
(gdb) p *sv
$6 = {sv_any = 0x7ffff7fe2410, sv_refcnt = 1, sv_flags = 17411, sv_u = {
    svu_pv = 0x7ffff63a1fe8 "do", svu_iv = 140737324392424,
    svu_uv = 140737324392424, svu_rv = 0x7ffff63a1fe8,
    svu_rx = 0x7ffff63a1fe8, svu_array = 0x7ffff63a1fe8,
    svu_hash = 0x7ffff63a1fe8, svu_gp = 0x7ffff63a1fe8,
    svu_fp = 0x7ffff63a1fe8}}

(that is, ~cff6 is the old address, and ~1fe8 is the new address)

Stepping out, I get:

(gdb) n
Perl_lex_next_chunk (flags=2) at toke.c:1312
1312        } else if (flags & LEX_NO_TERM) {
(gdb) info locals
linestr = 0x7ffff6606a48
buf = 0x7ffff63acff6 "do" <<---- I hope we never use this, because it's invalid now
old_bufend_pos = 9
new_bufend_pos = 4294967296
bufptr_pos = 9
oldbufptr_pos = 0
oldoldbufptr_pos = 0
linestart_pos = 0
last_uni_pos = 0
last_lop_pos = 0
got_some_for_debugger = false
got_some = false
__PRETTY_FUNCTION__ = "Perl_lex_next_chunk"
...

1338        buf = SvPVX(linestr);
(gdb) n
1339        new_bufend_pos = SvCUR(linestr);
(gdb) p buf
$8 = 0x7ffff63a1fe8 "do" <<---- Good, we don't

Perl_lex_read_space (flags=2) at toke.c:1530
1530                CopLINE_set(PL_curcop, l);
(gdb) info locals
got_more = true
l = 1
c = 0 '\000'
s = 0x7ffff63acfff "" <<---- 
bufend = 0x7ffff63acfff "" <<---- These are both offset from the bad pointer (s[9], currently)
can_incline = true
need_incline = false
...
(gdb) n
1531                s = PL_parser->bufptr;
(gdb) n
1532                bufend = PL_parser->bufend;
(gdb) n
1533                if (!got_more)
(gdb) p s
$9 = 0x7ffff63a1ff1 ";" <<----
(gdb) p bufend
$10 = 0x7ffff63a1ff2 "" <<---- Ok, this function is safe
...

S_skipspace_flags (s=0x7ffff63acfff "", flags=0) at toke.c:1834
1834            s = PL_bufptr;
(gdb) p s
$11 = 0x7ffff63acfff "" 
(gdb) n
1835            PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
(gdb) p s
$12 = 0x7ffff63a1ff1 ";" <<---- Ok, safe here too...

(gdb) info locals
lex = false
tmp = 44
off = 0
anydelim = false
sv = 0x0
cv = 0x0
rv2cv_op = 0x0
s = 0x7ffff63acff9 "000000" <<---- offset s[3] from the bad pointer
d = 0x7ffff63a1ff1 ";" <<---- As a reminder, we just called d = skipspace(d)...safe
len = 6
bof = true
saw_infix_sigil = false
formbrack = 0 '\000'
fake_eof = 0
orig_keyword = 0
gv = 0x0
gvp = 0x0
__PRETTY_FUNCTION__ = "Perl_yylex"

More ideas to follow, perhaps.


-- 
Respectfully,
Dan Collins


Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About