X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2b32fed87e17d7b5d5ecf7d79a2f7cfd1dfd5d26..4b05bc8ea5a106c203e7154f3cbae72e133c9c80:/doop.c diff --git a/doop.c b/doop.c index 3ed63f6..18bc067 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" @@ -619,18 +619,18 @@ I32 Perl_do_trans(pTHX_ SV *sv) { STRLEN len; - const I32 hasutf = (PL_op->op_private & - (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); + const I32 flags = PL_op->op_private; + const I32 hasutf = flags & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF); PERL_ARGS_ASSERT_DO_TRANS; - if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) { - Perl_croak_no_modify(); + if (SvREADONLY(sv) && !(flags & OPpTRANS_IDENTICAL)) { + Perl_croak_no_modify(); } (void)SvPV_const(sv, len); if (!len) return 0; - if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) { + if (!(flags & OPpTRANS_IDENTICAL)) { if (!SvPOKp(sv) || SvTHINKFIRST(sv)) (void)SvPV_force_nomg(sv, len); (void)SvPOK_only_UTF8(sv); @@ -638,27 +638,15 @@ Perl_do_trans(pTHX_ SV *sv) DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); - switch (PL_op->op_private & ~hasutf & ( - OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL| - OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { - case 0: - if (hasutf) - return do_trans_simple_utf8(sv); - else - return do_trans_simple(sv); - - case OPpTRANS_IDENTICAL: - case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT: - if (hasutf) - return do_trans_count_utf8(sv); - else - return do_trans_count(sv); - - default: - if (hasutf) - return do_trans_complex_utf8(sv); - else - return do_trans_complex(sv); + /* If we use only OPpTRANS_IDENTICAL to bypass the READONLY check, + * we must also rely on it to choose the readonly strategy. + */ + if (flags & OPpTRANS_IDENTICAL) { + return hasutf ? do_trans_count_utf8(sv) : do_trans_count(sv); + } else if (flags & (OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { + return hasutf ? do_trans_complex_utf8(sv) : do_trans_complex(sv); + } else { + return hasutf ? do_trans_simple_utf8(sv) : do_trans_simple(sv); } } @@ -692,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); @@ -756,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 *) @@ -771,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"); @@ -786,29 +772,37 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) 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); @@ -822,34 +816,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) + @@ -912,7 +905,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; @@ -920,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, @@ -938,9 +941,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"); @@ -948,14 +950,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) { @@ -1014,12 +1022,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); } @@ -1029,7 +1038,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); @@ -1076,16 +1085,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; @@ -1094,13 +1103,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; @@ -1109,10 +1127,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; @@ -1121,6 +1146,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) @@ -1210,16 +1240,24 @@ 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; } } -finish: + finish: SvTAINT(sv); } @@ -1232,11 +1270,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 */ @@ -1267,7 +1310,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) { @@ -1275,8 +1328,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, @@ -1288,11 +1340,5 @@ Perl_do_kv(pTHX) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */