X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/abec5bedacd77b2152e61ec3216ab47bd7272fc9..27daf5669559d9755c5886825536aefd01d540ca:/doop.c diff --git a/doop.c b/doop.c index c6ee847..0a546cc 100644 --- a/doop.c +++ b/doop.c @@ -16,7 +16,7 @@ /* This file contains some common functions needed to carry out certain * ops. For example, both pp_sprintf() and pp_prtf() call the function - * do_printf() found in this file. + * do_sprintf() found in this file. */ #include "EXTERN.h" @@ -680,7 +680,7 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) ++mark; } - sv_setpvs(sv, ""); + SvPVCLEAR(sv); /* sv_setpv retains old UTF8ness [perl #24846] */ SvUTF8_off(sv); @@ -744,9 +744,9 @@ 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; + STRLEN srclen, len, avail, uoffset, bitoffs = 0; const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET) ? SV_UNDEF_RETURNS_NULL : 0); unsigned char *s = (unsigned char *) @@ -759,44 +759,57 @@ 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"); if (SvUTF8(sv)) { - (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); - /* PVX may have changed */ - s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags); + if (Perl_sv_utf8_downgrade(aTHX_ sv, TRUE)) { + /* PVX may have changed */ + s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags); + } + else { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Use of strings with code points over 0xFF as" + " arguments to vec is deprecated. This will" + " be a fatal error in Perl 5.32"); + } } if (size < 8) { bitoffs = ((offset%8)*size)%8; uoffset = offset/(8/size); } - else if (size > 8) - uoffset = offset*(size/8); + else if (size > 8) { + int n = size/8; + if (offset > Size_t_MAX / n - 1) /* would overflow */ + return 0; + uoffset = offset*n; + } else uoffset = offset; - len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */ - if (len > srclen) { + if (uoffset >= srclen) + return 0; + + len = (bitoffs + size + 7)/8; /* required number of bytes */ + avail = srclen - uoffset; /* available number of bytes */ + + /* Does the byte range overlap the end of the string? If so, + * handle specially. */ + if (avail < len) { if (size <= 8) retnum = 0; else { if (size == 16) { - if (uoffset >= srclen) - retnum = 0; - else - retnum = (UV) s[uoffset] << 8; + assert(avail == 1); + retnum = (UV) s[uoffset] << 8; } else if (size == 32) { - if (uoffset >= srclen) - retnum = 0; - else if (uoffset + 1 >= srclen) + assert(avail >= 1 && avail <= 3); + if (avail == 1) retnum = ((UV) s[uoffset ] << 24); - else if (uoffset + 2 >= srclen) + else if (avail == 2) retnum = ((UV) s[uoffset ] << 24) + ((UV) s[uoffset + 1] << 16); @@ -810,34 +823,33 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) else if (size == 64) { Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), "Bit vector size > 32 non-portable"); - if (uoffset >= srclen) - retnum = 0; - else if (uoffset + 1 >= srclen) + assert(avail >= 1 && avail <= 7); + if (avail == 1) retnum = (UV) s[uoffset ] << 56; - else if (uoffset + 2 >= srclen) + else if (avail == 2) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48); - else if (uoffset + 3 >= srclen) + else if (avail == 3) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40); - else if (uoffset + 4 >= srclen) + else if (avail == 4) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32); - else if (uoffset + 5 >= srclen) + else if (avail == 5) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + ((UV) s[uoffset + 2] << 40) + ((UV) s[uoffset + 3] << 32) + ((UV) s[uoffset + 4] << 24); - else if (uoffset + 6 >= srclen) + else if (avail == 6) retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + @@ -900,7 +912,7 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) void Perl_do_vecset(pTHX_ SV *sv) { - SSize_t offset, bitoffs = 0; + STRLEN offset, bitoffs = 0; int size; unsigned char *s; UV lval; @@ -908,9 +920,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 & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE))); + if (errflags & LVf_NEG_OFF) + 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, @@ -926,9 +948,8 @@ 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"); @@ -936,14 +957,20 @@ Perl_do_vecset(pTHX_ SV *sv) bitoffs = ((offset%8)*size)%8; offset /= 8/size; } - else if (size > 8) - offset *= size/8; - - len = offset + (bitoffs + size + 7)/8; /* required number of bytes */ - if (len > targlen) { - s = (unsigned char*)SvGROW(targ, len + 1); - (void)memzero((char *)(s + targlen), len - targlen + 1); - SvCUR_set(targ, len); + else if (size > 8) { + int n = size/8; + if (offset > Size_t_MAX / n - 1) /* would overflow */ + Perl_croak_nocontext("Out of memory!"); + offset *= n; + } + + len = (bitoffs + size + 7)/8; /* required number of bytes */ + if (targlen < offset || targlen - offset < len) { + STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */ + Size_t_MAX : offset + len + 1; + s = (unsigned char*)SvGROW(targ, newlen); + (void)memzero((char *)(s + targlen), newlen - targlen); + SvCUR_set(targ, newlen - 1); } if (size < 8) { @@ -1002,12 +1029,13 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) const char *rsave; bool left_utf; bool right_utf; + bool do_warn_above_ff = ckWARN_d(WARN_DEPRECATED); STRLEN needlen = 0; PERL_ARGS_ASSERT_DO_VOP; if (sv != left || (optype != OP_BIT_AND && !SvOK(sv))) - sv_setpvs(sv, ""); /* avoid undef warning on |= and ^= */ + SvPVCLEAR(sv); /* avoid undef warning on |= and ^= */ if (sv == left) { lsave = lc = SvPV_force_nomg(left, leftlen); } @@ -1017,7 +1045,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) } rsave = rc = SvPV_nomg_const(right, rightlen); - /* This need to come after SvPV to ensure that string overloading has + /* This needs to come after SvPV to ensure that string overloading has fired off. */ left_utf = DO_UTF8(left); @@ -1064,16 +1092,16 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } if (left_utf || right_utf) { - UV duc, luc, ruc; char *dcorig = dc; char *dcsave = NULL; STRLEN lulen = leftlen; STRLEN rulen = rightlen; - STRLEN ulen; switch (optype) { case OP_BIT_AND: while (lulen && rulen) { + UV duc, luc, ruc; + STRLEN ulen; luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; @@ -1082,13 +1110,22 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) rulen -= ulen; duc = luc & ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); + if (do_warn_above_ff && (luc > 0xff || ruc > 0xff)) { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + deprecated_above_ff_msg, PL_op_desc[optype]); + /* Warn only once per operation */ + do_warn_above_ff = FALSE; + } } if (sv == left || sv == right) (void)sv_usepvn(sv, dcorig, needlen); SvCUR_set(sv, dc - dcorig); + *SvEND(sv) = 0; break; case OP_BIT_XOR: while (lulen && rulen) { + UV duc, luc, ruc; + STRLEN ulen; luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; @@ -1097,10 +1134,17 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) rulen -= ulen; duc = luc ^ ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); + if (do_warn_above_ff && (luc > 0xff || ruc > 0xff)) { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + deprecated_above_ff_msg, PL_op_desc[optype]); + do_warn_above_ff = FALSE; + } } goto mop_up_utf; case OP_BIT_OR: while (lulen && rulen) { + UV duc, luc, ruc; + STRLEN ulen; luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; @@ -1109,6 +1153,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) rulen -= ulen; duc = luc | ruc; dc = (char*)uvchr_to_utf8((U8*)dc, duc); + if (do_warn_above_ff && (luc > 0xff || ruc > 0xff)) { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + deprecated_above_ff_msg, PL_op_desc[optype]); + do_warn_above_ff = FALSE; + } } mop_up_utf: if (rulen) @@ -1198,12 +1247,20 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) *dc++ = *lc++ | *rc++; mop_up: len = lensave; - if (rightlen > len) - sv_catpvn_nomg(sv, rsave + len, rightlen - len); - else if (leftlen > (STRLEN)len) - sv_catpvn_nomg(sv, lsave + len, leftlen - len); - else - *SvEND(sv) = '\0'; + if (rightlen > len) { + if (dc == rc) + SvCUR(sv) = rightlen; + else + sv_catpvn_nomg(sv, rsave + len, rightlen - len); + } + else if (leftlen > len) { + if (dc == lc) + SvCUR(sv) = leftlen; + else + sv_catpvn_nomg(sv, lsave + len, leftlen - len); + } + *SvEND(sv) = '\0'; + break; } } @@ -1220,11 +1277,16 @@ Perl_do_kv(pTHX) dSP; HV * const keys = MUTABLE_HV(POPs); HE *entry; - const I32 gimme = GIMME_V; + SSize_t extend_size; + const U8 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 */ - const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS || PL_op->op_type == OP_RKEYS); - const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES || PL_op->op_type == OP_RVALUES); + const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS) + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & 3) + OP_EACH == OP_KEYS ); + const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES) + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & 3) + OP_EACH == OP_VALUES ); (void)hv_iterinit(keys); /* always reset iterator regardless */ @@ -1255,7 +1317,17 @@ Perl_do_kv(pTHX) RETURN; } - EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues)); + if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ "Can't modify keys in list assignment"); + } + + /* 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) { @@ -1263,8 +1335,7 @@ Perl_do_kv(pTHX) XPUSHs(sv); } if (dovalues) { - SV *tmpstr; - tmpstr = hv_iterval(keys,entry); + SV *tmpstr = hv_iterval(keys,entry); DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu", (unsigned long)HeHASH(entry), (int)HvMAX(keys)+1,