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.

5 files changed, 94 insertions, 10 deletions

diff --git a/doop.c b/doop.c
index b5c10039b6..87e854a483 100644
--- a/doop.c
+++ b/doop.c
@@ -744,7 +744,7 @@ 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;
     const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET)
@@ -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");
 
@@ -926,8 +924,6 @@ 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");
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/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/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/t/op/vec.t b/t/op/vec.t
index ea63317ad0..9bea548459 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 => 43 );
 
 
 is(vec($foo,0,1), 0);
@@ -135,3 +137,53 @@ 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");
+    }
+}