In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/1b92e6949b737e92f61827f9c92afce9218e30ba?hp=1190bf17f4131bb86c6cd460c77e9d02894ca2ec>
- Log ----------------------------------------------------------------- commit 1b92e6949b737e92f61827f9c92afce9218e30ba Author: David Mitchell <[email protected]> Date: Fri Mar 31 13:44:58 2017 +0100 vec(): defer lvalue out-of-range croaking 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. ----------------------------------------------------------------------- Summary of changes: doop.c | 10 ++++++++++ mg.c | 5 ++++- pp.c | 40 ++++++++++++++-------------------------- sv.h | 3 ++- t/op/vec.t | 20 +++++++++++++++++++- 5 files changed, 49 insertions(+), 29 deletions(-) diff --git a/doop.c b/doop.c index 7674af5993..18bc067d93 100644 --- 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 b11f66acb0..969d183d6a 100644 --- 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 a6b30412b5..cc4cb59f7d 100644 --- 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 82130b7fc0..5e9c5b6881 100644 --- 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 diff --git a/t/op/vec.t b/t/op/vec.t index e50ffb7af8..5fa1879686 100644 --- a/t/op/vec.t +++ b/t/op/vec.t @@ -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"); +} -- Perl5 Master Repository
