This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
vec(): defer lvalue out-of-range croaking
authorDavid Mitchell <davem@iabyn.com>
Fri, 31 Mar 2017 12:44:58 +0000 (13:44 +0100)
committerDavid Mitchell <davem@iabyn.com>
Fri, 31 Mar 2017 13:13:24 +0000 (14:13 +0100)
RT #131083

Recent commits v5.25.10-81-gd69c430 and v5.25.10-82-g67dd6f3 added
out-of-range/overflow checks for the offset arg of vec().  However in
lvalue context, these croaks now happen before the SVt_PVLV was created,
rather than when its set magic was called. This means that something like

    sub f { $x = $_[0] }
    f(vec($s, -1, 8))

now croaks even though the out-of-range value never ended up getting used
in lvalue context.

This commit fixes things by, in pp_vec(), rather than croaking, just set
flag bits in LvFLAGS() to indicate that the offset is -Ve / out-of-range.

Then in Perl_magic_getvec(), return 0 if these flags are set, and in
Perl_magic_setvec() croak with a suitable error.

doop.c
mg.c
pp.c
sv.h
t/op/vec.t

diff --git a/doop.c b/doop.c
index 7674af5..18bc067 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -913,9 +913,19 @@ Perl_do_vecset(pTHX_ SV *sv)
     STRLEN targlen;
     STRLEN len;
     SV * const targ = LvTARG(sv);
+    char errflags = LvFLAGS(sv);
 
     PERL_ARGS_ASSERT_DO_VECSET;
 
+    /* some out-of-range errors have been deferred if/until the LV is
+     * actually written to: f(vec($s,-1,8)) is not always fatal */
+    if (errflags) {
+        assert(!(errflags & ~(1|4)));
+        if (errflags & 1)
+            Perl_croak_nocontext("Negative offset to vec in lvalue context");
+        Perl_croak_nocontext("Out of memory!");
+    }
+
     if (!targ)
        return;
     s = (unsigned char*)SvPV_force_flags(targ, targlen,
diff --git a/mg.c b/mg.c
index b11f66a..969d183 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2305,11 +2305,14 @@ int
 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
 {
     SV * const lsv = LvTARG(sv);
+    char errflags = LvFLAGS(sv);
 
     PERL_ARGS_ASSERT_MAGIC_GETVEC;
     PERL_UNUSED_ARG(mg);
 
-    sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+    /* non-zero errflags implies deferred out-of-range condition */
+    assert(!(errflags & ~(1|4)));
+    sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
 
     return 0;
 }
diff --git a/pp.c b/pp.c
index a6b3041..cc4cb59 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3477,41 +3477,29 @@ PP(pp_vec)
     SV * const src = POPs;
     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
     SV * ret;
-    UV   retuv = 0;
-    STRLEN offset;
+    UV   retuv;
+    STRLEN offset = 0;
+    char errflags = 0;
 
     /* extract a STRLEN-ranged integer value from offsetsv into offset,
-     * or die trying */
+     * or flag that its out of range */
     {
         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 (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
+            errflags = 4; /* out of range */
+        else if (iv < 0)
+            errflags = (1|4); /* negative offset, out of range */
 #if PTRSIZE < IVSIZE
-        if (iv > Size_t_MAX) {
-            if (!lvalue)
-                goto return_val; /* out of range: return 0 */
-            Perl_croak_nocontext("Out of memory!");
-        }
+        else if (iv > Size_t_MAX)
+            errflags = 4; /* out of range */
 #endif
-
-        offset = (STRLEN)iv;
+        else
+            offset = (STRLEN)iv;
     }
 
-    retuv = do_vecget(src, offset, size);
-
-  return_val:
+    retuv = errflags ? 0 : do_vecget(src, offset, size);
 
     if (lvalue) {                      /* it's an lvalue! */
        ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
@@ -3520,6 +3508,7 @@ PP(pp_vec)
        LvTARG(ret) = SvREFCNT_inc_simple(src);
        LvTARGOFF(ret) = offset;
        LvTARGLEN(ret) = size;
+       LvFLAGS(ret)   = errflags;
     }
     else {
        dTARGET;
@@ -3527,7 +3516,6 @@ PP(pp_vec)
        ret = TARG;
     }
 
-
     sv_setuv(ret, retuv);
     if (!lvalue)
        SvSETMAGIC(ret);
diff --git a/sv.h b/sv.h
index 82130b7..5e9c5b6 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -541,7 +541,8 @@ struct xpvlv {
     SV*                xlv_targ;
     char       xlv_type;       /* k=keys .=pos x=substr v=vec /=join/re
                                 * y=alem/helem/iter t=tie T=tied HE */
-    char       xlv_flags;      /* 1 = negative offset  2 = negative len */
+    char       xlv_flags;      /* 1 = negative offset  2 = negative len
+                                   4 = out of range (vec) */
 };
 
 #define xlv_targoff xlv_targoff_u.xlvu_targoff
index e50ffb7..5fa1879 100644 (file)
@@ -8,7 +8,7 @@ BEGIN {
 
 use Config;
 
-plan(tests => 74);
+plan(tests => 78);
 
 
 is(vec($foo,0,1), 0);
@@ -223,3 +223,21 @@ like($@, qr/^Modification of a read-only value attempted at /,
         }
     }
 }
+
+# RT #131083 maybe-lvalue out of range should only croak if assigned to
+
+{
+    sub  RT131083 { if ($_[0]) { $_[1] = 1; } $_[1]; }
+    my $s = "abc";
+    my $off = -1;
+    my $v = RT131083(0, vec($s, $off, 8));
+    is($v, 0, "RT131083 rval -1");
+    $v = eval { RT131083(1, vec($s, $off, 8)); };
+    like($@, qr/Negative offset to vec in lvalue context/, "RT131083 lval -1");
+
+    $off = ~0;
+    my $v = RT131083(0, vec($s, $off, 8));
+    is($v, 0, "RT131083 rval ~0");
+    $v = eval { RT131083(1, vec($s, $off, 8)); };
+    like($@, qr/Out of memory!/, "RT131083 lval ~0");
+}