In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/281fe5e7055b0d2374f99ba00af0e45f22386854?hp=95d8e32b92e4e78f0c172dd82ff70a8a96bb1451>
- Log ----------------------------------------------------------------- commit 281fe5e7055b0d2374f99ba00af0e45f22386854 Merge: 7e337d2de5 67dd6f35b0 Author: David Mitchell <[email protected]> Date: Fri Mar 17 14:13:57 2017 +0000 [MERGE] fix vec() offset overflow issues commit 67dd6f35b05c5d28609af9237e6f509a8bb91383 Author: David Mitchell <[email protected]> Date: Thu Mar 16 12:29:03 2017 +0000 fix integer overflows in Perl_do_vecget()/set RT #130915 In something like vec($str, $bignum, 16) (i.e. where $str is treated as a series of 16-bit words), Perl_do_vecget() and Perl_do_vecset() end up doing calculations equivalent to: $start = $bignum*2; $end = $start + 2; Currently both these calculations can wrap if $bignum is near the maximum value of a STRLEN (the previous commit already fixed cases for $bignum > max(STRLEN)). So this commit makes them check for potential overflow before doing such calculations. It also takes account of the fact that the previous commit changed the type of offset from signed to unsigned. Finally, it also adds some tests to t/op/vec.t for where the 'word' overlaps the end of the string, for example $x = vec("ab", 0, 64) should behave the same as: $x = vec("ab\0\0\0\0\0\0", 0, 64) This uses a separate code path, and I couldn't see any tests for it. This commit is based on an earlier proposed fix by Aaron Crane. M doop.c M t/op/vec.t commit d69c43040e4967294b1195ecfdc4acf0f74b5958 Author: David Mitchell <[email protected]> Date: Wed Mar 15 14:35:59 2017 +0000 Perl_do_vecget(): change offset arg to STRLEN type ... and fix up its caller, pp_vec(). This is part of a fix for RT #130915. pp_vec() is responsible for extracting out the offset and size from SVs on the stack, and then calling do_vecget() with those values. (Sometimes the call is done indirectly by storing the offset in the LvTARGOFF() field of a SVt_PVLV, then later Perl_magic_getvec() passes the LvTARGOFF() value to do_vecget().) Now SvCUR, SvLEN and LvTARGOFF are all of type STRLEN (a.k.a Size_t), while the offset arg of do_vecget() is of type SSize_t (i.e. there's a signed/unsigned mismatch). It makes more sense to make the arg of type STRLEN. So that is what this commit does. At the same time this commit fixes up pp_vec() to handle all the possibilities where the offset value can't fit into a STRLEN, returning 0 or croaking accordingly, so that do_vecget() is never called with a truncated or wrapped offset. The next commit will fix up the internals of do_vecget() and do_vecset(), which have to worry about offset*(2^n) wrapping or being > SvCUR(). This commit is based on an earlier proposed fix by Aaron Crane. M doop.c M embed.fnc M pp.c M proto.h M t/op/vec.t commit 7e337d2de5bfdccdeeb8d3f2f24f559ff905770a Merge: 511e4ff70e 521aa9ac9d Author: David Mitchell <[email protected]> Date: Fri Mar 17 14:10:59 2017 +0000 [MERGE] fix -DPERL_GLOBAL_STRUCT_PRIVATE builds With no automatic smoking, this build option has suffered some bitrot over the last few months. commit 521aa9ac9d163b537d772e3e0de4add0df35ca80 Author: David Mitchell <[email protected]> Date: Fri Mar 17 13:51:46 2017 +0000 PERL_GLOBAL_STRUCT_PRIVATE: dump.c:op_class_names t/porting/libperl.t under -DPERL_GLOBAL_STRUCT_PRIVATE doesn't like non-const static data structures M dump.c commit 8c0364339f063fa32be742877e8206c8b6203de0 Author: David Mitchell <[email protected]> Date: Fri Mar 17 13:40:03 2017 +0000 PERL_GLOBAL_STRUCT_PRIVATE: fix scope.c:arg_counts t/porting/libperl.t under -DPERL_GLOBAL_STRUCT_PRIVATE doesn't like non-const static data structures M scope.c commit 7bfe3bfdd4427cdc26a2581cc633e3fb5582ce70 Author: David Mitchell <[email protected]> Date: Fri Mar 17 13:15:13 2017 +0000 PERL_GLOBAL_STRUCT_PRIVATE: fix PL_isa_DOES I added the global string constant PL_isa_DOES recently. This caused t/porting/libperl.t to fail under -DPERL_GLOBAL_STRUCT_PRIVATE builds. This commit makes PL_isa_DOES be declared and defined in a similar way to other such global constants. This is pure cargo-culting - I have no real idea of the point of all the EXTCONST, INIT and globvar.sym stuff. M globvar.sym M perl.h M pp_hot.c M universal.c commit a5555695d6543e0b1a47bec20245db4878556a6d Author: David Mitchell <[email protected]> Date: Fri Mar 17 12:19:44 2017 +0000 t/porting/libperl.t: add better dianostics For -DPERL_GLOBAL_STRUCT_PRIVATE builds, it checks that there aren't any global symbols. Make it display the symbols if it finds any. It already does so for bss; this commit adds data and common diag()s. M t/porting/libperl.t commit 511e4ff70ef6e05671303d4eb487d4d5690dd80a Author: David Mitchell <[email protected]> Date: Fri Mar 17 09:57:39 2017 +0000 locale.c: fix compiler warning (this is debugging-only code) It was trying to printf a U32 using %u M locale.c ----------------------------------------------------------------------- Summary of changes: doop.c | 80 ++++++++++++++++++++++++++--------------------- dump.c | 2 +- embed.fnc | 2 +- globvar.sym | 1 + locale.c | 4 +-- perl.h | 6 ++++ pp.c | 40 ++++++++++++++++++++++-- pp_hot.c | 2 -- proto.h | 2 +- scope.c | 2 +- t/op/vec.t | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++- t/porting/libperl.t | 15 +++++++-- universal.c | 7 +---- 13 files changed, 199 insertions(+), 54 deletions(-) diff --git a/doop.c b/doop.c index b5c10039b6..7674af5993 100644 --- a/doop.c +++ b/doop.c @@ -744,9 +744,9 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) /* currently converts input to bytes if possible, but doesn't sweat failure */ UV -Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) +Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) { - STRLEN srclen, len, uoffset, bitoffs = 0; + STRLEN srclen, len, avail, uoffset, bitoffs = 0; const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET) ? SV_UNDEF_RETURNS_NULL : 0); unsigned char *s = (unsigned char *) @@ -759,8 +759,6 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) PERL_ARGS_ASSERT_DO_VECGET; - if (offset < 0) - return 0; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); @@ -774,29 +772,37 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) bitoffs = ((offset%8)*size)%8; uoffset = offset/(8/size); } - else if (size > 8) - uoffset = offset*(size/8); + else if (size > 8) { + int n = size/8; + if (offset > Size_t_MAX / n - 1) /* would overflow */ + return 0; + uoffset = offset*n; + } else uoffset = offset; - len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */ - if (len > srclen) { + if (uoffset >= srclen) + return 0; + + len = (bitoffs + size + 7)/8; /* required number of bytes */ + avail = srclen - uoffset; /* available number of bytes */ + + /* Does the byte range overlap the end of the string? If so, + * handle specially. */ + if (avail < len) { if (size <= 8) retnum = 0; else { if (size == 16) { - if (uoffset >= srclen) - retnum = 0; - else - retnum = (UV) s[uoffset] << 8; + assert(avail == 1); + retnum = (UV) s[uoffset] << 8; } else if (size == 32) { - if (uoffset >= srclen) - retnum = 0; - else if (uoffset + 1 >= srclen) + assert(avail >= 1 && avail <= 3); + if (avail == 1) retnum = ((UV) s[uoffset ] << 24); - else if (uoffset + 2 >= srclen) + else if (avail == 2) retnum = ((UV) s[uoffset ] << 24) + ((UV) s[uoffset + 1] << 16); @@ -810,34 +816,33 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) else if (size == 64) { Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "Bit vector size > 32 non-portable"); - if (uoffset >= srclen) - retnum = 0; - else if (uoffset + 1 >= srclen) + assert(avail >= 1 && avail <= 7); + if (avail == 1) retnum = (UV) s[uoffset ] << 56; - else if (uoffset + 2 >= srclen) + else if (avail == 2) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48); - else if (uoffset + 3 >= srclen) + else if (avail == 3) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40); - else if (uoffset + 4 >= srclen) + else if (avail == 4) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32); - else if (uoffset + 5 >= srclen) + else if (avail == 5) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32) + ((UV) s[uoffset + 4] << 24); - else if (uoffset + 6 >= srclen) + else if (avail == 6) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + @@ -900,7 +905,7 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) void Perl_do_vecset(pTHX_ SV *sv) { - SSize_t offset, bitoffs = 0; + STRLEN offset, bitoffs = 0; int size; unsigned char *s; UV lval; @@ -926,9 +931,8 @@ Perl_do_vecset(pTHX_ SV *sv) (void)SvPOK_only(targ); lval = SvUV(sv); offset = LvTARGOFF(sv); - if (offset < 0) - Perl_croak(aTHX_ "Negative offset to vec in lvalue context"); size = LvTARGLEN(sv); + if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); @@ -936,14 +940,20 @@ Perl_do_vecset(pTHX_ SV *sv) bitoffs = ((offset%8)*size)%8; offset /= 8/size; } - else if (size > 8) - offset *= size/8; - - len = offset + (bitoffs + size + 7)/8; /* required number of bytes */ - if (len > targlen) { - s = (unsigned char*)SvGROW(targ, len + 1); - (void)memzero((char *)(s + targlen), len - targlen + 1); - SvCUR_set(targ, len); + else if (size > 8) { + int n = size/8; + if (offset > Size_t_MAX / n - 1) /* would overflow */ + Perl_croak_nocontext("Out of memory!"); + offset *= n; + } + + len = (bitoffs + size + 7)/8; /* required number of bytes */ + if (targlen < offset || targlen - offset < len) { + STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */ + Size_t_MAX : offset + len + 1; + s = (unsigned char*)SvGROW(targ, newlen); + (void)memzero((char *)(s + targlen), newlen - targlen); + SvCUR_set(targ, newlen - 1); } if (size < 8) { diff --git a/dump.c b/dump.c index c5e3a79feb..7cdebfe875 100644 --- a/dump.c +++ b/dump.c @@ -930,7 +930,7 @@ const struct flag_to_name op_flags_names[] = { /* indexed by enum OPclass */ -const char * op_class_names[] = { +const char * const op_class_names[] = { "NULL", "OP", "UNOP", diff --git a/embed.fnc b/embed.fnc index 3a68a3538f..654dad9998 100644 --- a/embed.fnc +++ b/embed.fnc @@ -491,7 +491,7 @@ pR |Off_t |do_tell |NN GV* gv : Defined in doop.c, used only in pp.c p |I32 |do_trans |NN SV* sv : Used in my.c and pp.c -p |UV |do_vecget |NN SV* sv|SSize_t offset|int size +p |UV |do_vecget |NN SV* sv|STRLEN offset|int size : Defined in doop.c, used only in mg.c (with /* XXX slurp this routine */) p |void |do_vecset |NN SV* sv : Defined in doop.c, used only in pp.c diff --git a/globvar.sym b/globvar.sym index 2943fc6691..c82dc8f1c8 100644 --- a/globvar.sym +++ b/globvar.sym @@ -19,6 +19,7 @@ PL_hexdigit PL_inf PL_interp_size PL_interp_size_5_18_0 +PL_isa_DOES PL_keyword_plugin PL_latin1_lc PL_magic_data diff --git a/locale.c b/locale.c index 1ba802f1ae..258542aac7 100644 --- a/locale.c +++ b/locale.c @@ -1955,8 +1955,8 @@ S_print_collxfrm_input_and_return(pTHX_ PERL_ARGS_ASSERT_PRINT_COLLXFRM_INPUT_AND_RETURN; - PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%u]: returning ", - PL_collation_ix); + PerlIO_printf(Perl_debug_log, "_mem_collxfrm[%" UVuf "]: returning ", + (UV)PL_collation_ix); if (xlen) { PerlIO_printf(Perl_debug_log, "%" UVuf, (UV) *xlen); } diff --git a/perl.h b/perl.h index 867c30050d..70e12bd722 100644 --- a/perl.h +++ b/perl.h @@ -4799,6 +4799,12 @@ EXTCONST U8 PL_subversion EXTCONST char PL_uuemap[65] INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"); +/* a special string address whose value is "isa", but which perl knows + * to treat as if it were really "DOES" when printing the method name in + * the "Can't call method '%s'" error message */ +EXTCONST char PL_isa_DOES[] + INIT("isa"); + #ifdef DOINIT EXTCONST char PL_uudmap[256] = # ifdef PERL_MICRO diff --git a/pp.c b/pp.c index a640995e31..a6b30412b5 100644 --- a/pp.c +++ b/pp.c @@ -3473,10 +3473,45 @@ PP(pp_vec) { dSP; const IV size = POPi; - const IV offset = POPi; + SV* offsetsv = POPs; SV * const src = POPs; const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; SV * ret; + UV retuv = 0; + STRLEN offset; + + /* extract a STRLEN-ranged integer value from offsetsv into offset, + * or die trying */ + { + IV iv = SvIV(offsetsv); + + /* avoid a large UV being wrapped to a negative value */ + if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX) { + if (!lvalue) + goto return_val; /* out of range: return 0 */ + Perl_croak_nocontext("Out of memory!"); + } + + if (iv < 0) { + if (!lvalue) + goto return_val; /* out of range: return 0 */ + Perl_croak_nocontext("Negative offset to vec in lvalue context"); + } + +#if PTRSIZE < IVSIZE + if (iv > Size_t_MAX) { + if (!lvalue) + goto return_val; /* out of range: return 0 */ + Perl_croak_nocontext("Out of memory!"); + } +#endif + + offset = (STRLEN)iv; + } + + retuv = do_vecget(src, offset, size); + + return_val: if (lvalue) { /* it's an lvalue! */ ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ @@ -3492,7 +3527,8 @@ PP(pp_vec) ret = TARG; } - sv_setuv(ret, do_vecget(src, offset, size)); + + sv_setuv(ret, retuv); if (!lvalue) SvSETMAGIC(ret); PUSHs(ret); diff --git a/pp_hot.c b/pp_hot.c index 4f0d094ce6..7c98c90337 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -4391,8 +4391,6 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) return sv; } -extern char PL_isa_DOES[]; - PERL_STATIC_INLINE HV * S_opmethod_stash(pTHX_ SV* meth) { diff --git a/proto.h b/proto.h index 3e55e21c3b..f1d6181b4b 100644 --- a/proto.h +++ b/proto.h @@ -806,7 +806,7 @@ PERL_CALLCONV Off_t Perl_do_tell(pTHX_ GV* gv) PERL_CALLCONV I32 Perl_do_trans(pTHX_ SV* sv); #define PERL_ARGS_ASSERT_DO_TRANS \ assert(sv) -PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, SSize_t offset, int size); +PERL_CALLCONV UV Perl_do_vecget(pTHX_ SV* sv, STRLEN offset, int size); #define PERL_ARGS_ASSERT_DO_VECGET \ assert(sv) PERL_CALLCONV void Perl_do_vecset(pTHX_ SV* sv); diff --git a/scope.c b/scope.c index c51a125dfa..a7c17e8d9e 100644 --- a/scope.c +++ b/scope.c @@ -788,7 +788,7 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad) } -static U8 arg_counts[] = { +static const U8 arg_counts[] = { 0, /* SAVEt_ALLOC */ 0, /* SAVEt_CLEARPADRANGE */ 0, /* SAVEt_CLEARSV */ diff --git a/t/op/vec.t b/t/op/vec.t index ea63317ad0..e50ffb7af8 100644 --- a/t/op/vec.t +++ b/t/op/vec.t @@ -6,7 +6,9 @@ BEGIN { set_up_inc('../lib'); } -plan( tests => 37 ); +use Config; + +plan(tests => 74); is(vec($foo,0,1), 0); @@ -135,3 +137,89 @@ like($@, qr/^Modification of a read-only value attempted at /, is ${\vec %h, 0, 1}, vec(scalar %h, 0, 1), '\vec %h'; is ${\vec @a, 0, 1}, vec(scalar @a, 0, 1), '\vec @a'; } + + +# [perl #130915] heap-buffer-overflow in Perl_do_vecget + +{ + # ensure that out-of-STRLEN-range offsets are handled correctly. This + # partially duplicates some tests above, but those cases are repeated + # here for completeness. + # + # Note that all the 'Out of memory!' errors trapped eval {} are 'fake' + # croaks generated by pp_vec() etc when they have detected something + # that would have otherwise overflowed. The real 'Out of memory!' + # error thrown by safesysrealloc() etc is not trappable. If it were + # accidentally triggered in this test script, the script would exit at + # that point. + + + my $s = "abcdefghijklmnopqrstuvwxyz"; + my $x; + + # offset is SvIOK_UV + + $x = vec($s, ~0, 8); + is($x, 0, "RT 130915: UV_MAX rval"); + eval { vec($s, ~0, 8) = 1 }; + like($@, qr/^Out of memory!/, "RT 130915: UV_MAX lval"); + + # offset is negative + + $x = vec($s, -1, 8); + is($x, 0, "RT 130915: -1 rval"); + eval { vec($s, -1, 8) = 1 }; + like($@, qr/^Negative offset to vec in lvalue context/, + "RT 130915: -1 lval"); + + # offset positive but doesn't fit in a STRLEN + + SKIP: { + skip 'IV is no longer than size_t', 2 + if $Config{ivsize} <= $Config{sizesize}; + + my $size_max = (1 << (8 *$Config{sizesize})) - 1; + my $sm2 = $size_max * 2; + + $x = vec($s, $sm2, 8); + is($x, 0, "RT 130915: size_max*2 rval"); + eval { vec($s, $sm2, 8) = 1 }; + like($@, qr/^Out of memory!/, "RT 130915: size_max*2 lval"); + } + + # (offset * num-bytes) could overflow + + for my $power (1..3) { + my $bytes = (1 << $power); + my $biglog2 = $Config{sizesize} * 8 - $power; + for my $i (0..1) { + my $offset = (1 << $biglog2) - $i; + $x = vec($s, $offset, $bytes*8); + is($x, 0, "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval"); + eval { vec($s, $offset, $bytes*8) = 1; }; + like($@, qr/^Out of memory!/, + "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval"); + } + } +} + +# Test multi-byte gets partially beyond the end of the string. +# It's supposed to pretend there is a stream of \0's following the string. + +{ + my $s = "\x01\x02\x03\x04\x05\x06\x07"; + my $s0 = $s . ("\0" x 8); + + for my $bytes (1, 2, 4, 8) { + for my $offset (0..$bytes) { + if ($Config{ivsize} < $bytes) { + pass("skipping multi-byte bytes=$bytes offset=$offset"); + next; + } + no warnings 'portable'; + is (vec($s, 8 - $offset, $bytes*8), + vec($s0, 8 - $offset, $bytes*8), + "multi-byte bytes=$bytes offset=$offset"); + } + } +} diff --git a/t/porting/libperl.t b/t/porting/libperl.t index 8c1350f68c..1536fda944 100644 --- a/t/porting/libperl.t +++ b/t/porting/libperl.t @@ -359,8 +359,19 @@ if ($GSP) { ok(! exists $symbols{data}{data} || # clang with ASAN seems to add this symbol to every object file: !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}), - "has no data data symbols"); - ok(! exists $symbols{data}{common}, "has no data common symbols"); + "has no data data symbols") + or do { + my $bad = "DATA entries (there are supposed to be none):\n"; + $bad .= " data sym: $_\n" for sort keys %{$symbols{data}{data}}; + diag($bad); + }; + + ok(! exists $symbols{data}{common}, "has no data common symbols") + or do { + my $bad = "COMMON entries (there are supposed to be none):\n"; + $bad .= " common sym: $_\n" for sort keys %{$symbols{data}{common}}; + diag($bad); + }; # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have # the extra text symbol for accessing the vars diff --git a/universal.c b/universal.c index 88835f9d78..be39310da7 100644 --- a/universal.c +++ b/universal.c @@ -184,11 +184,6 @@ The SV can be a Perl object or the name of a Perl class. #include "XSUB.h" -/* a special string address whose value is "isa", but which perl knows - * to treat as if it were really "DOES" when printing the method name in - * the "Can't call method '%s'" error message */ -char PL_isa_DOES[] = "isa"; - bool Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) { @@ -232,7 +227,7 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) methodname = newSV_type(SVt_PV); SvLEN(methodname) = 0; SvCUR(methodname) = strlen(PL_isa_DOES); - SvPVX(methodname) = PL_isa_DOES; + SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */ SvPOK_on(methodname); sv_2mortal(methodname); call_sv(methodname, G_SCALAR | G_METHOD); -- Perl5 Master Repository
