X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f0ee386351fbbf1a41ead86e9163f688d1b37dc1..6fa2dc60899234df7bde728354b58afa2779105e:/doop.c diff --git a/doop.c b/doop.c index 007ff5e..dbf26d6 100644 --- a/doop.c +++ b/doop.c @@ -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); } } @@ -669,12 +657,10 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) I32 items = sp - mark; STRLEN len; STRLEN delimlen; + const char * const delims = SvPV_const(delim, delimlen); PERL_ARGS_ASSERT_DO_JOIN; - (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */ - /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */ - mark++; len = (items > 0 ? (delimlen * (items - 1) ) : 0); SvUPGRADE(sv, SVt_PV); @@ -708,10 +694,11 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) } if (delimlen) { + const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES; for (; items > 0; items--,mark++) { STRLEN len; const char *s; - sv_catsv_nomg(sv,delim); + sv_catpvn_flags(sv,delims,delimlen,delimflag); s = SvPV_const(*mark,len); sv_catpvn_flags(sv,s,len, DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); @@ -1015,6 +1002,7 @@ 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; @@ -1030,7 +1018,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); @@ -1095,6 +1083,12 @@ 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); @@ -1110,6 +1104,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; + } } goto mop_up_utf; case OP_BIT_OR: @@ -1122,6 +1121,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) @@ -1220,7 +1224,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) break; } } -finish: + finish: SvTAINT(sv); } @@ -1233,11 +1237,12 @@ Perl_do_kv(pTHX) dSP; HV * const keys = MUTABLE_HV(POPs); HE *entry; + SSize_t extend_size; const I32 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); + const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES); (void)hv_iterinit(keys); /* always reset iterator regardless */ @@ -1268,37 +1273,28 @@ Perl_do_kv(pTHX) RETURN; } - EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues)); + /* 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); - PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */ while ((entry = hv_iternext(keys))) { - SPAGAIN; if (dokeys) { SV* const sv = hv_iterkeysv(entry); - XPUSHs(sv); /* won't clobber stack_sp */ + XPUSHs(sv); } if (dovalues) { - SV *tmpstr; - PUTBACK; - 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, (unsigned long)(HeHASH(entry) & HvMAX(keys)))); - SPAGAIN; XPUSHs(tmpstr); } - PUTBACK; } - return NORMAL; + RETURN; } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */