This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] EXTEND(), XSRETURN() wrap issues
authorDavid Mitchell <davem@iabyn.com>
Fri, 2 Oct 2015 10:43:41 +0000 (11:43 +0100)
committerDavid Mitchell <davem@iabyn.com>
Fri, 2 Oct 2015 10:43:41 +0000 (11:43 +0100)
19 files changed:
MANIFEST
XSUB.h
av.c
doop.c
ext/B/B.pm
ext/B/B.xs
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/extend.t [new file with mode: 0644]
ext/XS-APItest/t/xsub_h.t
handy.h
lib/ExtUtils/typemap
mg.c
pp.c
pp.h
pp_hot.c
pp_sys.c
regexec.c
scope.c
sv.c

index 7ae4148..864dd4a 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) {
index 706e19a..13ab3c9 100644 (file)
@@ -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.
index 5d15d80..eb21103 100644 (file)
@@ -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));
index 4002fc0..1514b6e 100644 (file)
@@ -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 (file)
index 0000000..b3834b4
--- /dev/null
@@ -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)";
+
+
+        }
+    }
+}
index 9bf0710..e763130 100644 (file)
@@ -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 (file)
--- 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
index 5f61527..1cdb846 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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 (file)
--- 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
index 840d131..66e8b9d 100644 (file)
--- 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;
index f1e2902..f9579af 100644 (file)
--- 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) {
index e92e7a3..15b28e5 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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();