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
#define XSRETURN(off) \
STMT_START { \
const IV tmpXSoff = (off); \
+ assert(tmpXSoff >= 0);\
PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \
return; \
} STMT_END
{
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;
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 */
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) {
# 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.
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) {
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));
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
test_force_keys(HV *hv)
PREINIT:
HE *he;
- STRLEN count = 0;
+ SSize_t count = 0;
PPCODE:
hv_iterinit(hv);
he = hv_iternext(hv);
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:
CV *cv;
AV *av;
SV **p;
- Size_t i, size;
+ SSize_t i, size;
cv = sv_2cv(block, &stash, &gv, 0);
if (cv == Nullcv) {
--- /dev/null
+#!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)";
+
+
+ }
+ }
+}
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();
* 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
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
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--) {
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;
}
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;
SP += max;
}
else if (count <= 0)
- SP -= items;
+ SP = MARK;
}
else { /* Note: mark already snarfed by pp_list */
SV * const tmpstr = POPs;
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;
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) {
=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
}
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;
{
SV **orig_sp = sp;
I32 ret_args;
+ SSize_t extend_size;
PERL_ARGS_ASSERT_TIED_METHOD;
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) {
* 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;
}
/* FALLTHROUGH */
case BOUNDL: /* /\b/l */
+ {
+ bool b1, b2;
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
if (FLAGS(scan) != TRADITIONAL_BOUND) {
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;
/* 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
* 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;
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
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) {
{
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);
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 *);
}
}
- 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();
https://perl5.git.perl.org / perl5.git / commitdiff