In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e1e57578ee6d0a7cfb9b7c2bd64ef30749ffb127?hp=0fa1f7e4e66a455cab6ccf1f9c49f2373c1ced80>
- Log ----------------------------------------------------------------- commit e1e57578ee6d0a7cfb9b7c2bd64ef30749ffb127 Merge: 0fa1f7e 50ceb81 Author: David Mitchell <[email protected]> Date: Fri Oct 2 11:43:41 2015 +0100 [MERGE] EXTEND(), XSRETURN() wrap issues commit 50ceb817b77c1d185c35795d3198f9b60248fe77 Author: Doug Bell <[email protected]> Date: Tue Jun 2 22:39:09 2015 -0500 add tests for XSRETURN* macros M ext/XS-APItest/APItest.xs M ext/XS-APItest/t/xsub_h.t commit 9e77582c6bb40536b9ca4037729a9b0f2c7ff932 Author: Doug Bell <[email protected]> Date: Tue Jun 2 22:34:42 2015 -0500 add assertion to prevent stack corruption in XSUB We should not be able to return negative offsets from the stack in XSUBs. M XSUB.h commit 052a7c766b9640ee847979cb9d2351a63e23a378 Author: David Mitchell <[email protected]> Date: Mon Sep 21 14:49:22 2015 +0100 fix up EXTEND() callers The previous commit made it clear that the N argument to EXTEND() is supposed to be signed, in particular SSize_t, and now typically triggers compiler warnings where this isn't the case. This commit fixes the various places in core that passed the wrong sort of N to EXTEND(). The fixes are in three broad categories. First, where sensible, I've changed the relevant var to be SSize_t. Second, where its expected that N could never be large enough to wrap, I've just added an assert and a cast. Finally, I've added extra code to detect whether the cast could wrap/truncate, and if so set N to -1, which will trigger a panic in stack_grow(). This also fixes [perl #125937] 'x' operator on list causes segfault with possible stack corruption M doop.c M ext/B/B.pm M ext/B/B.xs M ext/XS-APItest/APItest.xs M lib/ExtUtils/typemap M mg.c M pp.c M pp_sys.c commit 6768377c79109b7124f0c8a4e3677982689d9f49 Author: David Mitchell <[email protected]> Date: Mon Sep 7 15:00:32 2015 +0100 make EXTEND() and stack_grow() safe(r) This commit fixes various issues around stack_grow() and its two main wrappers, EXTEND() and MEXTEND(). In particular it behaves very badly on systems with 32-bit pointers but 64-bit ints. One noticeable effect of this is commit is that various usages of EXTEND() etc will now start to give compiler warnings - usually because they're passing an unsigned N arg when it should be signed. This may indicate a logic error in the caller's code which needs fixing. This commit causes several such warnings to appear in core code, which will be fixed in the next commit. Essentially there are several potential false negatives in this basic code: if (PL_stack_max - p < (SSize_t)(n)) stack_grow(sp,p,(SSize_t)(n)); where it incorrectly skips the call to stack_grow() and then the caller tramples over the end of the stack because it assumes that it has in fact been extended. The value of N passed to stack_grow() can also potentially get truncated or wrapped. Note that the N arg of stack_grow() is SSize_t and EXTEND()'s N arg is documented as SSize_t. In earlier times, they were both ints. Significantly, this means that they are both signed, and always have been. In detail, the problems and their solutions are: 1) N is a signed value: if negative, it could be an indication of a caller's invalid logic or wrapping in the caller's code. This should trigger a panic. Make it so by adding an extra test to EXTEND() to always call stack_grow if negative, then add a check and panic in stack_grow() (and other places too). This extra test will be constant folded when EXTEND() is called with a literal N. 2) If the caller passes an unsigned value of N, then the comparison is between a signed and an unsigned value, leading to potential wrap-around. Casting N to SSize_t merely hides any compiler warnings, thus failing to alert the caller to a problem with their code. In addition, where sizeof(N) > sizeof(SSize_t), the cast may truncate N, again leading to false negatives. The solution is to remove the cast, and let the caller deal with any compiler warnings that result. 3) Similarly, casting stack_grow()'s N arg can hide any warnings issued by e.g. -Wconversion. So remove it. It still does the wrong thing if the caller uses a non-signed type (usually a panic in stack_grow()), but coders have slightly more chance of spotting issues at compile time now. 4) If sizeof(N) > sizeof(SSize_t), then the N arg to stack_grow() may get truncated or sign-swapped. Add a test for this (basically that N is too big to fit in a SSize_t); for simplicity, in this case just set N to -1 so that stack_grow() panics shortly afterwards. In platforms where this can't happen, the test is constant folded away. With all these changes, the macro now looks in essence like: if ( n < 0 || PL_stack_max - p < n) stack_grow(sp,p, (sizeof(n) > sizeof(SSize_t) && ((SSize_t)(n) != n) ? -1 : n)); M MANIFEST M av.c M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/extend.t M pp.h M pp_hot.c M scope.c commit 73e8ff0004522621dfb42f01966853b51d5522a6 Author: David Mitchell <[email protected]> Date: Wed Sep 9 13:02:40 2015 +0100 fix some 32/64-bit compiler warnings Some bits of code don't do well on a 32-bit system with 64-bit ints (-Duse64bitint) In particular: _MEM_WRAP_NEEDS_RUNTIME_CHECK: if sizeof(MEM_SIZE) > sizeof(n), then the shift count could be negative S_regmatch: ln and n were two different sizes and signesses, so comparing them warned. Since they were being mis-used as two convenient temporary booleans anyway, just use temporary booleans instead. Perl_sv_vcatpvfn_flags: the test/assertion (IV)elen < 0 was (I think) being used to test for signed/unsigned conversion wrap-around. elen is of type STRLEN which is a pointer-based type, so can be 32-bit while IV is 64-bit. Instead compare it to half the maximum value of a STRLEN var to see if it may have wrapped. M handy.h M regexec.c M sv.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + XSUB.h | 1 + av.c | 4 +++ doop.c | 6 +++- ext/B/B.pm | 2 +- ext/B/B.xs | 10 ++++-- ext/XS-APItest/APItest.xs | 92 +++++++++++++++++++++++++++++++++++++++++++++-- ext/XS-APItest/t/extend.t | 68 +++++++++++++++++++++++++++++++++++ ext/XS-APItest/t/xsub_h.t | 31 ++++++++++++++++ handy.h | 5 ++- lib/ExtUtils/typemap | 6 +++- mg.c | 4 ++- pp.c | 29 ++++++++------- pp.h | 47 +++++++++++++++++++----- pp_hot.c | 4 ++- pp_sys.c | 8 ++++- regexec.c | 48 +++++++++++++++---------- scope.c | 4 +++ sv.c | 10 +++--- 19 files changed, 325 insertions(+), 55 deletions(-) create mode 100644 ext/XS-APItest/t/extend.t diff --git a/MANIFEST b/MANIFEST index 7ae4148..864dd4a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3933,6 +3933,7 @@ ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops ext/XS-APItest/t/cv_name.t test cv_name ext/XS-APItest/t/eval-filter.t Simple source filter/eval test ext/XS-APItest/t/exception.t XS::APItest extension +ext/XS-APItest/t/extend.t test EXTEND() macro ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad ext/XS-APItest/t/gotosub.t XS::APItest: tests goto &xsub and hints ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions diff --git a/XSUB.h b/XSUB.h index 4548fc9..e64bc83 100644 --- a/XSUB.h +++ b/XSUB.h @@ -327,6 +327,7 @@ Rethrows a previously caught exception. See L<perlguts/"Exception Handling">. #define XSRETURN(off) \ STMT_START { \ const IV tmpXSoff = (off); \ + assert(tmpXSoff >= 0);\ PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \ return; \ } STMT_END diff --git a/av.c b/av.c index cb99ceb..2c4740b 100644 --- a/av.c +++ b/av.c @@ -87,6 +87,10 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, { PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + if (key < -1) /* -1 is legal */ + Perl_croak(aTHX_ + "panic: av_extend_guts() negative count (%"IVdf")", (IV)key); + if (key > *maxp) { SV** ary; SSize_t tmp; diff --git a/doop.c b/doop.c index 19fe310..5dbd8a2 100644 --- a/doop.c +++ b/doop.c @@ -1220,6 +1220,7 @@ Perl_do_kv(pTHX) dSP; HV * const keys = MUTABLE_HV(POPs); HE *entry; + SSize_t extend_size; const I32 gimme = GIMME_V; const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */ @@ -1255,7 +1256,10 @@ Perl_do_kv(pTHX) RETURN; } - EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues)); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(keys) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(keys) * (dokeys + dovalues); + EXTEND(SP, extend_size); while ((entry = hv_iternext(keys))) { if (dokeys) { diff --git a/ext/B/B.pm b/ext/B/B.pm index 706e19a..13ab3c9 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.59'; + $B::VERSION = '1.60'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 5d15d80..eb21103 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1370,7 +1370,9 @@ aux_list(o, cv) PAD *comppad = PadlistARRAY(padlist)[1]; #endif - EXTEND(SP, len); + /* len should never be big enough to truncate or wrap */ + assert(len <= SSize_t_MAX); + EXTEND(SP, (SSize_t)len); PUSHs(sv_2mortal(newSViv(actions))); while (!last) { @@ -2139,8 +2141,12 @@ HvARRAY(hv) PPCODE: if (HvUSEDKEYS(hv) > 0) { HE *he; + SSize_t extend_size; (void)hv_iterinit(hv); - EXTEND(sp, HvUSEDKEYS(hv) * 2); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(hv) * 2; + EXTEND(sp, extend_size); while ((he = hv_iternext(hv))) { if (HeSVKEY(he)) { mPUSHs(HeSVKEY(he)); diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 4002fc0..1514b6e 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1443,6 +1443,61 @@ XS_APIVERSION_valid(...) XS_APIVERSION_BOOTCHECK; XSRETURN_EMPTY; +void +xsreturn( int len ) + PPCODE: + int i = 0; + EXTEND( SP, len ); + for ( ; i < len; i++ ) { + ST(i) = sv_2mortal( newSViv(i) ); + } + XSRETURN( len ); + +void +xsreturn_iv() + PPCODE: + XSRETURN_IV( (1<<31) + 1 ); + +void +xsreturn_uv() + PPCODE: + XSRETURN_UV( (U32)((1<<31) + 1) ); + +void +xsreturn_nv() + PPCODE: + XSRETURN_NV(0.25); + +void +xsreturn_pv() + PPCODE: + XSRETURN_PV("returned"); + +void +xsreturn_pvn() + PPCODE: + XSRETURN_PVN("returned too much",8); + +void +xsreturn_no() + PPCODE: + XSRETURN_NO; + +void +xsreturn_yes() + PPCODE: + XSRETURN_YES; + +void +xsreturn_undef() + PPCODE: + XSRETURN_UNDEF; + +void +xsreturn_empty() + PPCODE: + XSRETURN_EMPTY; + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void @@ -1738,7 +1793,7 @@ void test_force_keys(HV *hv) PREINIT: HE *he; - STRLEN count = 0; + SSize_t count = 0; PPCODE: hv_iterinit(hv); he = hv_iternext(hv); @@ -2137,6 +2192,39 @@ mxpushu() mXPUSHu(3); XSRETURN(3); + + # test_EXTEND(): excerise the EXTEND() macro. + # After calling EXTEND(), it also does *(p+n) = NULL and + # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't + # actually been extended properly. + # + # max_offset specifies the SP to use. It is treated as a signed offset + # from PL_stack_max. + # nsv is the SV holding the value of n indicating how many slots + # to extend the stack by. + # use_ss is a boolean indicating that n should be cast to a SSize_t + +void +test_EXTEND(max_offset, nsv, use_ss) + IV max_offset; + SV *nsv; + bool use_ss; +PREINIT: + SV **sp = PL_stack_max + max_offset; +PPCODE: + if (use_ss) { + SSize_t n = (SSize_t)SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + else { + IV n = SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + *PL_stack_max = NULL; + + void call_sv_C() PREINIT: @@ -3518,7 +3606,7 @@ CODE: CV *cv; AV *av; SV **p; - Size_t i, size; + SSize_t i, size; cv = sv_2cv(block, &stash, &gv, 0); if (cv == Nullcv) { diff --git a/ext/XS-APItest/t/extend.t b/ext/XS-APItest/t/extend.t new file mode 100644 index 0000000..b3834b4 --- /dev/null +++ b/ext/XS-APItest/t/extend.t @@ -0,0 +1,68 @@ +#!perl +# +# Test stack expansion macros: EXTEND() etc, especially for edge cases +# where the count wraps to a native value or gets truncated. +# +# Some of these tests aren't really testing; they are however exercising +# edge cases, which other tools like ASAN may then detect problems with. +# In particular, test_EXTEND() does *(p+n) = NULL and *PL_stack_max = NULL +# before returning, to help such tools spot errors. +# +# Also, it doesn't test large but legal grow requests; only ridiculously +# large requests that are guaranteed to wrap. + +use Test::More; +use Config; +use XS::APItest qw(test_EXTEND); + +plan tests => 48; + +my $uvsize = $Config::Config{uvsize}; # sizeof(UV) +my $sizesize = $Config::Config{sizesize}; # sizeof(Size_t) + +# The first arg to test_EXTEND() is the SP to use in EXTEND(), treated +# as an offset from PL_stack_max. So extend(-1, 1, $use_ss) shouldn't +# call Perl_stack_grow(), while extend(-1, 2, $use_ss) should. +# Exercise offsets near to PL_stack_max to detect edge cases. +# Note that having the SP pointer beyond PL_stack_max is legal. + +for my $offset (-1, 0, 1) { + + # treat N as either an IV or a SSize_t + for my $use_ss (0, 1) { + + # test with N in range -1 .. 3; only the -1 should panic + + eval { test_EXTEND($offset, -1, $use_ss) }; + like $@, qr/panic: .*negative count/, "test_EXTEND($offset, -1, $use_ss)"; + + for my $n (0,1,2,3) { + eval { test_EXTEND($offset, $n, $use_ss) }; + is $@, "", "test_EXTEND($offset, $n, $use_ss)"; + } + + # some things can wrap if the int size is greater than the ptr size + + SKIP: { + skip "Not small ptrs", 3 if $use_ss || $uvsize <= $sizesize; + + # 0xffff... wraps to -1 + eval { test_EXTEND($offset, (1 << 8*$sizesize)-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX, $use_ss)"; + + # 0x10000... truncates to zero; + # but the wrap-detection code converts it to -1 to force a panic + eval { test_EXTEND($offset, 1 << 8*$sizesize, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX+1, $use_ss)"; + + # 0x1ffff... truncates and then wraps to -1 + eval { test_EXTEND($offset, (1 << (8*$sizesize+1))-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, 2*SIZE_MAX-1, $use_ss)"; + + + } + } +} diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t index 9bf0710..e763130 100644 --- a/ext/XS-APItest/t/xsub_h.t +++ b/ext/XS-APItest/t/xsub_h.t @@ -120,4 +120,35 @@ is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef, like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/, "expected error"); +my @xsreturn; +@xsreturn = XS::APItest::XSUB::xsreturn(2); +is scalar @xsreturn, 2, 'returns a list of 2 elements'; +is $xsreturn[0], 0; +is $xsreturn[1], 1; + +my $xsreturn = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 2, 'returns the last item on the stack'; + +( $xsreturn ) = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 0, 'gets the first item on the stack'; + +is XS::APItest::XSUB::xsreturn_iv(), -2**31+1, 'XSRETURN_IV returns signed int'; +is XS::APItest::XSUB::xsreturn_uv(), 2**31+1, 'XSRETURN_UV returns unsigned int'; +is XS::APItest::XSUB::xsreturn_nv(), 0.25, 'XSRETURN_NV returns double'; +is XS::APItest::XSUB::xsreturn_pv(), "returned", 'XSRETURN_PV returns string'; +is XS::APItest::XSUB::xsreturn_pvn(), "returned", 'XSRETURN_PVN returns string with length'; +ok !XS::APItest::XSUB::xsreturn_no(), 'XSRETURN_NO returns falsey'; +ok XS::APItest::XSUB::xsreturn_yes(), 'XSRETURN_YES returns truthy'; + +is XS::APItest::XSUB::xsreturn_undef(), undef, 'XSRETURN_UNDEF returns undef in scalar context'; +my @xs_undef = XS::APItest::XSUB::xsreturn_undef(); +is scalar @xs_undef, 1, 'XSRETURN_UNDEF returns a single-element list'; +is $xs_undef[0], undef, 'XSRETURN_UNDEF returns undef in list context'; + +my @xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context'; +my $xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context'; + + done_testing(); diff --git a/handy.h b/handy.h index 0318504..ffb8e2f 100644 --- a/handy.h +++ b/handy.h @@ -1917,10 +1917,13 @@ PoisonWith(0xEF) for catching access to freed memory. * As well as avoiding the need for a run-time check in some cases, it's * designed to avoid compiler warnings like: * comparison is always false due to limited range of data type + * It's mathematically equivalent to + * max(n) * sizeof(t) > MEM_SIZE_MAX */ # define _MEM_WRAP_NEEDS_RUNTIME_CHECK(n,t) \ - (sizeof(t) > ((MEM_SIZE)1 << 8*(sizeof(MEM_SIZE) - sizeof(n)))) + ( sizeof(MEM_SIZE) < sizeof(n) \ + || sizeof(t) > ((MEM_SIZE)1 << 8*(sizeof(MEM_SIZE) - sizeof(n)))) /* This is written in a slightly odd way to avoid various spurious * compiler warnings. We *want* to write the expression as diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 5f61527..1cdb846 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -378,7 +378,11 @@ T_PACKEDARRAY T_ARRAY { U32 ix_$var; - EXTEND(SP,size_$var); + SSize_t extend_size = + sizeof(size_$var) > sizeof(SSize_t) && size_$var > SSize_t_MAX + ? -1 /* might wrap; -1 triggers a panic in EXTEND() */ + : (SSize_t)size_$var; + EXTEND(SP, extend_size); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM diff --git a/mg.c b/mg.c index 8ebb6a3..ea39a67 100644 --- a/mg.c +++ b/mg.c @@ -1810,7 +1810,9 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, argc+1); + /* EXTEND() expects a signed argc; don't wrap when casting */ + assert(argc <= I32_MAX); + EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { while (argc--) { diff --git a/pp.c b/pp.c index 34e4a4e..05268f4 100644 --- a/pp.c +++ b/pp.c @@ -88,18 +88,18 @@ PP(pp_padav) gimme = GIMME_V; if (gimme == G_ARRAY) { /* XXX see also S_pushav in pp_hot.c */ - const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { - Size_t i; + SSize_t i; for (i=0; i < maxarg; i++) { SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { - PADOFFSET i; - for (i=0; i < (PADOFFSET)maxarg; i++) { + SSize_t i; + for (i=0; i < maxarg; i++) { SV * const sv = AvARRAY((const AV *)TARG)[i]; SP[i+1] = sv ? sv : &PL_sv_undef; } @@ -1718,14 +1718,15 @@ PP(pp_repeat) if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; - const Size_t items = SP - MARK; + const SSize_t items = SP - MARK; const U8 mod = PL_op->op_flags & OPf_MOD; if (count > 1) { - Size_t max; + SSize_t max; - if ( items > MEM_SIZE_MAX / (UV)count /* max would overflow */ - || items > (U32)I32_MAX / sizeof(SV *) /* repeatcpy would overflow */ + if ( items > SSize_t_MAX / count /* max would overflow */ + /* repeatcpy would overflow */ + || items > I32_MAX / (I32)sizeof(SV *) ) Perl_croak(aTHX_ "%s","Out of memory during list extend"); max = items * count; @@ -1746,7 +1747,7 @@ PP(pp_repeat) SP += max; } else if (count <= 0) - SP -= items; + SP = MARK; } else { /* Note: mark already snarfed by pp_list */ SV * const tmpstr = POPs; @@ -5660,7 +5661,7 @@ PP(pp_split) SSize_t maxiters = slen + 10; I32 trailing_empty = 0; const char *orig; - const I32 origlimit = limit; + const IV origlimit = limit; I32 realarray = 0; I32 base; const I32 gimme = GIMME_V; @@ -5834,11 +5835,13 @@ PP(pp_split) split //, $str, $i; */ if (!gimme_scalar) { - const U32 items = limit - 1; - if (items < slen) + const IV items = limit - 1; + /* setting it to -1 will trigger a panic in EXTEND() */ + const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; + if (items >=0 && items < sslen) EXTEND(SP, items); else - EXTEND(SP, slen); + EXTEND(SP, sslen); } if (do_utf8) { diff --git a/pp.h b/pp.h index 2d99a72..b497085 100644 --- a/pp.h +++ b/pp.h @@ -283,29 +283,58 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. =cut */ +/* _EXTEND_SAFE_N(n): private helper macro for EXTEND(). + * Tests whether the value of n would be truncated when implicitly cast to + * SSize_t as an arg to stack_grow(). If so, sets it to -1 instead to + * trigger a panic. It will be constant folded on platforms where this + * can't happen. + */ + +#define _EXTEND_SAFE_N(n) \ + (sizeof(n) > sizeof(SSize_t) && ((SSize_t)(n) != (n)) ? -1 : (n)) + #ifdef STRESS_REALLOC # define EXTEND(p,n) STMT_START { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } STMT_END /* Same thing, but update mark register too. */ # define MEXTEND(p,n) STMT_START { \ const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } STMT_END #else -# define EXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + +/* _EXTEND_NEEDS_GROW(p,n): private helper macro for EXTEND(). + * Tests to see whether n is too big and we need to grow the stack. Be + * very careful if modifying this. There are many ways to get things wrong + * (wrapping, truncating etc) that could cause a false negative and cause + * the call to stack_grow() to be skipped. On the other hand, false + * positives are safe. + * Bear in mind that sizeof(p) may be less than, equal to, or greater + * than sizeof(n), and while n is documented to be signed, someone might + * pass an unsigned value or expression. In general don't use casts to + * avoid warnings; instead expect the caller to fix their code. + * It is legal for p to be greater than PL_stack_max. + * If the allocated stack is already very large but current usage is + * small, then PL_stack_max - p might wrap round to a negative value, but + * this just gives a safe false positive + */ + +# define _EXTEND_NEEDS_GROW(p,n) ( (n) < 0 || PL_stack_max - p < (n)) + +# define EXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } } STMT_END /* Same thing, but update mark register too. */ -# define MEXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ +# define MEXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + const SSize_t markoff = mark - PL_stack_base;\ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } } STMT_END diff --git a/pp_hot.c b/pp_hot.c index 840d131..66e8b9d 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1275,7 +1275,9 @@ PP(pp_aassign) } av_clear(ary); - av_extend(ary, lastrelem - relem); + if (relem <= lastrelem) + av_extend(ary, lastrelem - relem); + i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; diff --git a/pp_sys.c b/pp_sys.c index f1e2902..f9579af 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -533,6 +533,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, { SV **orig_sp = sp; I32 ret_args; + SSize_t extend_size; PERL_ARGS_ASSERT_TIED_METHOD; @@ -543,7 +544,12 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ PUSHSTACKi(PERLSI_MAGIC); - EXTEND(SP, argc+1); /* object + args */ + /* extend for object + args. If argc might wrap/truncate when cast + * to SSize_t, set to -1 which will trigger a panic in EXTEND() */ + extend_size = + sizeof(argc) >= sizeof(SSize_t) && argc > SSize_t_MAX - 1 + ? -1 : (SSize_t)argc + 1; + EXTEND(SP, extend_size); PUSHMARK(sp); PUSHs(SvTIED_obj(sv, mg)); if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { diff --git a/regexec.c b/regexec.c index e92e7a3..15b28e5 100644 --- a/regexec.c +++ b/regexec.c @@ -1205,10 +1205,10 @@ Perl_re_intuit_start(pTHX_ * didn't contradict, so just retry the anchored "other" * substr */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " Found /%s^%s/m, rescanning for anchored from offset %ld (rx_origin now %"IVdf")...\n", + " Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n", PL_colors[0], PL_colors[1], - (long)(rx_origin - strbeg + prog->anchored_offset), - (long)(rx_origin - strbeg) + (IV)(rx_origin - strbeg + prog->anchored_offset), + (IV)(rx_origin - strbeg) )); goto do_other_substr; } @@ -5526,6 +5526,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* FALLTHROUGH */ case BOUNDL: /* /\b/l */ + { + bool b1, b2; _CHECK_AND_WARN_PROBLEMATIC_LOCALE; if (FLAGS(scan) != TRADITIONAL_BOUND) { @@ -5538,27 +5540,28 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (utf8_target) { if (locinput == reginfo->strbeg) - ln = isWORDCHAR_LC('\n'); + b1 = isWORDCHAR_LC('\n'); else { - ln = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1, + b1 = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg))); } - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC_utf8((U8*)locinput); } else { /* Here the string isn't utf8 */ - ln = (locinput == reginfo->strbeg) + b1 = (locinput == reginfo->strbeg) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(nextchr); } - if (to_complement ^ (ln == n)) { + if (to_complement ^ (b1 == b2)) { sayNO; } break; + } case NBOUND: /* /\B/ */ to_complement = 1; @@ -5575,6 +5578,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* FALLTHROUGH */ case BOUNDA: /* /\b/a */ + { + bool b1, b2; bound_ascii_match_only: /* Here the string isn't utf8, or is utf8 and only ascii characters @@ -5586,16 +5591,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * 2) it is a multi-byte character, in which case the final byte is * never mistakable for ASCII, and so the test will say it is * not a word character, which is the correct answer. */ - ln = (locinput == reginfo->strbeg) + b1 = (locinput == reginfo->strbeg) ? isWORDCHAR_A('\n') : isWORDCHAR_A(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_A('\n') : isWORDCHAR_A(nextchr); - if (to_complement ^ (ln == n)) { + if (to_complement ^ (b1 == b2)) { sayNO; } break; + } case NBOUNDU: /* /\B/u */ to_complement = 1; @@ -5609,15 +5615,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) bound_utf8: switch((bound_type) FLAGS(scan)) { case TRADITIONAL_BOUND: - ln = (locinput == reginfo->strbeg) + { + bool b1, b2; + b1 = (locinput == reginfo->strbeg) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_utf8(reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg))); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_utf8((U8*)locinput); - match = cBOOL(ln != n); + match = cBOOL(b1 != b2); break; + } case GCB_BOUND: if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) { match = TRUE; /* GCB always matches at begin and @@ -5679,14 +5688,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) else { /* Not utf8 target */ switch((bound_type) FLAGS(scan)) { case TRADITIONAL_BOUND: - ln = (locinput == reginfo->strbeg) + { + bool b1, b2; + b1 = (locinput == reginfo->strbeg) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_L1(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_L1(nextchr); - match = cBOOL(ln != n); + match = cBOOL(b1 != b2); break; + } case GCB_BOUND: if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) { diff --git a/scope.c b/scope.c index 9768c30..1b89186 100644 --- a/scope.c +++ b/scope.c @@ -31,6 +31,10 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) { PERL_ARGS_ASSERT_STACK_GROW; + if (n < 0) + Perl_croak(aTHX_ + "panic: stack_grow() negative count (%"IVdf")", (IV)n); + PL_stack_sp = sp; #ifndef STRESS_REALLOC av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); diff --git a/sv.c b/sv.c index dc2ba8b..feca758 100644 --- a/sv.c +++ b/sv.c @@ -11444,9 +11444,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p is safe. */ is_utf8 = (bool)va_arg(*args, int); elen = va_arg(*args, UV); - if ((IV)elen < 0) { - /* check if utf8 length is larger than 0 when cast to IV */ - assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */ + /* if utf8 length is larger than 0x7ffff..., then it might + * have been a signed value that wrapped */ + if (elen > ((~(STRLEN)0) >> 1)) { + assert(0); /* in DEBUGGING build we want to crash */ elen= 0; /* otherwise we want to treat this as an empty string */ } eptr = va_arg(*args, char *); @@ -12690,7 +12691,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - assert((IV)elen >= 0); /* here zero elen is fine */ + /* signed value that's wrapped? */ + assert(elen <= ((~(STRLEN)0) >> 1)); have = esignlen + zeros + elen; if (have < zeros) croak_memory_wrap(); -- Perl5 Master Repository
