X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e80717e766f2b07e86266e546391d45f27bd6fb3..6a2e93d94928fd304ef9a1821ad2e0eb8adfccb3:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index eebed8c..c693b30 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -34,6 +34,7 @@ #include "EXTERN.h" #define PERL_IN_PP_HOT_C #include "perl.h" +#include "regcomp.h" /* Hot code. */ @@ -59,9 +60,9 @@ PP(pp_gvsv) dSP; EXTEND(SP,1); if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) - PUSHs(save_scalar(cGVOP_gv)); + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSVn(cGVOP_gv)); + PUSHs(GvSVn(cGVOP_gv)); RETURN; } @@ -106,19 +107,19 @@ PP(pp_and) { PERL_ASYNC_CHECK(); { - /* SP is not used to remove a variable that is saved across the - sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine - register or load/store vs direct mem ops macro is introduced, this - should be a define block between direct PL_stack_sp and dSP operations, - presently, using PL_stack_sp is bias towards CISC cpus */ - SV * const sv = *PL_stack_sp; - if (!SvTRUE_NN(sv)) - return NORMAL; - else { - if (PL_op->op_type == OP_AND) - --PL_stack_sp; - return cLOGOP->op_other; - } + /* SP is not used to remove a variable that is saved across the + sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine + register or load/store vs direct mem ops macro is introduced, this + should be a define block between direct PL_stack_sp and dSP operations, + presently, using PL_stack_sp is bias towards CISC cpus */ + SV * const sv = *PL_stack_sp; + if (!SvTRUE_NN(sv)) + return NORMAL; + else { + if (PL_op->op_type == OP_AND) + --PL_stack_sp; + return cLOGOP->op_other; + } } } @@ -131,98 +132,98 @@ PP(pp_sassign) SV *left = POPs; SV *right = TOPs; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */ - SV * const temp = left; - left = right; right = temp; + SV * const temp = left; + left = right; right = temp; } assert(TAINTING_get || !TAINT_get); if (UNLIKELY(TAINT_get) && !SvTAINTED(right)) - TAINT_NOT; + TAINT_NOT; if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) { /* *foo =\&bar */ - SV * const cv = SvRV(right); - const U32 cv_type = SvTYPE(cv); - const bool is_gv = isGV_with_GP(left); - const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; - - if (!got_coderef) { - assert(SvROK(cv)); - } - - /* Can do the optimisation if left (LVALUE) is not a typeglob, - right (RVALUE) is a reference to something, and we're in void - context. */ - if (!got_coderef && !is_gv && GIMME_V == G_VOID) { - /* Is the target symbol table currently empty? */ - GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV); - if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { - /* Good. Create a new proxy constant subroutine in the target. - The gv becomes a(nother) reference to the constant. */ - SV *const value = SvRV(cv); - - SvUPGRADE(MUTABLE_SV(gv), SVt_IV); - SvPCS_IMPORTED_on(gv); - SvRV_set(gv, value); - SvREFCNT_inc_simple_void(value); - SETs(left); - RETURN; - } - } - - /* Need to fix things up. */ - if (!is_gv) { - /* Need to fix GV. */ - left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV)); - } - - if (!got_coderef) { - /* We've been returned a constant rather than a full subroutine, - but they expect a subroutine reference to apply. */ - if (SvROK(cv)) { - ENTER_with_name("sassign_coderef"); - SvREFCNT_inc_void(SvRV(cv)); - /* newCONSTSUB takes a reference count on the passed in SV - from us. We set the name to NULL, otherwise we get into - all sorts of fun as the reference to our new sub is - donated to the GV that we're about to assign to. - */ - SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, - SvRV(cv)))); - SvREFCNT_dec_NN(cv); - LEAVE_with_name("sassign_coderef"); - } else { - /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; - is that - First: ops for \&{"BONK"}; return us the constant in the - symbol table - Second: ops for *{"BONK"} cause that symbol table entry - (and our reference to it) to be upgraded from RV - to typeblob) - Thirdly: We get here. cv is actually PVGV now, and its - GvCV() is actually the subroutine we're looking for - - So change the reference so that it points to the subroutine - of that typeglob, as that's what they were after all along. - */ - GV *const upgraded = MUTABLE_GV(cv); - CV *const source = GvCV(upgraded); - - assert(source); - assert(CvFLAGS(source) & CVf_CONST); - - SvREFCNT_inc_simple_void_NN(source); - SvREFCNT_dec_NN(upgraded); - SvRV_set(right, MUTABLE_SV(source)); - } - } + SV * const cv = SvRV(right); + const U32 cv_type = SvTYPE(cv); + const bool is_gv = isGV_with_GP(left); + const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; + + if (!got_coderef) { + assert(SvROK(cv)); + } + + /* Can do the optimisation if left (LVALUE) is not a typeglob, + right (RVALUE) is a reference to something, and we're in void + context. */ + if (!got_coderef && !is_gv && GIMME_V == G_VOID) { + /* Is the target symbol table currently empty? */ + GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV); + if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { + /* Good. Create a new proxy constant subroutine in the target. + The gv becomes a(nother) reference to the constant. */ + SV *const value = SvRV(cv); + + SvUPGRADE(MUTABLE_SV(gv), SVt_IV); + SvPCS_IMPORTED_on(gv); + SvRV_set(gv, value); + SvREFCNT_inc_simple_void(value); + SETs(left); + RETURN; + } + } + + /* Need to fix things up. */ + if (!is_gv) { + /* Need to fix GV. */ + left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV)); + } + + if (!got_coderef) { + /* We've been returned a constant rather than a full subroutine, + but they expect a subroutine reference to apply. */ + if (SvROK(cv)) { + ENTER_with_name("sassign_coderef"); + SvREFCNT_inc_void(SvRV(cv)); + /* newCONSTSUB takes a reference count on the passed in SV + from us. We set the name to NULL, otherwise we get into + all sorts of fun as the reference to our new sub is + donated to the GV that we're about to assign to. + */ + SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, + SvRV(cv)))); + SvREFCNT_dec_NN(cv); + LEAVE_with_name("sassign_coderef"); + } else { + /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; + is that + First: ops for \&{"BONK"}; return us the constant in the + symbol table + Second: ops for *{"BONK"} cause that symbol table entry + (and our reference to it) to be upgraded from RV + to typeblob) + Thirdly: We get here. cv is actually PVGV now, and its + GvCV() is actually the subroutine we're looking for + + So change the reference so that it points to the subroutine + of that typeglob, as that's what they were after all along. + */ + GV *const upgraded = MUTABLE_GV(cv); + CV *const source = GvCV(upgraded); + + assert(source); + assert(CvFLAGS(source) & CVf_CONST); + + SvREFCNT_inc_simple_void_NN(source); + SvREFCNT_dec_NN(upgraded); + SvRV_set(right, MUTABLE_SV(source)); + } + } } if ( UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 && (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC) ) - Perl_warner(aTHX_ - packWARN(WARN_MISC), "Useless assignment to a temporary" - ); + Perl_warner(aTHX_ + packWARN(WARN_MISC), "Useless assignment to a temporary" + ); SvSetMagicSV(left, right); SETs(left); RETURN; @@ -248,16 +249,22 @@ PP(pp_unstack) FREETMPS; if (!(PL_op->op_flags & OPf_SPECIAL)) { assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx)); - CX_LEAVE_SCOPE(cx); + CX_LEAVE_SCOPE(cx); } return NORMAL; } -PP(pp_concat) + +/* The main body of pp_concat, not including the magic/overload and + * stack handling. + * It does targ = left . right. + * Moved into a separate function so that pp_multiconcat() can use it + * too. + */ + +PERL_STATIC_INLINE void +S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy) { - dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); - { - dPOPTOPssrl; bool lbyte; STRLEN rlen; const char *rpv = NULL; @@ -265,61 +272,852 @@ PP(pp_concat) bool rcopied = FALSE; if (TARG == right && right != left) { /* $r = $l.$r */ - rpv = SvPV_nomg_const(right, rlen); - rbyte = !DO_UTF8(right); - right = newSVpvn_flags(rpv, rlen, SVs_TEMP); - rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ - rcopied = TRUE; + rpv = SvPV_nomg_const(right, rlen); + rbyte = !DO_UTF8(right); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); + rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ + rcopied = TRUE; } if (TARG != left) { /* not $l .= $r */ STRLEN llen; const char* const lpv = SvPV_nomg_const(left, llen); - lbyte = !DO_UTF8(left); - sv_setpvn(TARG, lpv, llen); - if (!lbyte) - SvUTF8_on(TARG); - else - SvUTF8_off(TARG); + lbyte = !DO_UTF8(left); + sv_setpvn(TARG, lpv, llen); + if (!lbyte) + SvUTF8_on(TARG); + else + SvUTF8_off(TARG); } else { /* $l .= $r and left == TARG */ - if (!SvOK(left)) { + if (!SvOK(left)) { if ((left == right /* $l .= $l */ - || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */ + || targmy) /* $l = $l . $r */ && ckWARN(WARN_UNINITIALIZED) ) report_uninit(left); SvPVCLEAR(left); - } + } else { SvPV_force_nomg_nolen(left); } - lbyte = !DO_UTF8(left); - if (IN_BYTES) - SvUTF8_off(left); + lbyte = !DO_UTF8(left); + if (IN_BYTES) + SvUTF8_off(left); } if (!rcopied) { - rpv = SvPV_nomg_const(right, rlen); - rbyte = !DO_UTF8(right); + rpv = SvPV_nomg_const(right, rlen); + rbyte = !DO_UTF8(right); } if (lbyte != rbyte) { - if (lbyte) - sv_utf8_upgrade_nomg(TARG); - else { - if (!rcopied) - right = newSVpvn_flags(rpv, rlen, SVs_TEMP); - sv_utf8_upgrade_nomg(right); - rpv = SvPV_nomg_const(right, rlen); - } + if (lbyte) + sv_utf8_upgrade_nomg(TARG); + else { + if (!rcopied) + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); + sv_utf8_upgrade_nomg(right); + rpv = SvPV_nomg_const(right, rlen); + } } sv_catpvn_nomg(TARG, rpv, rlen); + SvSETMAGIC(TARG); +} - SETTARG; + +PP(pp_concat) +{ + dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); + { + dPOPTOPssrl; + S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY); + SETs(TARG); RETURN; } } + +/* pp_multiconcat() + +Concatenate one or more args, possibly interleaved with constant string +segments. The result may be assigned to, or appended to, a variable or +expression. + +Several op_flags and/or op_private bits indicate what the target is, and +whether it's appended to. Valid permutations are: + + - (PADTMP) = (A.B.C....) + OPpTARGET_MY $lex = (A.B.C....) + OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....) + OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....) + OPf_STACKED expr = (A.B.C....) + OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....) + +Other combinations like (A.B).(C.D) are not optimised into a multiconcat +op, as it's too hard to get the correct ordering of ties, overload etc. + +In addition: + + OPpMULTICONCAT_FAKE: not a real concat, instead an optimised + sprintf "...%s...". Don't call '.' + overloading: only use '""' overloading. + + OPpMULTICONCAT_STRINGIFY: the RHS was of the form + "...$a...$b..." rather than + "..." . $a . "..." . $b . "..." + +An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are +defined with PERL_MULTICONCAT_IX_FOO constants, where: + + + FOO index description + -------- ----- ---------------------------------- + NARGS 0 number of arguments + PLAIN_PV 1 non-utf8 constant string + PLAIN_LEN 2 non-utf8 constant string length + UTF8_PV 3 utf8 constant string + UTF8_LEN 4 utf8 constant string length + LENGTHS 5 first of nargs+1 const segment lengths + +The idea is that a general string concatenation will have a fixed (known +at compile time) number of variable args, interspersed with constant +strings, e.g. "a=$a b=$b\n" + +All the constant string segments "a=", " b=" and "\n" are stored as a +single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along +with a series of segment lengths: e.g. 2,3,1. In the case where the +constant string is plain but has a different utf8 representation, both +variants are stored, and two sets of (nargs+1) segments lengths are stored +in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS. + +A segment length of -1 indicates that there is no constant string at that +point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which +have differing overloading behaviour. + +*/ + +PP(pp_multiconcat) +{ + dSP; + SV *targ; /* The SV to be assigned or appended to */ + char *targ_pv; /* where within SvPVX(targ) we're writing to */ + STRLEN targ_len; /* SvCUR(targ) */ + SV **toparg; /* the highest arg position on the stack */ + UNOP_AUX_item *aux; /* PL_op->op_aux buffer */ + UNOP_AUX_item *const_lens; /* the segment length array part of aux */ + const char *const_pv; /* the current segment of the const string buf */ + SSize_t nargs; /* how many args were expected */ + SSize_t stack_adj; /* how much to adjust SP on return */ + STRLEN grow; /* final size of destination string (targ) */ + UV targ_count; /* how many times targ has appeared on the RHS */ + bool is_append; /* OPpMULTICONCAT_APPEND flag is set */ + bool slow_concat; /* args too complex for quick concat */ + U32 dst_utf8; /* the result will be utf8 (indicate this with + SVf_UTF8 in a U32, rather than using bool, + for ease of testing and setting) */ + /* for each arg, holds the result of an SvPV() call */ + struct multiconcat_svpv { + const char *pv; + SSize_t len; + } + *targ_chain, /* chain of slots where targ has appeared on RHS */ + *svpv_p, /* ptr for looping through svpv_buf */ + *svpv_base, /* first slot (may be greater than svpv_buf), */ + *svpv_end, /* and slot after highest result so far, of: */ + svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */ + + aux = cUNOP_AUXx(PL_op)->op_aux; + stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; + is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND); + + /* get targ from the stack or pad */ + + if (PL_op->op_flags & OPf_STACKED) { + if (is_append) { + /* for 'expr .= ...', expr is the bottom item on the stack */ + targ = SP[-nargs]; + stack_adj++; + } + else + /* for 'expr = ...', expr is the top item on the stack */ + targ = POPs; + } + else { + SV **svp = &(PAD_SVl(PL_op->op_targ)); + targ = *svp; + if (PL_op->op_private & OPpLVAL_INTRO) { + assert(PL_op->op_private & OPpTARGET_MY); + save_clearsv(svp); + } + if (!nargs) + /* $lex .= "const" doesn't cause anything to be pushed */ + EXTEND(SP,1); + } + + toparg = SP; + SP -= (nargs - 1); + grow = 1; /* allow for '\0' at minimum */ + targ_count = 0; + targ_chain = NULL; + targ_len = 0; + svpv_end = svpv_buf; + /* only utf8 variants of the const strings? */ + dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8; + + + /* -------------------------------------------------------------- + * Phase 1: + * + * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8 + * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths. + * + * utf8 is indicated by storing a negative length. + * + * Where an arg is actually targ, the stringification is deferred: + * the length is set to 0, and the slot is added to targ_chain. + * + * If a magic, overloaded, or otherwise weird arg is found, which + * might have side effects when stringified, the loop is abandoned and + * we goto a code block where a more basic 'emulate calling + * pp_cpncat() on each arg in turn' is done. + */ + + for (; SP <= toparg; SP++, svpv_end++) { + U32 utf8; + STRLEN len; + SV *sv; + + assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG); + + sv = *SP; + + /* this if/else chain is arranged so that common/simple cases + * take few conditionals */ + + if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) { + /* common case: sv is a simple non-magical PV */ + if (targ == sv) { + /* targ appears on RHS. + * Delay storing PV pointer; instead, add slot to targ_chain + * so it can be populated later, after targ has been grown and + * we know its final SvPVX() address. + */ + targ_on_rhs: + svpv_end->len = 0; /* zerojng here means we can skip + updating later if targ_len == 0 */ + svpv_end->pv = (char*)targ_chain; + targ_chain = svpv_end; + targ_count++; + continue; + } + + len = SvCUR(sv); + svpv_end->pv = SvPVX(sv); + } + else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) + /* may have side effects: tie, overload etc. + * Abandon 'stringify everything first' and handle + * args in strict order. Note that already-stringified args + * will be reprocessed, which is safe because the each first + * stringification would have been idempotent. + */ + goto do_magical; + else if (SvNIOK(sv)) { + if (targ == sv) + goto targ_on_rhs; + /* stringify general valid scalar */ + svpv_end->pv = sv_2pv_flags(sv, &len, 0); + } + else if (!SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + /* an undef value in the presence of warnings may trigger + * side affects */ + goto do_magical; + svpv_end->pv = ""; + len = 0; + } + else + goto do_magical; /* something weird */ + + utf8 = (SvFLAGS(sv) & SVf_UTF8); + dst_utf8 |= utf8; + ASSUME(len < SSize_t_MAX); + svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len; + grow += len; + } + + /* -------------------------------------------------------------- + * Phase 2: + * + * Stringify targ: + * + * if targ appears on the RHS or is appended to, force stringify it; + * otherwise set it to "". Then set targ_len. + */ + + if (is_append) { + /* abandon quick route if using targ might have side effects */ + if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) + goto do_magical; + + if (SvOK(targ)) { + U32 targ_utf8; + stringify_targ: + SvPV_force_nomg_nolen(targ); + targ_utf8 = SvFLAGS(targ) & SVf_UTF8; + if (UNLIKELY(dst_utf8 & ~targ_utf8)) { + if (LIKELY(!IN_BYTES)) + sv_utf8_upgrade_nomg(targ); + } + else + dst_utf8 |= targ_utf8; + + targ_len = SvCUR(targ); + grow += targ_len * (targ_count + is_append); + goto phase3; + } + else if (ckWARN(WARN_UNINITIALIZED)) + /* warning might have side effects */ + goto do_magical; + /* the undef targ will be silently SvPVCLEAR()ed below */ + } + else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) { + /* Assigning to some weird LHS type. Don't force the LHS to be an + * empty string; instead, do things 'long hand' by using the + * overload code path, which concats to a TEMP sv and does + * sv_catsv() calls rather than COPY()s. This ensures that even + * bizarre code like this doesn't break or crash: + * *F = *F . *F. + * (which makes the 'F' typeglob an alias to the + * '*main::F*main::F' typeglob). + */ + goto do_magical; + } + else if (targ_chain) + /* targ was found on RHS. + * Force stringify it, using the same code as the append branch + * above, except that we don't need the magic/overload/undef + * checks as these will already have been done in the phase 1 + * loop. + */ + goto stringify_targ; + + /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0; + * those will be done later. */ + SV_CHECK_THINKFIRST_COW_DROP(targ); + SvUPGRADE(targ, SVt_PV); + SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8); + SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8); + + phase3: + + /* -------------------------------------------------------------- + * Phase 3: + * + * UTF-8 tweaks and grow targ: + * + * Now that we know the length and utf8-ness of both the targ and + * args, grow targ to the size needed to accumulate all the args, based + * on whether targ appears on the RHS, whether we're appending, and + * whether any non-utf8 args expand in size if converted to utf8. + * + * For the latter, if dst_utf8 we scan non-utf8 args looking for + * variant chars, and adjust the svpv->len value of those args to the + * utf8 size and negate it to flag them. At the same time we un-negate + * the lens of any utf8 args since after this phase we no longer care + * whether an arg is utf8 or not. + * + * Finally, initialise const_lens and const_pv based on utf8ness. + * Note that there are 3 permutations: + * + * * If the constant string is invariant whether utf8 or not (e.g. "abc"), + * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as + * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of + * segment lengths. + * + * * If the string is fully utf8, e.g. "\x{100}", then + * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is + * one set of segment lengths. + * + * * If the string has different plain and utf8 representations + * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]] + * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] + * holds the utf8 rep, and there are 2 sets of segment lengths, + * with the utf8 set following after the plain set. + * + * On entry to this section the (pv,len) pairs in svpv_buf have the + * following meanings: + * (pv, len) a plain string + * (pv, -len) a utf8 string + * (NULL, 0) left-most targ \ linked together R-to-L + * (next, 0) other targ / in targ_chain + */ + + /* turn off utf8 handling if 'use bytes' is in scope */ + if (UNLIKELY(dst_utf8 && IN_BYTES)) { + dst_utf8 = 0; + SvUTF8_off(targ); + /* undo all the negative lengths which flag utf8-ness */ + for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { + SSize_t len = svpv_p->len; + if (len < 0) + svpv_p->len = -len; + } + } + + /* grow += total of lengths of constant string segments */ + { + SSize_t len; + len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN + : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; + slow_concat = cBOOL(len); + grow += len; + } + + const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS; + + if (dst_utf8) { + const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; + if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv + && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv) + /* separate sets of lengths for plain and utf8 */ + const_lens += nargs + 1; + + /* If the result is utf8 but some of the args aren't, + * calculate how much extra growth is needed for all the chars + * which will expand to two utf8 bytes. + * Also, if the growth is non-zero, negate the length to indicate + * that this is a variant string. Conversely, un-negate the + * length on utf8 args (which was only needed to flag non-utf8 + * args in this loop */ + for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { + SSize_t len, extra; + + len = svpv_p->len; + if (len <= 0) { + svpv_p->len = -len; + continue; + } + + extra = variant_under_utf8_count((U8 *) svpv_p->pv, + (U8 *) svpv_p->pv + len); + if (UNLIKELY(extra)) { + grow += extra; + /* -ve len indicates special handling */ + svpv_p->len = -(len + extra); + slow_concat = TRUE; + } + } + } + else + const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; + + /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should + * already have been dropped */ + assert(!SvIsCOW(targ)); + targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ)); + + + /* -------------------------------------------------------------- + * Phase 4: + * + * Now that targ has been grown, we know the final address of the targ + * PVX, if needed. Preserve / move targ contents if appending or if + * targ appears on RHS. + * + * Also update svpv_buf slots in targ_chain. + * + * Don't bother with any of this if the target length is zero: + * targ_len is set to zero unless we're appending or targ appears on + * RHS. And even if it is, we can optimise by skipping this chunk of + * code for zero targ_len. In the latter case, we don't need to update + * the slots in targ_chain with the (zero length) target string, since + * we set the len in such slots to 0 earlier, and since the Copy() is + * skipped on zero length, it doesn't matter what svpv_p->pv contains. + * + * On entry to this section the (pv,len) pairs in svpv_buf have the + * following meanings: + * (pv, len) a pure-plain or utf8 string + * (pv, -(len+extra)) a plain string which will expand by 'extra' + * bytes when converted to utf8 + * (NULL, 0) left-most targ \ linked together R-to-L + * (next, 0) other targ / in targ_chain + * + * On exit, the targ contents will have been moved to the + * earliest place they are needed (e.g. $x = "abc$x" will shift them + * 3 bytes, while $x .= ... will leave them at the beginning); + * and dst_pv will point to the location within SvPVX(targ) where the + * next arg should be copied. + */ + + svpv_base = svpv_buf; + + if (targ_len) { + struct multiconcat_svpv *tc_stop; + char *targ_buf = targ_pv; /* ptr to original targ string */ + + assert(is_append || targ_count); + + if (is_append) { + targ_pv += targ_len; + tc_stop = NULL; + } + else { + /* The targ appears on RHS, e.g. '$t = $a . $t . $t'. + * Move the current contents of targ to the first + * position where it's needed, and use that as the src buffer + * for any further uses (such as the second RHS $t above). + * In calculating the first position, we need to sum the + * lengths of all consts and args before that. + */ + + UNOP_AUX_item *lens = const_lens; + /* length of first const string segment */ + STRLEN offset = lens->ssize > 0 ? lens->ssize : 0; + + assert(targ_chain); + svpv_p = svpv_base; + + for (;;) { + SSize_t len; + if (!svpv_p->pv) + break; /* the first targ argument */ + /* add lengths of the next arg and const string segment */ + len = svpv_p->len; + if (len < 0) /* variant args have this */ + len = -len; + offset += (STRLEN)len; + len = (++lens)->ssize; + offset += (len >= 0) ? (STRLEN)len : 0; + if (!offset) { + /* all args and consts so far are empty; update + * the start position for the concat later */ + svpv_base++; + const_lens++; + } + svpv_p++; + assert(svpv_p < svpv_end); + } + + if (offset) { + targ_buf += offset; + Move(targ_pv, targ_buf, targ_len, char); + /* a negative length implies don't Copy(), but do increment */ + svpv_p->len = -((SSize_t)targ_len); + slow_concat = TRUE; + } + else { + /* skip the first targ copy */ + svpv_base++; + const_lens++; + targ_pv += targ_len; + } + + /* Don't populate the first targ slot in the loop below; it's + * either not used because we advanced svpv_base beyond it, or + * we already stored the special -targ_len value in it + */ + tc_stop = svpv_p; + } + + /* populate slots in svpv_buf representing targ on RHS */ + while (targ_chain != tc_stop) { + struct multiconcat_svpv *p = targ_chain; + targ_chain = (struct multiconcat_svpv *)(p->pv); + p->pv = targ_buf; + p->len = (SSize_t)targ_len; + } + } + + + /* -------------------------------------------------------------- + * Phase 5: + * + * Append all the args in svpv_buf, plus the const strings, to targ. + * + * On entry to this section the (pv,len) pairs in svpv_buf have the + * following meanings: + * (pv, len) a pure-plain or utf8 string (which may be targ) + * (pv, -(len+extra)) a plain string which will expand by 'extra' + * bytes when converted to utf8 + * (0, -len) left-most targ, whose content has already + * been copied. Just advance targ_pv by len. + */ + + /* If there are no constant strings and no special case args + * (svpv_p->len < 0), use a simpler, more efficient concat loop + */ + if (!slow_concat) { + for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) { + SSize_t len = svpv_p->len; + if (!len) + continue; + Copy(svpv_p->pv, targ_pv, len, char); + targ_pv += len; + } + const_lens += (svpv_end - svpv_base + 1); + } + else { + /* Note that we iterate the loop nargs+1 times: to append nargs + * arguments and nargs+1 constant strings. For example, "-$a-$b-" + */ + svpv_p = svpv_base - 1; + + for (;;) { + SSize_t len = (const_lens++)->ssize; + + /* append next const string segment */ + if (len > 0) { + Copy(const_pv, targ_pv, len, char); + targ_pv += len; + const_pv += len; + } + + if (++svpv_p == svpv_end) + break; + + /* append next arg */ + len = svpv_p->len; + + if (LIKELY(len > 0)) { + Copy(svpv_p->pv, targ_pv, len, char); + targ_pv += len; + } + else if (UNLIKELY(len < 0)) { + /* negative length indicates two special cases */ + const char *p = svpv_p->pv; + len = -len; + if (UNLIKELY(p)) { + /* copy plain-but-variant pv to a utf8 targ */ + char * end_pv = targ_pv + len; + assert(dst_utf8); + while (targ_pv < end_pv) { + U8 c = (U8) *p++; + append_utf8_from_native_byte(c, (U8**)&targ_pv); + } + } + else + /* arg is already-copied targ */ + targ_pv += len; + } + + } + } + + *targ_pv = '\0'; + SvCUR_set(targ, targ_pv - SvPVX(targ)); + assert(grow >= SvCUR(targ) + 1); + assert(SvLEN(targ) >= SvCUR(targ) + 1); + + /* -------------------------------------------------------------- + * Phase 6: + * + * return result + */ + + SP -= stack_adj; + SvTAINT(targ); + SETTARG; + RETURN; + + /* -------------------------------------------------------------- + * Phase 7: + * + * We only get here if any of the args (or targ too in the case of + * append) have something which might cause side effects, such + * as magic, overload, or an undef value in the presence of warnings. + * In that case, any earlier attempt to stringify the args will have + * been abandoned, and we come here instead. + * + * Here, we concat each arg in turn the old-fashioned way: essentially + * emulating pp_concat() in a loop. This means that all the weird edge + * cases will be handled correctly, if not necessarily speedily. + * + * Note that some args may already have been stringified - those are + * processed again, which is safe, since only args without side-effects + * were stringified earlier. + */ + + do_magical: + { + SSize_t i, n; + SV *left = NULL; + SV *right; + SV* nexttarg; + bool nextappend; + U32 utf8 = 0; + SV **svp; + const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; + UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; + Size_t arg_count = 0; /* how many args have been processed */ + + if (!cpv) { + cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; + utf8 = SVf_UTF8; + } + + svp = toparg - nargs + 1; + + /* iterate for: + * nargs arguments, + * plus possible nargs+1 consts, + * plus, if appending, a final targ in an extra last iteration + */ + + n = nargs *2 + 1; + for (i = 0; i <= n; i++) { + SSize_t len; + + /* if necessary, stringify the final RHS result in + * something like $targ .= "$a$b$c" - simulating + * pp_stringify + */ + if ( i == n + && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY) + && !(SvPOK(left)) + /* extra conditions for backwards compatibility: + * probably incorrect, but keep the existing behaviour + * for now. The rules are: + * $x = "$ov" single arg: stringify; + * $x = "$ov$y" multiple args: don't stringify, + * $lex = "$ov$y$z" except TARGMY with at least 2 concats + */ + && ( arg_count == 1 + || ( arg_count >= 3 + && !is_append + && (PL_op->op_private & OPpTARGET_MY) + && !(PL_op->op_private & OPpLVAL_INTRO) + ) + ) + ) + { + SV *tmp = sv_newmortal(); + sv_copypv(tmp, left); + SvSETMAGIC(tmp); + left = tmp; + } + + /* do one extra iteration to handle $targ in $targ .= ... */ + if (i == n && !is_append) + break; + + /* get the next arg SV or regen the next const SV */ + len = lens[i >> 1].ssize; + if (i == n) { + /* handle the final targ .= (....) */ + right = left; + left = targ; + } + else if (i & 1) + right = svp[(i >> 1)]; + else if (len < 0) + continue; /* no const in this position */ + else { + right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP)); + cpv += len; + } + + arg_count++; + + if (arg_count <= 1) { + left = right; + continue; /* need at least two SVs to concat together */ + } + + if (arg_count == 2 && i < n) { + /* for the first concat, create a mortal acting like the + * padtmp from OP_CONST. In later iterations this will + * be appended to */ + nexttarg = sv_newmortal(); + nextappend = FALSE; + } + else { + nexttarg = left; + nextappend = TRUE; + } + + /* Handle possible overloading. + * This is basically an unrolled + * tryAMAGICbin_MG(concat_amg, AMGf_assign); + * and + * Perl_try_amagic_bin() + * call, but using left and right rather than SP[-1], SP[0], + * and not relying on OPf_STACKED implying .= + */ + + if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) { + SvGETMAGIC(left); + if (left != right) + SvGETMAGIC(right); + + if ((SvAMAGIC(left) || SvAMAGIC(right)) + /* sprintf doesn't do concat overloading, + * but allow for $x .= sprintf(...) + */ + && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE) + || i == n) + ) + { + SV * const tmpsv = amagic_call(left, right, concat_amg, + (nextappend ? AMGf_assign: 0)); + if (tmpsv) { + /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test + * here, which isn't needed as any implicit + * assign done under OPpTARGET_MY is done after + * this loop */ + if (nextappend) { + sv_setsv(left, tmpsv); + SvSETMAGIC(left); + } + else + left = tmpsv; + continue; + } + } + + /* if both args are the same magical value, make one a copy */ + if (left == right && SvGMAGICAL(left)) { + left = sv_newmortal(); + /* Print the uninitialized warning now, so it includes the + * variable name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else + sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); + } + } + + /* nexttarg = left . right */ + S_do_concat(aTHX_ left, right, nexttarg, 0); + left = nexttarg; + } + + SP = toparg - stack_adj + 1; + + /* Return the result of all RHS concats, unless this op includes + * an assign ($lex = x.y.z or expr = x.y.z), in which case copy + * to target (which will be $lex or expr). + * If we are appending, targ will already have been appended to in + * the loop */ + if ( !is_append + && ( (PL_op->op_flags & OPf_STACKED) + || (PL_op->op_private & OPpTARGET_MY)) + ) { + sv_setsv(targ, left); + SvSETMAGIC(targ); + } + else + targ = left; + SETs(targ); + RETURN; + } +} + + /* push the elements of av onto the stack. * Returns PL_op->op_next to allow tail-call optimisation of its callers */ @@ -333,14 +1131,22 @@ S_pushav(pTHX_ AV* const av) PADOFFSET i; for (i=0; i < (PADOFFSET)maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); - SP[i+1] = svp ? *svp : &PL_sv_undef; + SP[i+1] = LIKELY(svp) + ? *svp + : UNLIKELY(PL_op->op_flags & OPf_MOD) + ? av_nonelem(av,i) + : &PL_sv_undef; } } else { PADOFFSET i; for (i=0; i < (PADOFFSET)maxarg; i++) { - SV * const sv = AvARRAY(av)[i]; - SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef; + SV *sv = AvARRAY(av)[i]; + SP[i+1] = LIKELY(sv) + ? sv + : UNLIKELY(PL_op->op_flags & OPf_MOD) + ? av_nonelem(av,i) + : &PL_sv_undef; } } SP += maxarg; @@ -401,28 +1207,28 @@ PP(pp_padsv) dSP; EXTEND(SP, 1); { - OP * const op = PL_op; - /* access PL_curpad once */ - SV ** const padentry = &(PAD_SVl(op->op_targ)); - { - dTARG; - TARG = *padentry; - PUSHs(TARG); - PUTBACK; /* no pop/push after this, TOPs ok */ - } - if (op->op_flags & OPf_MOD) { - if (op->op_private & OPpLVAL_INTRO) - if (!(op->op_private & OPpPAD_STATE)) - save_clearsv(padentry); - if (op->op_private & OPpDEREF) { - /* TOPs is equivalent to TARG here. Using TOPs (SP) rather - than TARG reduces the scope of TARG, so it does not - span the call to save_clearsv, resulting in smaller - machine code. */ - TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF); - } - } - return op->op_next; + OP * const op = PL_op; + /* access PL_curpad once */ + SV ** const padentry = &(PAD_SVl(op->op_targ)); + { + dTARG; + TARG = *padentry; + PUSHs(TARG); + PUTBACK; /* no pop/push after this, TOPs ok */ + } + if (op->op_flags & OPf_MOD) { + if (op->op_private & OPpLVAL_INTRO) + if (!(op->op_private & OPpPAD_STATE)) + save_clearsv(padentry); + if (op->op_private & OPpDEREF) { + /* TOPs is equivalent to TARG here. Using TOPs (SP) rather + than TARG reduces the scope of TARG, so it does not + span the call to save_clearsv, resulting in smaller + machine code. */ + TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF); + } + } + return op->op_next; } } @@ -432,25 +1238,22 @@ PP(pp_readline) /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::readline() */ if (TOPs) { - SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + SvGETMAGIC(TOPs); + tryAMAGICunTARGETlist(iter_amg, 0); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; if (!isGV_with_GP(PL_last_in_gv)) { - if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) - PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); - else { - dSP; - XPUSHs(MUTABLE_SV(PL_last_in_gv)); - PUTBACK; - Perl_pp_rv2gv(aTHX); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); - if (PL_last_in_gv == (GV *)&PL_sv_undef) - PL_last_in_gv = NULL; - else - assert(isGV_with_GP(PL_last_in_gv)); - } + if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) + PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); + else { + dSP; + XPUSHs(MUTABLE_SV(PL_last_in_gv)); + PUTBACK; + Perl_pp_rv2gv(aTHX); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv)); + } } return do_readline(); } @@ -459,14 +1262,20 @@ PP(pp_eq) { dSP; SV *left, *right; + U32 flags_and, flags_or; - tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); + tryAMAGICbin_MG(eq_amg, AMGf_numeric); right = POPs; left = TOPs; + flags_and = SvFLAGS(left) & SvFLAGS(right); + flags_or = SvFLAGS(left) | SvFLAGS(right); + SETs(boolSV( - (SvIOK_notUV(left) && SvIOK_notUV(right)) - ? (SvIVX(left) == SvIVX(right)) - : ( do_ncmp(left, right) == 0) + ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) ) + ? (SvIVX(left) == SvIVX(right)) + : (flags_and & SVf_NOK) + ? (SvNVX(left) == SvNVX(right)) + : ( do_ncmp(left, right) == 0) )); RETURN; } @@ -484,10 +1293,10 @@ PP(pp_preinc) == SVf_IOK)) && SvIVX(sv) != IV_MAX) { - SvIV_set(sv, SvIVX(sv) + 1); + SvIV_set(sv, SvIVX(sv) + 1); } else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */ - sv_inc(sv); + sv_inc(sv); SvSETMAGIC(sv); return NORMAL; } @@ -505,10 +1314,10 @@ PP(pp_predec) == SVf_IOK)) && SvIVX(sv) != IV_MIN) { - SvIV_set(sv, SvIVX(sv) - 1); + SvIV_set(sv, SvIVX(sv) - 1); } else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */ - sv_dec(sv); + sv_dec(sv); SvSETMAGIC(sv); return NORMAL; } @@ -523,11 +1332,11 @@ PP(pp_or) PERL_ASYNC_CHECK(); sv = TOPs; if (SvTRUE_NN(sv)) - RETURN; + RETURN; else { - if (PL_op->op_type == OP_OR) + if (PL_op->op_type == OP_OR) --SP; - RETURNOP(cLOGOP->op_other); + RETURNOP(cLOGOP->op_other); } } @@ -543,16 +1352,16 @@ PP(pp_defined) const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); if (is_dor) { - PERL_ASYNC_CHECK(); + PERL_ASYNC_CHECK(); sv = TOPs; if (UNLIKELY(!sv || !SvANY(sv))) { - if (op_type == OP_DOR) - --SP; + if (op_type == OP_DOR) + --SP; RETURNOP(cLOGOP->op_other); } } else { - /* OP_DEFINED */ + /* OP_DEFINED */ sv = POPs; if (UNLIKELY(!sv || !SvANY(sv))) RETPUSHNO; @@ -561,22 +1370,22 @@ PP(pp_defined) defined = FALSE; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - defined = TRUE; - break; + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + defined = TRUE; + break; case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - defined = TRUE; - break; + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + defined = TRUE; + break; case SVt_PVCV: - if (CvROOT(sv) || CvXSUB(sv)) - defined = TRUE; - break; + if (CvROOT(sv) || CvXSUB(sv)) + defined = TRUE; + break; default: - SvGETMAGIC(sv); - if (SvOK(sv)) - defined = TRUE; - break; + SvGETMAGIC(sv); + if (SvOK(sv)) + defined = TRUE; + break; } if (is_dor) { @@ -633,16 +1442,10 @@ PP(pp_add) NV nl = SvNVX(svl); NV nr = SvNVX(svr); - if ( -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) - && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) -#else - nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) -#endif - ) + if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) { /* nothing was lost by converting to IVs */ goto do_iv; + } SP--; TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */ SETs(TARG); @@ -700,101 +1503,103 @@ PP(pp_add) */ if (SvIV_please_nomg(svr)) { - /* Unless the left argument is integer in range we are going to have to - use NV maths. Hence only attempt to coerce the right argument if - we know the left is integer. */ - UV auv = 0; - bool auvok = FALSE; - bool a_valid = 0; - - if (!useleft) { - auv = 0; - a_valid = auvok = 1; - /* left operand is undef, treat as zero. + 0 is identity, - Could SETi or SETu right now, but space optimise by not adding - lots of code to speed up what is probably a rarish case. */ - } else { - /* Left operand is defined, so is it IV? */ - if (SvIV_please_nomg(svl)) { - if ((auvok = SvUOK(svl))) - auv = SvUVX(svl); - else { - const IV aiv = SvIVX(svl); - if (aiv >= 0) { - auv = aiv; - auvok = 1; /* Now acting as a sign flag. */ - } else { - auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); - } - } - a_valid = 1; - } - } - if (a_valid) { - bool result_good = 0; - UV result; - UV buv; - bool buvok = SvUOK(svr); - - if (buvok) - buv = SvUVX(svr); - else { - const IV biv = SvIVX(svr); - if (biv >= 0) { - buv = biv; - buvok = 1; - } else - buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); - } - /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, - else "IV" now, independent of how it came in. - if a, b represents positive, A, B negative, a maps to -A etc - a + b => (a + b) - A + b => -(a - b) - a + B => (a - b) - A + B => -(a + b) - all UV maths. negate result if A negative. - add if signs same, subtract if signs differ. */ - - if (auvok ^ buvok) { - /* Signs differ. */ - if (auv >= buv) { - result = auv - buv; - /* Must get smaller */ - if (result <= auv) - result_good = 1; - } else { - result = buv - auv; - if (result <= buv) { - /* result really should be -(auv-buv). as its negation - of true value, need to swap our result flag */ - auvok = !auvok; - result_good = 1; - } - } - } else { - /* Signs same */ - result = auv + buv; - if (result >= auv) - result_good = 1; - } - if (result_good) { - SP--; - if (auvok) - SETu( result ); - else { - /* Negate result */ - if (result <= (UV)IV_MIN) + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + UV auv = 0; + bool auvok = FALSE; + bool a_valid = 0; + + if (!useleft) { + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. + 0 is identity, + Could SETi or SETu right now, but space optimise by not adding + lots of code to speed up what is probably a rarish case. */ + } else { + /* Left operand is defined, so is it IV? */ + if (SvIV_please_nomg(svl)) { + if ((auvok = SvUOK(svl))) + auv = SvUVX(svl); + else { + const IV aiv = SvIVX(svl); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { + /* Using 0- here and later to silence bogus warning + * from MS VC */ + auv = (UV) (0 - (UV) aiv); + } + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + UV buv; + bool buvok = SvUOK(svr); + + if (buvok) + buv = SvUVX(svr); + else { + const IV biv = SvIVX(svr); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else + buv = (UV) (0 - (UV) biv); + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independent of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a + b => (a + b) + A + b => -(a - b) + a + B => (a - b) + A + B => -(a + b) + all UV maths. negate result if A negative. + add if signs same, subtract if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; + } + } + } else { + /* Signs same */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); - else { - /* result valid, but out of range for IV. */ - SETn( -(NV)result ); - } - } - RETURN; - } /* Overflow, drop through to NVs. */ - } + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ + } } #else @@ -802,15 +1607,15 @@ PP(pp_add) #endif { - NV value = SvNV_nomg(svr); - (void)POPs; - if (!useleft) { - /* left operand is undef, treat as zero. + 0.0 is identity. */ - SETn(value); - RETURN; - } - SETn( value + SvNV_nomg(svl) ); - RETURN; + NV value = SvNV_nomg(svr); + (void)POPs; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + SvNV_nomg(svl) ); + RETURN; } } @@ -821,7 +1626,7 @@ PP(pp_aelemfast) { dSP; AV * const av = PL_op->op_type == OP_AELEMFAST_LEX - ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); + ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); const U32 lval = PL_op->op_flags & OPf_MOD; const I8 key = (I8)PL_op->op_private; SV** svp; @@ -848,7 +1653,7 @@ PP(pp_aelemfast) DIE(aTHX_ PL_no_aelem, (int)key); if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -873,83 +1678,83 @@ PP(pp_print) PerlIO *fp; MAGIC *mg; GV * const gv - = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; IO *io = GvIO(gv); if (io - && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { had_magic: - if (MARK == ORIGMARK) { - /* If using default handle then we need to make space to - * pass object as 1st arg, so move other args up ... - */ - MEXTEND(SP, 1); - ++MARK; - Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); - ++SP; - } - return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), - mg, - (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK - | (PL_op->op_type == OP_SAY - ? TIED_METHOD_SAY : 0)), sp - mark); + if (MARK == ORIGMARK) { + /* If using default handle then we need to make space to + * pass object as 1st arg, so move other args up ... + */ + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), + mg, + (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK + | (PL_op->op_type == OP_SAY + ? TIED_METHOD_SAY : 0)), sp - mark); } if (!io) { if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv))) - && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) goto had_magic; - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - goto just_say_no; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (IoIFP(io)) - report_wrongway_fh(gv, '<'); - else - report_evil_fh(gv); - SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); - goto just_say_no; + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); + goto just_say_no; } else { - SV * const ofs = GvSV(PL_ofsgv); /* $, */ - MARK++; - if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - if (MARK <= SP) { - /* don't use 'ofs' here - it may be invalidated by magic callbacks */ - if (!do_print(GvSV(PL_ofsgv), fp)) { - MARK--; - break; - } - } - } - } - else { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - } - } - if (MARK <= SP) - goto just_say_no; - else { - if (PL_op->op_type == OP_SAY) { - if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) - goto just_say_no; - } + SV * const ofs = GvSV(PL_ofsgv); /* $, */ + MARK++; + if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + if (MARK <= SP) { + /* don't use 'ofs' here - it may be invalidated by magic callbacks */ + if (!do_print(GvSV(PL_ofsgv), fp)) { + MARK--; + break; + } + } + } + } + else { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + } + } + if (MARK <= SP) + goto just_say_no; + else { + if (PL_op->op_type == OP_SAY) { + if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) + goto just_say_no; + } else if (PL_ors_sv && SvOK(PL_ors_sv)) - if (!do_print(PL_ors_sv, fp)) /* $\ */ - goto just_say_no; + if (!do_print(PL_ors_sv, fp)) /* $\ */ + goto just_say_no; - if (IoFLAGS(io) & IOf_FLUSH) - if (PerlIO_flush(fp) == EOF) - goto just_say_no; - } + if (IoFLAGS(io) & IOf_FLUSH) + if (PerlIO_flush(fp) == EOF) + goto just_say_no; + } } SP = ORIGMARK; XPUSHs(&PL_sv_yes); @@ -982,8 +1787,8 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV); - if (gimme == G_ARRAY) { - hv_pushkv(hv); + if (gimme == G_LIST) { + hv_pushkv(hv, 3); return NORMAL; } @@ -991,6 +1796,9 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) /* 'keys %h' masquerading as '%h': reset iterator */ (void)hv_iterinit(hv); + if (gimme == G_VOID) + return NORMAL; + is_bool = ( PL_op->op_private & OPpTRUEBOOL || ( PL_op->op_private & OPpMAYBE_TRUEBOOL && block_gimme() == G_VOID)); @@ -1022,6 +1830,19 @@ S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) PUSHi(i); } else + if (is_keys) { + /* parent op should be an unused OP_KEYS whose targ we can + * use */ + dTARG; + OP *k; + + assert(!OpHAS_SIBLING(PL_op)); + k = PL_op->op_sibparent; + assert(k->op_type == OP_KEYS); + TARG = PAD_SV(k->op_targ); + PUSHi(i); + } + else mPUSHi(i); } } @@ -1038,18 +1859,18 @@ PP(pp_padav) U8 gimme; assert(SvTYPE(TARG) == SVt_PVAV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { - PUSHs(TARG); - RETURN; + PUSHs(TARG); + RETURN; } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME_V == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); PUSHs(TARG); @@ -1058,11 +1879,11 @@ PP(pp_padav) } gimme = GIMME_V; - if (gimme == G_ARRAY) + if (gimme == G_LIST) return S_pushav(aTHX_ (AV*)TARG); if (gimme == G_SCALAR) { - const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; if (!maxarg) PUSHs(&PL_sv_zero); else if (PL_op->op_private & OPpTRUEBOOL) @@ -1081,14 +1902,14 @@ PP(pp_padhv) assert(SvTYPE(TARG) == SVt_PVHV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); - RETURN; + RETURN; } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); @@ -1119,70 +1940,70 @@ PP(pp_rv2av) static const char an_array[] = "an ARRAY"; static const char a_hash[] = "a HASH"; const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV - || PL_op->op_type == OP_LVAVREF; + || PL_op->op_type == OP_LVAVREF; const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; SvGETMAGIC(sv); if (SvROK(sv)) { - if (UNLIKELY(SvAMAGIC(sv))) { - sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); - } - sv = SvRV(sv); - if (UNLIKELY(SvTYPE(sv) != type)) - /* diag_listed_as: Not an ARRAY reference */ - DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); - else if (UNLIKELY(PL_op->op_flags & OPf_MOD - && PL_op->op_private & OPpLVAL_INTRO)) - Perl_croak(aTHX_ "%s", PL_no_localize_ref); + if (UNLIKELY(SvAMAGIC(sv))) { + sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); + } + sv = SvRV(sv); + if (UNLIKELY(SvTYPE(sv) != type)) + /* diag_listed_as: Not an ARRAY reference */ + DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); + else if (UNLIKELY(PL_op->op_flags & OPf_MOD + && PL_op->op_private & OPpLVAL_INTRO)) + Perl_croak(aTHX_ "%s", PL_no_localize_ref); } else if (UNLIKELY(SvTYPE(sv) != type)) { - GV *gv; - - if (!isGV_with_GP(sv)) { - gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, - type, &sp); - if (!gv) - RETURN; - } - else { - gv = MUTABLE_GV(sv); - } - sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv)); - if (PL_op->op_private & OPpLVAL_INTRO) - sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv)); + GV *gv; + + if (!isGV_with_GP(sv)) { + gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, + type, &sp); + if (!gv) + RETURN; + } + else { + gv = MUTABLE_GV(sv); + } + sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv)); + if (PL_op->op_private & OPpLVAL_INTRO) + sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv)); } if (PL_op->op_flags & OPf_REF) { - SETs(sv); - RETURN; + SETs(sv); + RETURN; } else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (gimme != G_ARRAY) - goto croak_cant_return; - SETs(sv); - RETURN; - } + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { + if (gimme != G_LIST) + goto croak_cant_return; + SETs(sv); + RETURN; + } } if (is_pp_rv2av) { - AV *const av = MUTABLE_AV(sv); + AV *const av = MUTABLE_AV(sv); - if (gimme == G_ARRAY) { + if (gimme == G_LIST) { SP--; PUTBACK; return S_pushav(aTHX_ av); - } + } - if (gimme == G_SCALAR) { - const SSize_t maxarg = AvFILL(av) + 1; + if (gimme == G_SCALAR) { + const SSize_t maxarg = AvFILL(av) + 1; if (PL_op->op_private & OPpTRUEBOOL) SETs(maxarg ? &PL_sv_yes : &PL_sv_zero); else { dTARGET; SETi(maxarg); } - } + } } else { SP--; PUTBACK; @@ -1194,7 +2015,7 @@ PP(pp_rv2av) croak_cant_return: Perl_croak(aTHX_ "Can't return %s to lvalue scalar context", - is_pp_rv2av ? "array" : "hash"); + is_pp_rv2av ? "array" : "hash"); RETURN; } @@ -1205,18 +2026,18 @@ S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) if (*oddkey) { if (ckWARN(WARN_MISC)) { - const char *err; - if (oddkey == firstkey && - SvROK(*oddkey) && - (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || - SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) - { - err = "Reference found where even-sized list expected"; - } - else - err = "Odd number of elements in hash assignment"; - Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); - } + const char *err; + if (oddkey == firstkey && + SvROK(*oddkey) && + (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || + SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) + { + err = "Reference found where even-sized list expected"; + } + else + err = "Odd number of elements in hash assignment"; + Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); + } } } @@ -1257,7 +2078,6 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, #endif ) { - dVAR; SV **relem; SV **lelem; SSize_t lcount = lastlelem - firstlelem + 1; @@ -1385,7 +2205,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, PP(pp_aassign) { - dVAR; dSP; + dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -1462,20 +2282,20 @@ PP(pp_aassign) /* first lelem loop while there are still relems */ while (LIKELY(lelem <= lastlelem)) { - bool alias = FALSE; - SV *lsv = *lelem++; + bool alias = FALSE; + SV *lsv = *lelem++; TAINT_NOT; /* Each item stands on its own, taintwise. */ assert(relem <= lastrelem); - if (UNLIKELY(!lsv)) { - alias = TRUE; - lsv = *lelem++; - ASSUME(SvTYPE(lsv) == SVt_PVAV); - } - - switch (SvTYPE(lsv)) { - case SVt_PVAV: { + if (UNLIKELY(!lsv)) { + alias = TRUE; + lsv = *lelem++; + ASSUME(SvTYPE(lsv) == SVt_PVAV); + } + + switch (SvTYPE(lsv)) { + case SVt_PVAV: { SV **svp; SSize_t i; SSize_t tmps_base; @@ -1547,7 +2367,7 @@ PP(pp_aassign) * (or pass through where we can optimise away the copy) */ if (UNLIKELY(alias)) { - U32 lval = (gimme == G_ARRAY) + U32 lval = (gimme == G_LIST) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0; for (svp = relem; svp <= lastrelem; svp++) { SV *rsv = *svp; @@ -1637,16 +2457,16 @@ PP(pp_aassign) PL_tmps_ix -= (nelems + 1); } - if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) + if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) /* its assumed @ISA set magic can't die and leak ary */ - SvSETMAGIC(MUTABLE_SV(ary)); + SvSETMAGIC(MUTABLE_SV(ary)); SvREFCNT_dec_NN(ary); relem = lastrelem + 1; - goto no_relems; + goto no_relems; } - case SVt_PVHV: { /* normal hash */ + case SVt_PVHV: { /* normal hash */ SV **svp; bool dirty_tmps; @@ -1720,7 +2540,7 @@ PP(pp_aassign) /* possibly protect keys */ - if (UNLIKELY(gimme == G_ARRAY)) { + if (UNLIKELY(gimme == G_LIST)) { /* handle e.g. * @a = ((%h = ($$r, 1)), $r = "x"); * $_++ for %h = (1,2,3,4); @@ -1768,7 +2588,7 @@ PP(pp_aassign) dirty_tmps = FALSE; - if (UNLIKELY(gimme == G_ARRAY)) { + if (UNLIKELY(gimme == G_LIST)) { /* @a = (%h = (...)) etc */ SV **svp; SV **topelem = relem; @@ -1848,11 +2668,11 @@ PP(pp_aassign) SvREFCNT_dec_NN(hash); relem = lastrelem + 1; - goto no_relems; - } + goto no_relems; + } - default: - if (!SvIMMORTAL(lsv)) { + default: + if (!SvIMMORTAL(lsv)) { SV *ref; if (UNLIKELY( @@ -1887,7 +2707,7 @@ PP(pp_aassign) } if (++relem > lastrelem) goto no_relems; - break; + break; } /* switch */ } /* while */ @@ -1896,17 +2716,17 @@ PP(pp_aassign) /* simplified lelem loop for when there are no relems left */ while (LIKELY(lelem <= lastlelem)) { - SV *lsv = *lelem++; + SV *lsv = *lelem++; TAINT_NOT; /* Each item stands on its own, taintwise. */ - if (UNLIKELY(!lsv)) { - lsv = *lelem++; - ASSUME(SvTYPE(lsv) == SVt_PVAV); - } + if (UNLIKELY(!lsv)) { + lsv = *lelem++; + ASSUME(SvTYPE(lsv) == SVt_PVAV); + } - switch (SvTYPE(lsv)) { - case SVt_PVAV: + switch (SvTYPE(lsv)) { + case SVt_PVAV: if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) { av_clear((AV*)lsv); if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) @@ -1914,103 +2734,99 @@ PP(pp_aassign) } break; - case SVt_PVHV: + case SVt_PVHV: if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv)) hv_clear((HV*)lsv); break; - default: - if (!SvIMMORTAL(lsv)) { + default: + if (!SvIMMORTAL(lsv)) { sv_set_undef(lsv); SvSETMAGIC(lsv); - *relem++ = lsv; } - break; + *relem++ = lsv; + break; } /* switch */ } /* while */ TAINT_NOT; /* result of list assign isn't tainted */ if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) { - /* Will be used to set PL_tainting below */ - Uid_t tmp_uid = PerlProc_getuid(); - Uid_t tmp_euid = PerlProc_geteuid(); - Gid_t tmp_gid = PerlProc_getgid(); - Gid_t tmp_egid = PerlProc_getegid(); + /* Will be used to set PL_tainting below */ + Uid_t tmp_uid = PerlProc_getuid(); + Uid_t tmp_euid = PerlProc_geteuid(); + Gid_t tmp_gid = PerlProc_getgid(); + Gid_t tmp_egid = PerlProc_getegid(); /* XXX $> et al currently silently ignore failures */ - if (PL_delaymagic & DM_UID) { + if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - PERL_UNUSED_RESULT( + PERL_UNUSED_RESULT( setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1, (Uid_t)-1)); -#else -# ifdef HAS_SETREUID +#elif defined(HAS_SETREUID) PERL_UNUSED_RESULT( setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1)); -# else +#else # ifdef HAS_SETRUID - if ((PL_delaymagic & DM_UID) == DM_RUID) { - PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); - PL_delaymagic &= ~DM_RUID; - } + if ((PL_delaymagic & DM_UID) == DM_RUID) { + PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); + PL_delaymagic &= ~DM_RUID; + } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID - if ((PL_delaymagic & DM_UID) == DM_EUID) { - PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); - PL_delaymagic &= ~DM_EUID; - } + if ((PL_delaymagic & DM_UID) == DM_EUID) { + PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); + PL_delaymagic &= ~DM_EUID; + } # endif /* HAS_SETEUID */ - if (PL_delaymagic & DM_UID) { - if (PL_delaymagic_uid != PL_delaymagic_euid) - DIE(aTHX_ "No setreuid available"); - PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); - } -# endif /* HAS_SETREUID */ + if (PL_delaymagic & DM_UID) { + if (PL_delaymagic_uid != PL_delaymagic_euid) + DIE(aTHX_ "No setreuid available"); + PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); + } #endif /* HAS_SETRESUID */ - tmp_uid = PerlProc_getuid(); - tmp_euid = PerlProc_geteuid(); - } + tmp_uid = PerlProc_getuid(); + tmp_euid = PerlProc_geteuid(); + } /* XXX $> et al currently silently ignore failures */ - if (PL_delaymagic & DM_GID) { + if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - PERL_UNUSED_RESULT( + PERL_UNUSED_RESULT( setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1, (Gid_t)-1)); -#else -# ifdef HAS_SETREGID - PERL_UNUSED_RESULT( +#elif defined(HAS_SETREGID) + PERL_UNUSED_RESULT( setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1)); -# else +#else # ifdef HAS_SETRGID - if ((PL_delaymagic & DM_GID) == DM_RGID) { - PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); - PL_delaymagic &= ~DM_RGID; - } + if ((PL_delaymagic & DM_GID) == DM_RGID) { + PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); + PL_delaymagic &= ~DM_RGID; + } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID - if ((PL_delaymagic & DM_GID) == DM_EGID) { - PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); - PL_delaymagic &= ~DM_EGID; - } + if ((PL_delaymagic & DM_GID) == DM_EGID) { + PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); + PL_delaymagic &= ~DM_EGID; + } # endif /* HAS_SETEGID */ - if (PL_delaymagic & DM_GID) { - if (PL_delaymagic_gid != PL_delaymagic_egid) - DIE(aTHX_ "No setregid available"); - PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); - } -# endif /* HAS_SETREGID */ + if (PL_delaymagic & DM_GID) { + if (PL_delaymagic_gid != PL_delaymagic_egid) + DIE(aTHX_ "No setregid available"); + PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); + } #endif /* HAS_SETRESGID */ - tmp_gid = PerlProc_getgid(); - tmp_egid = PerlProc_getegid(); - } - TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); + tmp_gid = PerlProc_getgid(); + tmp_egid = PerlProc_getegid(); + } + TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(tmp_uid); PERL_UNUSED_VAR(tmp_euid); @@ -2021,9 +2837,9 @@ PP(pp_aassign) PL_delaymagic = old_delaymagic; if (gimme == G_VOID) - SP = firstrelem - 1; + SP = firstrelem - 1; else if (gimme == G_SCALAR) { - SP = firstrelem; + SP = firstrelem; EXTEND(SP,1); if (PL_op->op_private & OPpASSIGN_TRUEBOOL) SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero); @@ -2061,14 +2877,14 @@ PP(pp_qr) cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv); if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) { - *cvp = cv_clone(cv); - SvREFCNT_dec_NN(cv); + *cvp = cv_clone(cv); + SvREFCNT_dec_NN(cv); } if (pkg) { - HV *const stash = gv_stashsv(pkg, GV_ADD); - SvREFCNT_dec_NN(pkg); - (void)sv_bless(rv, stash); + HV *const stash = gv_stashsv(pkg, GV_ADD); + SvREFCNT_dec_NN(pkg); + (void)sv_bless(rv, stash); } if (UNLIKELY(RXp_ISTAINTED(prog))) { @@ -2079,6 +2895,47 @@ PP(pp_qr) RETURN; } +STATIC bool +S_are_we_in_Debug_EXECUTE_r(pTHX) +{ + /* Given a 'use re' is in effect, does it ask for outputting execution + * debug info? + * + * This is separated from the sole place it's called, an inline function, + * because it is the large-ish slow portion of the function */ + + DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX; + + return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK)); +} + +PERL_STATIC_INLINE bool +S_should_we_output_Debug_r(pTHX_ regexp *prog) +{ + PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R; + + /* pp_match can output regex debugging info. This function returns a + * boolean as to whether or not it should. + * + * Under -Dr, it should. Any reasonable compiler will optimize this bit of + * code away on non-debugging builds. */ + if (UNLIKELY(DEBUG_r_TEST)) { + return TRUE; + } + + /* If the regex engine is using the non-debugging execution routine, then + * no debugging should be output. Same if the field is NULL that pluggable + * engines are not supposed to fill. */ + if ( LIKELY(prog->engine->exec == &Perl_regexec_flags) + || UNLIKELY(prog->engine->op_comp == NULL)) + { + return FALSE; + } + + /* Otherwise have to check */ + return S_are_we_in_Debug_EXECUTE_r(aTHX); +} + PP(pp_match) { dSP; dTARG; @@ -2100,27 +2957,27 @@ PP(pp_match) MAGIC *mg = NULL; if (PL_op->op_flags & OPf_STACKED) - TARG = POPs; + TARG = POPs; else { if (ARGTARG) GETTARGET; else { TARG = DEFSV; } - EXTEND(SP,1); + EXTEND(SP,1); } PUTBACK; /* EVAL blocks need stack_sp. */ /* Skip get-magic if this is a qr// clone, because regcomp has already done it. */ truebase = prog->mother_re - ? SvPV_nomg_const(TARG, len) - : SvPV_const(TARG, len); + ? SvPV_nomg_const(TARG, len) + : SvPV_const(TARG, len); if (!truebase) - DIE(aTHX_ "panic: pp_match"); + DIE(aTHX_ "panic: pp_match"); strend = truebase + len; rxtainted = (RXp_ISTAINTED(prog) || - (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); + (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; /* We need to know this in case we fail out early - pos() must be reset */ @@ -2134,8 +2991,10 @@ PP(pp_match) pm->op_pmflags & PMf_USED #endif ) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once")); - goto nope; + if (UNLIKELY(should_we_output_Debug_r(prog))) { + PerlIO_printf(Perl_debug_log, "?? already matched once"); + } + goto nope; } /* handle the empty pattern */ @@ -2156,10 +3015,12 @@ PP(pp_match) } if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%" - UVuf " < %" IVdf ")\n", - (UV)len, (IV)RXp_MINLEN(prog))); - goto nope; + if (UNLIKELY(should_we_output_Debug_r(prog))) { + PerlIO_printf(Perl_debug_log, + "String shorter than min possible regex match (%zd < %zd)\n", + len, RXp_MINLEN(prog)); + } + goto nope; } /* get pos() if //g */ @@ -2181,12 +3042,12 @@ PP(pp_match) ) #endif { - r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); + r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer * only on the first iteration. Therefore we need to copy $' as well * as $&, to make the rest of the string available for captures in * subsequent iterations */ - if (! (global && gimme == G_ARRAY)) + if (! (global && gimme == G_LIST)) r_flags |= REXEC_COPY_SKIP_POST; }; #ifdef PERL_SAWAMPERSAND @@ -2199,27 +3060,27 @@ PP(pp_match) play_it_again: if (global) - s = truebase + curpos; + s = truebase + curpos; if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, - had_zerolen, TARG, NULL, r_flags)) - goto nope; + had_zerolen, TARG, NULL, r_flags)) + goto nope; PL_curpm = pm; if (dynpm->op_pmflags & PMf_ONCE) #ifdef USE_ITHREADS - SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); #else - dynpm->op_pmflags |= PMf_USED; + dynpm->op_pmflags |= PMf_USED; #endif if (rxtainted) - RXp_MATCH_TAINTED_on(prog); + RXp_MATCH_TAINTED_on(prog); TAINT_IF(RXp_MATCH_TAINTED(prog)); /* update pos */ - if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) { + if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) { if (!mg) mg = sv_magicext_mglob(TARG); MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS(prog)[0].end); @@ -2229,50 +3090,50 @@ PP(pp_match) mg->mg_flags &= ~MGf_MINMATCH; } - if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) { - LEAVE_SCOPE(oldsave); - RETPUSHYES; + if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) { + LEAVE_SCOPE(oldsave); + RETPUSHYES; } /* push captures on stack */ { - const I32 nparens = RXp_NPARENS(prog); - I32 i = (global && !nparens) ? 1 : 0; - - SPAGAIN; /* EVAL blocks could move the stack. */ - EXTEND(SP, nparens + i); - EXTEND_MORTAL(nparens + i); - for (i = !i; i <= nparens; i++) { - PUSHs(sv_newmortal()); - if (LIKELY((RXp_OFFS(prog)[i].start != -1) + const I32 nparens = RXp_NPARENS(prog); + I32 i = (global && !nparens) ? 1 : 0; + + SPAGAIN; /* EVAL blocks could move the stack. */ + EXTEND(SP, nparens + i); + EXTEND_MORTAL(nparens + i); + for (i = !i; i <= nparens; i++) { + PUSHs(sv_newmortal()); + if (LIKELY((RXp_OFFS(prog)[i].start != -1) && RXp_OFFS(prog)[i].end != -1 )) { - const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start; - const char * const s = RXp_OFFS(prog)[i].start + truebase; - if (UNLIKELY( RXp_OFFS(prog)[i].end < 0 + const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start; + const char * const s = RXp_OFFS(prog)[i].start + truebase; + if (UNLIKELY( RXp_OFFS(prog)[i].end < 0 || RXp_OFFS(prog)[i].start < 0 || len < 0 || len > strend - s) ) - DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " - "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf, - (long) i, (long) RXp_OFFS(prog)[i].start, - (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len); - sv_setpvn(*SP, s, len); - if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) - SvUTF8_on(*SP); - } - } - if (global) { + DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " + "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf, + (long) i, (long) RXp_OFFS(prog)[i].start, + (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len); + sv_setpvn(*SP, s, len); + if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) + SvUTF8_on(*SP); + } + } + if (global) { curpos = (UV)RXp_OFFS(prog)[0].end; - had_zerolen = RXp_ZERO_LEN(prog); - PUTBACK; /* EVAL blocks may use stack */ - r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; - goto play_it_again; - } - LEAVE_SCOPE(oldsave); - RETURN; + had_zerolen = RXp_ZERO_LEN(prog); + PUTBACK; /* EVAL blocks may use stack */ + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; + goto play_it_again; + } + LEAVE_SCOPE(oldsave); + RETURN; } NOT_REACHED; /* NOTREACHED */ @@ -2284,8 +3145,8 @@ PP(pp_match) mg->mg_len = -1; } LEAVE_SCOPE(oldsave); - if (gimme == G_ARRAY) - RETURN; + if (gimme == G_LIST) + RETURN; RETPUSHNO; } @@ -2302,104 +3163,104 @@ Perl_do_readline(pTHX) const U8 gimme = GIMME_V; if (io) { - const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); - if (gimme == G_SCALAR) { - SPAGAIN; - SvSetSV_nosteal(TARG, TOPs); - SETTARG; - } - return NORMAL; - } + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { + SPAGAIN; + SvSetSV_nosteal(TARG, TOPs); + SETTARG; + } + return NORMAL; + } } fp = NULL; if (io) { - fp = IoIFP(io); - if (!fp) { - if (IoFLAGS(io) & IOf_ARGV) { - if (IoFLAGS(io) & IOf_START) { - IoLINES(io) = 0; - if (av_tindex(GvAVn(PL_last_in_gv)) < 0) { - IoFLAGS(io) &= ~IOf_START; - do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); - SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ - sv_setpvs(GvSVn(PL_last_in_gv), "-"); - SvSETMAGIC(GvSV(PL_last_in_gv)); - fp = IoIFP(io); - goto have_fp; - } - } - fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); - if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ - } - } - else if (type == OP_GLOB) - fp = Perl_start_glob(aTHX_ POPs, io); - } - else if (type == OP_GLOB) - SP--; - else if (IoTYPE(io) == IoTYPE_WRONLY) { - report_wrongway_fh(PL_last_in_gv, '>'); - } + fp = IoIFP(io); + if (!fp) { + if (IoFLAGS(io) & IOf_ARGV) { + if (IoFLAGS(io) & IOf_START) { + IoLINES(io) = 0; + if (av_count(GvAVn(PL_last_in_gv)) == 0) { + IoFLAGS(io) &= ~IOf_START; + do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); + SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ + sv_setpvs(GvSVn(PL_last_in_gv), "-"); + SvSETMAGIC(GvSV(PL_last_in_gv)); + fp = IoIFP(io); + goto have_fp; + } + } + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); + if (!fp) { /* Note: fp != IoIFP(io) */ + (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ + } + } + else if (type == OP_GLOB) + fp = Perl_start_glob(aTHX_ POPs, io); + } + else if (type == OP_GLOB) + SP--; + else if (IoTYPE(io) == IoTYPE_WRONLY) { + report_wrongway_fh(PL_last_in_gv, '>'); + } } if (!fp) { - if ((!io || !(IoFLAGS(io) & IOf_START)) - && ckWARN(WARN_CLOSED) + if ((!io || !(IoFLAGS(io) & IOf_START)) + && ckWARN(WARN_CLOSED) && type != OP_GLOB) - { - report_evil_fh(PL_last_in_gv); - } - if (gimme == G_SCALAR) { - /* undef TARG, and push that undefined value */ - if (type != OP_RCATLINE) { - sv_set_undef(TARG); - } - PUSHTARG; - } - RETURN; + { + report_evil_fh(PL_last_in_gv); + } + if (gimme == G_SCALAR) { + /* undef TARG, and push that undefined value */ + if (type != OP_RCATLINE) { + sv_set_undef(TARG); + } + PUSHTARG; + } + RETURN; } have_fp: if (gimme == G_SCALAR) { - sv = TARG; - if (type == OP_RCATLINE && SvGMAGICAL(sv)) - mg_get(sv); - if (SvROK(sv)) { - if (type == OP_RCATLINE) - SvPV_force_nomg_nolen(sv); - else - sv_unref(sv); - } - else if (isGV_with_GP(sv)) { - SvPV_force_nomg_nolen(sv); - } - SvUPGRADE(sv, SVt_PV); - tmplen = SvLEN(sv); /* remember if already alloced */ - if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { + sv = TARG; + if (type == OP_RCATLINE && SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { + if (type == OP_RCATLINE) + SvPV_force_nomg_nolen(sv); + else + sv_unref(sv); + } + else if (isGV_with_GP(sv)) { + SvPV_force_nomg_nolen(sv); + } + SvUPGRADE(sv, SVt_PV); + tmplen = SvLEN(sv); /* remember if already alloced */ + if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { /* try short-buffering it. Please update t/op/readline.t - * if you change the growth length. - */ - Sv_Grow(sv, 80); - } - offset = 0; - if (type == OP_RCATLINE && SvOK(sv)) { - if (!SvPOK(sv)) { - SvPV_force_nomg_nolen(sv); - } - offset = SvCUR(sv); - } + * if you change the growth length. + */ + Sv_Grow(sv, 80); + } + offset = 0; + if (type == OP_RCATLINE && SvOK(sv)) { + if (!SvPOK(sv)) { + SvPV_force_nomg_nolen(sv); + } + offset = SvCUR(sv); + } } else { - sv = sv_2mortal(newSV(80)); - offset = 0; + sv = sv_2mortal(newSV(80)); + offset = 0; } /* This should not be marked tainted if the fp is marked clean */ #define MAYBE_TAINT_LINE(io, sv) \ if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ - TAINT; \ - SvTAINTED_on(sv); \ + TAINT; \ + SvTAINTED_on(sv); \ } /* delay EOF state for a snarfed empty file */ @@ -2408,93 +3269,93 @@ Perl_do_readline(pTHX) || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { - PUTBACK; - if (!sv_gets(sv, fp, offset) - && (type == OP_GLOB - || SNARF_EOF(gimme, PL_rs, io, sv) - || PerlIO_error(fp))) - { - PerlIO_clearerr(fp); - if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); - if (fp) - continue; - (void)do_close(PL_last_in_gv, FALSE); - } - else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE)) { - Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), - "glob failed (child exited with status %d%s)", - (int)(STATUS_CURRENT >> 8), - (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); - } - } - if (gimme == G_SCALAR) { - if (type != OP_RCATLINE) { - SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); - } - SPAGAIN; - PUSHTARG; - } - MAYBE_TAINT_LINE(io, sv); - RETURN; - } - MAYBE_TAINT_LINE(io, sv); - IoLINES(io)++; - IoFLAGS(io) |= IOf_NOLINE; - SvSETMAGIC(sv); - SPAGAIN; - XPUSHs(sv); - if (type == OP_GLOB) { - const char *t1; - Stat_t statbuf; - - if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { - char * const tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX_const(PL_rs)) { - *tmps = '\0'; - SvCUR_set(sv, SvCUR(sv) - 1); - } - } - for (t1 = SvPVX_const(sv); *t1; t1++) + PUTBACK; + if (!sv_gets(sv, fp, offset) + && (type == OP_GLOB + || SNARF_EOF(gimme, PL_rs, io, sv) + || PerlIO_error(fp))) + { + PerlIO_clearerr(fp); + if (IoFLAGS(io) & IOf_ARGV) { + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); + if (fp) + continue; + (void)do_close(PL_last_in_gv, FALSE); + } + else if (type == OP_GLOB) { + if (!do_close(PL_last_in_gv, FALSE)) { + Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), + "glob failed (child exited with status %d%s)", + (int)(STATUS_CURRENT >> 8), + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } + } + if (gimme == G_SCALAR) { + if (type != OP_RCATLINE) { + SV_CHECK_THINKFIRST_COW_DROP(TARG); + SvOK_off(TARG); + } + SPAGAIN; + PUSHTARG; + } + MAYBE_TAINT_LINE(io, sv); + RETURN; + } + MAYBE_TAINT_LINE(io, sv); + IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; + SvSETMAGIC(sv); + SPAGAIN; + XPUSHs(sv); + if (type == OP_GLOB) { + const char *t1; + Stat_t statbuf; + + if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { + char * const tmps = SvEND(sv) - 1; + if (*tmps == *SvPVX_const(PL_rs)) { + *tmps = '\0'; + SvCUR_set(sv, SvCUR(sv) - 1); + } + } + for (t1 = SvPVX_const(sv); *t1; t1++) #ifdef __VMS - if (strchr("*%?", *t1)) + if (memCHRs("*%?", *t1)) #else - if (strchr("$&*(){}[]'\";\\|?<>~`", *t1)) + if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) #endif - break; - if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { - (void)POPs; /* Unmatched wildcard? Chuck it... */ - continue; - } - } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ - if (ckWARN(WARN_UTF8)) { - const U8 * const s = (const U8*)SvPVX_const(sv) + offset; - const STRLEN len = SvCUR(sv) - offset; - const U8 *f; - - if (!is_utf8_string_loc(s, len, &f)) - /* Emulate :encoding(utf8) warning in the same case. */ - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "utf8 \"\\x%02X\" does not map to Unicode", - f < (U8*)SvEND(sv) ? *f : 0); - } - } - if (gimme == G_ARRAY) { - if (SvLEN(sv) - SvCUR(sv) > 20) { - SvPV_shrink_to_cur(sv); - } - sv = sv_2mortal(newSV(80)); - continue; - } - else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { - /* try to reclaim a bit of scalar space (only on 1st alloc) */ - const STRLEN new_len - = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ - SvPV_renew(sv, new_len); - } - RETURN; + break; + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { + (void)POPs; /* Unmatched wildcard? Chuck it... */ + continue; + } + } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + if (ckWARN(WARN_UTF8)) { + const U8 * const s = (const U8*)SvPVX_const(sv) + offset; + const STRLEN len = SvCUR(sv) - offset; + const U8 *f; + + if (!is_utf8_string_loc(s, len, &f)) + /* Emulate :encoding(utf8) warning in the same case. */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "utf8 \"\\x%02X\" does not map to Unicode", + f < (U8*)SvEND(sv) ? *f : 0); + } + } + if (gimme == G_LIST) { + if (SvLEN(sv) - SvCUR(sv) > 20) { + SvPV_shrink_to_cur(sv); + } + sv = sv_2mortal(newSV(80)); + continue; + } + else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + /* try to reclaim a bit of scalar space (only on 1st alloc) */ + const STRLEN new_len + = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ + SvPV_renew(sv, new_len); + } + RETURN; } } @@ -2512,52 +3373,52 @@ PP(pp_helem) bool preeminent = TRUE; if (SvTYPE(hv) != SVt_PVHV) - RETPUSHUNDEF; + RETPUSHUNDEF; if (localizing) { - MAGIC *mg; - HV *stash; - - /* If we can determine whether the element exist, - * Try to preserve the existenceness of a tied hash - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise. */ - if (SvCANEXISTDELETE(hv)) - preeminent = hv_exists_ent(hv, keysv, 0); + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(hv)) + preeminent = hv_exists_ent(hv, keysv, 0); } he = hv_fetch_ent(hv, keysv, lval && !defer, 0); svp = he ? &HeVAL(he) : NULL; if (lval) { - if (!svp || !*svp || *svp == &PL_sv_undef) { - SV* lv; - SV* key2; - if (!defer) { - DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); - } - lv = sv_newmortal(); - sv_upgrade(lv, SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); - SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ - LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); - LvTARGLEN(lv) = 1; - PUSHs(lv); - RETURN; - } - if (localizing) { - if (HvNAME_get(hv) && isGV(*svp)) - save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else if (preeminent) - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - else - SAVEHDELETE(hv, keysv); - } - else if (PL_op->op_private & OPpDEREF) { - PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); - RETURN; - } + if (!svp || !*svp || *svp == &PL_sv_undef) { + SV* lv; + SV* key2; + if (!defer) { + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + } + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); + SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ + LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } + if (localizing) { + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) + save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); + } + else if (PL_op->op_private & OPpDEREF) { + PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); + RETURN; + } } sv = (svp && *svp ? *svp : &PL_sv_undef); /* Originally this did a conditional C; this @@ -2573,7 +3434,7 @@ PP(pp_helem) * compromise, do the get magic here. (The MGf_GSKIP flag will stop it * being called too many times). */ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -2584,14 +3445,14 @@ PP(pp_helem) STATIC GV * S_softref2xv_lite(pTHX_ SV *const sv, const char *const what, - const svtype type) + const svtype type) { if (PL_op->op_private & HINT_STRICT_REFS) { - if (SvOK(sv)) - Perl_die(aTHX_ PL_no_symref_sv, sv, - (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); - else - Perl_die(aTHX_ PL_no_usym, what); + if (SvOK(sv)) + Perl_die(aTHX_ PL_no_symref_sv, sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); + else + Perl_die(aTHX_ PL_no_usym, what); } if (!SvOK(sv)) Perl_die(aTHX_ PL_no_usym, what); @@ -2779,14 +3640,20 @@ PP(pp_multideref) IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); - len = av_tindex(av); - sv = sv_2mortal(newSVavdefelem(av, - /* Resolve a negative index now, unless it points - * before the beginning of the array, in which - * case record it for error reporting in - * magic_setdefelem. */ - elem < 0 && len + elem >= 0 - ? len + elem : elem, 1)); + len = av_top_index(av); + /* Resolve a negative index that falls within + * the array. Leave it negative it if falls + * outside the array. */ + if (elem < 0 && len + elem >= 0) + elem = len + elem; + if (elem >= 0 && elem <= len) + /* Falls within the array. */ + sv = av_nonelem(av,elem); + else + /* Falls outside the array. If it is neg- + ative, magic_setdefelem will use the + index for error reporting. */ + sv = sv_2mortal(newSVavdefelem(av,elem,1)); } else { if (UNLIKELY(localizing)) { @@ -2982,7 +3849,7 @@ PP(pp_multideref) } else { if (localizing) { - if (HvNAME_get(hv) && isGV(sv)) + if (HvNAME_get(hv) && isGV_or_RVCV(sv)) save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); else if (preeminent) { @@ -3071,13 +3938,13 @@ PP(pp_iter) case CXt_LOOP_LAZYIV: /* integer increment */ { IV cur = cx->blk_loop.state_u.lazyiv.cur; - if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) - goto retno; + if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) + goto retno; oldsv = *itersvp; - /* see NB comment above */ - if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { - /* safe to reuse old SV */ + /* see NB comment above */ + if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { + /* safe to reuse old SV */ if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV)) == SVt_IV) @@ -3094,28 +3961,28 @@ PP(pp_iter) } else sv_setiv(oldsv, cur); - } - else - { - /* we need a fresh SV every time so that loop body sees a - * completely new SV for closures/references to work as they - * used to */ - *itersvp = newSViv(cur); - SvREFCNT_dec(oldsv); - } - - if (UNLIKELY(cur == IV_MAX)) { - /* Handle end of range at IV_MAX */ - cx->blk_loop.state_u.lazyiv.end = IV_MIN; - } else - ++cx->blk_loop.state_u.lazyiv.cur; + } + else + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as they + * used to */ + *itersvp = newSViv(cur); + SvREFCNT_dec(oldsv); + } + + if (UNLIKELY(cur == IV_MAX)) { + /* Handle end of range at IV_MAX */ + cx->blk_loop.state_u.lazyiv.end = IV_MIN; + } else + ++cx->blk_loop.state_u.lazyiv.cur; break; } case CXt_LOOP_LIST: /* for (1,2,3) */ assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */ - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.stack.ix += inc); if (UNLIKELY(inc > 0 ? ix > cx->blk_oldsp @@ -3130,7 +3997,7 @@ PP(pp_iter) case CXt_LOOP_ARY: /* for (@ary) */ av = cx->blk_loop.state_u.ary.ary; - inc = 1 - (PL_op->op_private & OPpITER_REVERSED); + inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); ix = (cx->blk_loop.state_u.ary.ix += inc); if (UNLIKELY(inc > 0 ? ix > AvFILL(av) @@ -3178,36 +4045,52 @@ PP(pp_iter) break; default: - DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); + DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); } - /* Bypass pushing &PL_sv_yes and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead * jump straight to the AND op's op_other */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); - return cLOGOPx(PL_op->op_next)->op_other; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return cLOGOPx(PL_op->op_next)->op_other; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + /* pp_enteriter should have pre-extended the stack */ + EXTEND_SKIP(PL_stack_sp, 1); + *++PL_stack_sp = &PL_sv_yes; + return PL_op->op_next; + } retno: - /* Bypass pushing &PL_sv_no and calling pp_and(); instead + /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead * jump straight to the AND op's op_next */ assert(PL_op->op_next->op_type == OP_AND); - assert(PL_op->op_next->op_ppaddr == Perl_pp_and); /* pp_enteriter should have pre-extended the stack */ EXTEND_SKIP(PL_stack_sp, 1); /* we only need this for the rare case where the OP_AND isn't * in void context, e.g. $x = do { for (..) {...} }; - * but its cheaper to just push it rather than testing first + * (or for when an XS module has replaced the op_ppaddr) + * but it's cheaper to just push it rather than testing first */ *++PL_stack_sp = &PL_sv_no; - return PL_op->op_next->op_next; + if (PL_op->op_next->op_ppaddr == Perl_pp_and) { + return PL_op->op_next->op_next; + } + else { + /* An XS module has replaced the op_ppaddr, so fall back to the slow, + * obvious way. */ + return PL_op->op_next; + } } /* A description of how taint works in pattern matching and substitution. -This is all conditional on NO_TAINT_SUPPORT not being defined. Under -NO_TAINT_SUPPORT, taint-related operations should become no-ops. +This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default). +Under NO_TAINT_SUPPORT, taint-related operations should become no-ops. While the pattern is being assembled/concatenated and then compiled, PL_tainted will get set (via TAINT_set) if any component of the pattern @@ -3238,34 +4121,34 @@ There are four destinations of taint and they are affected by the sources according to the rules below: * the return value (not including /r): - tainted by the source string and pattern, but only for the - number-of-iterations case; boolean returns aren't tainted; + tainted by the source string and pattern, but only for the + number-of-iterations case; boolean returns aren't tainted; * the modified string (or modified copy under /r): - tainted by the source string, pattern, and replacement strings; + tainted by the source string, pattern, and replacement strings; * $1 et al: - tainted by the pattern, and under 'use re "taint"', by the source - string too; + tainted by the pattern, and under 'use re "taint"', by the source + string too; * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted: - should always be unset before executing subsequent code. + should always be unset before executing subsequent code. The overall action of pp_subst is: * at the start, set bits in rxtainted indicating the taint status of - the various sources. + the various sources. * After each pattern execution, update the SUBST_TAINT_PAT bit in - rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the - pattern has subsequently become tainted via locale ops. + rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the + pattern has subsequently become tainted via locale ops. * If control is being passed to pp_substcont to execute a /e block, - save rxtainted in the CXt_SUBST block, for future use by - pp_substcont. + save rxtainted in the CXt_SUBST block, for future use by + pp_substcont. * Whenever control is being returned to perl code (either by falling - off the "end" of pp_subst/pp_substcont, or by entering a /e block), - use the flag bits in rxtainted to make all the appropriate types of - destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 - et al will appear tainted. + off the "end" of pp_subst/pp_substcont, or by entering a /e block), + use the flag bits in rxtainted to make all the appropriate types of + destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 + et al will appear tainted. pp_match is just a simpler version of the above. @@ -3284,7 +4167,7 @@ PP(pp_subst) SSize_t maxiters; bool once; U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. - See "how taint works" above */ + See "how taint works" above */ char *orig; U8 r_flags; REGEXP *rx = PM_GETRE(pm); @@ -3304,14 +4187,14 @@ PP(pp_subst) PERL_ASYNC_CHECK(); if (PL_op->op_flags & OPf_STACKED) - TARG = POPs; + TARG = POPs; else { if (ARGTARG) GETTARGET; else { TARG = DEFSV; } - EXTEND(SP,1); + EXTEND(SP,1); } SvGETMAGIC(TARG); /* must come before cow check */ @@ -3321,14 +4204,14 @@ PP(pp_subst) #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { #ifndef PERL_ANY_COW - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG,0); + if (SvIsCOW(TARG)) + sv_force_normal_flags(TARG,0); #endif - if ((SvREADONLY(TARG) - || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) - || SvTYPE(TARG) > SVt_PVLV) - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) - Perl_croak_no_modify(); + if ((SvREADONLY(TARG) + || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) + || SvTYPE(TARG) > SVt_PVLV) + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) + Perl_croak_no_modify(); } PUTBACK; @@ -3337,31 +4220,31 @@ PP(pp_subst) * to match, we leave as-is; on successful match however, we *will* * coerce into a string, then repeat the match */ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG)) - force_on_match = 1; + force_on_match = 1; /* only replace once? */ once = !(rpm->op_pmflags & PMf_GLOBAL); /* See "how taint works" above */ if (TAINTING_get) { - rxtainted = ( - (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) - | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0) - | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) - | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) - ? SUBST_TAINT_BOOLRET : 0)); - TAINT_NOT; + rxtainted = ( + (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) + | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0) + | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) + | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0)); + TAINT_NOT; } force_it: if (!pm || !orig) - DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); + DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); strend = orig + len; slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len; maxiters = 2 * slen + 10; /* We can match twice at each - position, once with zero-length, - second time with non-zero. */ + position, once with zero-length, + second time with non-zero. */ /* handle the empty pattern */ if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) { @@ -3394,40 +4277,40 @@ PP(pp_subst) if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags)) { - SPAGAIN; - PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + SPAGAIN; + PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); + LEAVE_SCOPE(oldsave); + RETURN; } PL_curpm = pm; /* known replacement string? */ if (dstr) { - /* replacement needing upgrading? */ - if (DO_UTF8(TARG) && !doutf8) { - nsv = sv_newmortal(); - SvSetSV(nsv, dstr); - sv_utf8_upgrade(nsv); - c = SvPV_const(nsv, clen); - doutf8 = TRUE; - } - else { - c = SvPV_const(dstr, clen); - doutf8 = DO_UTF8(dstr); - } - - if (SvTAINTED(dstr)) - rxtainted |= SUBST_TAINT_REPL; + /* replacement needing upgrading? */ + if (DO_UTF8(TARG) && !doutf8) { + nsv = sv_newmortal(); + SvSetSV(nsv, dstr); + sv_utf8_upgrade(nsv); + c = SvPV_const(nsv, clen); + doutf8 = TRUE; + } + else { + c = SvPV_const(dstr, clen); + doutf8 = DO_UTF8(dstr); + } + + if (UNLIKELY(TAINT_get)) + rxtainted |= SUBST_TAINT_REPL; } else { - c = NULL; - doutf8 = FALSE; + c = NULL; + doutf8 = FALSE; } /* can do inplace substitution? */ if (c #ifdef PERL_ANY_COW - && !was_cow + && !was_cow #endif && (I32)clen <= RXp_MINLENRET(prog) && ( once @@ -3435,229 +4318,231 @@ PP(pp_subst) || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN)) ) && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST) - && (!doutf8 || SvUTF8(TARG)) - && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + && (!doutf8 || SvUTF8(TARG)) + && !(rpm->op_pmflags & PMf_NONDESTRUCT)) { #ifdef PERL_ANY_COW /* string might have got converted to COW since we set was_cow */ - if (SvIsCOW(TARG)) { - if (!force_on_match) - goto have_a_cow; - assert(SvVOK(TARG)); - } + if (SvIsCOW(TARG)) { + if (!force_on_match) + goto have_a_cow; + assert(SvVOK(TARG)); + } #endif - if (force_on_match) { + if (force_on_match) { /* redo the first match, this time with the orig var * forced into being a string */ - force_on_match = 0; - orig = SvPV_force_nomg(TARG, len); - goto force_it; - } + force_on_match = 0; + orig = SvPV_force_nomg(TARG, len); + goto force_it; + } - if (once) { + if (once) { char *d, *m; - if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ - rxtainted |= SUBST_TAINT_PAT; - m = orig + RXp_OFFS(prog)[0].start; - d = orig + RXp_OFFS(prog)[0].end; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ + if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; + m = orig + RXp_OFFS(prog)[0].start; + d = orig + RXp_OFFS(prog)[0].end; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ I32 i; - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - } - else { /* faster from front */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + SvCUR_set(TARG, m - s); + } + else { /* faster from front */ I32 i = m - s; - d -= clen; + d -= clen; if (i > 0) Move(s, d - i, i, char); - sv_chop(TARG, d-i); - if (clen) - Copy(c, d, clen, char); - } - SPAGAIN; - PUSHs(&PL_sv_yes); - } - else { + sv_chop(TARG, d-i); + if (clen) + Copy(c, d, clen, char); + } + SPAGAIN; + PUSHs(&PL_sv_yes); + } + else { char *d, *m; d = s = RXp_OFFS(prog)[0].start + orig; - do { + do { I32 i; - if (UNLIKELY(iters++ > maxiters)) - DIE(aTHX_ "Substitution loop"); + if (UNLIKELY(iters++ > maxiters)) + DIE(aTHX_ "Substitution loop"); /* run time pattern taint, eg locale */ - if (UNLIKELY(RXp_MATCH_TAINTED(prog))) - rxtainted |= SUBST_TAINT_PAT; - m = RXp_OFFS(prog)[0].start + orig; - if ((i = m - s)) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = RXp_OFFS(prog)[0].end + orig; - } while (CALLREGEXEC(rx, s, strend, orig, - s == m, /* don't match same null twice */ - TARG, NULL, + if (UNLIKELY(RXp_MATCH_TAINTED(prog))) + rxtainted |= SUBST_TAINT_PAT; + m = RXp_OFFS(prog)[0].start + orig; + if ((i = m - s)) { + if (s != d) + Move(s, d, i, char); + d += i; + } + if (clen) { + Copy(c, d, clen, char); + d += clen; + } + s = RXp_OFFS(prog)[0].end + orig; + } while (CALLREGEXEC(rx, s, strend, orig, + s == m, /* don't match same null twice */ + TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); - if (s != d) { + if (s != d) { I32 i = strend - s; - SvCUR_set(TARG, d - SvPVX_const(TARG) + i); - Move(s, d, i+1, char); /* include the NUL */ - } - SPAGAIN; + SvCUR_set(TARG, d - SvPVX_const(TARG) + i); + Move(s, d, i+1, char); /* include the NUL */ + } + SPAGAIN; + assert(iters); if (PL_op->op_private & OPpTRUEBOOL) - PUSHs(iters ? &PL_sv_yes : &PL_sv_zero); + PUSHs(&PL_sv_yes); else mPUSHi(iters); - } + } } else { - bool first; + bool first; char *m; - SV *repl; - if (force_on_match) { + SV *repl; + if (force_on_match) { /* redo the first match, this time with the orig var * forced into being a string */ - force_on_match = 0; - if (rpm->op_pmflags & PMf_NONDESTRUCT) { - /* I feel that it should be possible to avoid this mortal copy - given that the code below copies into a new destination. - However, I suspect it isn't worth the complexity of - unravelling the C for the small number of - cases where it would be viable to drop into the copy code. */ - TARG = sv_2mortal(newSVsv(TARG)); - } - orig = SvPV_force_nomg(TARG, len); - goto force_it; - } + force_on_match = 0; + if (rpm->op_pmflags & PMf_NONDESTRUCT) { + /* I feel that it should be possible to avoid this mortal copy + given that the code below copies into a new destination. + However, I suspect it isn't worth the complexity of + unravelling the C for the small number of + cases where it would be viable to drop into the copy code. */ + TARG = sv_2mortal(newSVsv(TARG)); + } + orig = SvPV_force_nomg(TARG, len); + goto force_it; + } #ifdef PERL_ANY_COW have_a_cow: #endif - if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ - rxtainted |= SUBST_TAINT_PAT; - repl = dstr; + if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; + repl = dstr; s = RXp_OFFS(prog)[0].start + orig; - dstr = newSVpvn_flags(orig, s-orig, + dstr = newSVpvn_flags(orig, s-orig, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); - if (!c) { - PERL_CONTEXT *cx; - SPAGAIN; + if (!c) { + PERL_CONTEXT *cx; + SPAGAIN; m = orig; - /* note that a whole bunch of local vars are saved here for - * use by pp_substcont: here's a list of them in case you're - * searching for places in this sub that uses a particular var: - * iters maxiters r_flags oldsave rxtainted orig dstr targ - * s m strend rx once */ - CX_PUSHSUBST(cx); - RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); - } - first = TRUE; - do { - if (UNLIKELY(iters++ > maxiters)) - DIE(aTHX_ "Substitution loop"); - if (UNLIKELY(RXp_MATCH_TAINTED(prog))) - rxtainted |= SUBST_TAINT_PAT; - if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) { - char *old_s = s; - char *old_orig = orig; + /* note that a whole bunch of local vars are saved here for + * use by pp_substcont: here's a list of them in case you're + * searching for places in this sub that uses a particular var: + * iters maxiters r_flags oldsave rxtainted orig dstr targ + * s m strend rx once */ + CX_PUSHSUBST(cx); + RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); + } + first = TRUE; + do { + if (UNLIKELY(iters++ > maxiters)) + DIE(aTHX_ "Substitution loop"); + if (UNLIKELY(RXp_MATCH_TAINTED(prog))) + rxtainted |= SUBST_TAINT_PAT; + if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) { + char *old_s = s; + char *old_orig = orig; assert(RXp_SUBOFFSET(prog) == 0); - orig = RXp_SUBBEG(prog); - s = orig + (old_s - old_orig); - strend = s + (strend - old_s); - } - m = RXp_OFFS(prog)[0].start + orig; - sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); - s = RXp_OFFS(prog)[0].end + orig; - if (first) { - /* replacement already stringified */ - if (clen) - sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8); - first = FALSE; - } - else { - sv_catsv(dstr, repl); - if (UNLIKELY(SvTAINTED(repl))) - rxtainted |= SUBST_TAINT_REPL; - } - if (once) - break; - } while (CALLREGEXEC(rx, s, strend, orig, + orig = RXp_SUBBEG(prog); + s = orig + (old_s - old_orig); + strend = s + (strend - old_s); + } + m = RXp_OFFS(prog)[0].start + orig; + sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); + s = RXp_OFFS(prog)[0].end + orig; + if (first) { + /* replacement already stringified */ + if (clen) + sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8); + first = FALSE; + } + else { + sv_catsv(dstr, repl); + } + if (once) + break; + } while (CALLREGEXEC(rx, s, strend, orig, s == m, /* Yields minend of 0 or 1 */ - TARG, NULL, + TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); assert(strend >= s); - sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); - - if (rpm->op_pmflags & PMf_NONDESTRUCT) { - /* From here on down we're using the copy, and leaving the original - untouched. */ - TARG = dstr; - SPAGAIN; - PUSHs(dstr); - } else { + sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); + + if (rpm->op_pmflags & PMf_NONDESTRUCT) { + /* From here on down we're using the copy, and leaving the original + untouched. */ + TARG = dstr; + SPAGAIN; + PUSHs(dstr); + } else { #ifdef PERL_ANY_COW - /* The match may make the string COW. If so, brilliant, because - that's just saved us one malloc, copy and free - the regexp has - donated the old buffer, and we malloc an entirely new one, rather - than the regexp malloc()ing a buffer and copying our original, - only for us to throw it away here during the substitution. */ - if (SvIsCOW(TARG)) { - sv_force_normal_flags(TARG, SV_COW_DROP_PV); - } else + /* The match may make the string COW. If so, brilliant, because + that's just saved us one malloc, copy and free - the regexp has + donated the old buffer, and we malloc an entirely new one, rather + than the regexp malloc()ing a buffer and copying our original, + only for us to throw it away here during the substitution. */ + if (SvIsCOW(TARG)) { + sv_force_normal_flags(TARG, SV_COW_DROP_PV); + } else #endif - { - SvPV_free(TARG); - } - SvPV_set(TARG, SvPVX(dstr)); - SvCUR_set(TARG, SvCUR(dstr)); - SvLEN_set(TARG, SvLEN(dstr)); - SvFLAGS(TARG) |= SvUTF8(dstr); - SvPV_set(dstr, NULL); + { + SvPV_free(TARG); + } + SvPV_set(TARG, SvPVX(dstr)); + SvCUR_set(TARG, SvCUR(dstr)); + SvLEN_set(TARG, SvLEN(dstr)); + SvFLAGS(TARG) |= SvUTF8(dstr); + SvPV_set(dstr, NULL); - SPAGAIN; - mPUSHi(iters); - } + SPAGAIN; + if (PL_op->op_private & OPpTRUEBOOL) + PUSHs(&PL_sv_yes); + else + mPUSHi(iters); + } } if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { - (void)SvPOK_only_UTF8(TARG); + (void)SvPOK_only_UTF8(TARG); } /* See "how taint works" above */ if (TAINTING_get) { - if ((rxtainted & SUBST_TAINT_PAT) || - ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == - (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - ) - (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */ - - if (!(rxtainted & SUBST_TAINT_BOOLRET) - && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) - ) - SvTAINTED_on(TOPs); /* taint return value */ - else - SvTAINTED_off(TOPs); /* may have got tainted earlier */ - - /* needed for mg_set below */ - TAINT_set( - cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + if ((rxtainted & SUBST_TAINT_PAT) || + ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == + (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */ + + if (!(rxtainted & SUBST_TAINT_BOOLRET) + && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + else + SvTAINTED_off(TOPs); /* may have got tainted earlier */ + + /* needed for mg_set below */ + TAINT_set( + cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) ); - SvTAINT(TARG); + SvTAINT(TARG); } SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ TAINT_NOT; @@ -3671,48 +4556,48 @@ PP(pp_grepwhile) dPOPss; if (SvTRUE_NN(sv)) - PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; + PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; ++*PL_markstack_ptr; FREETMPS; LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) { - I32 items; - const U8 gimme = GIMME_V; - - LEAVE_with_name("grep"); /* exit outer scope */ - (void)POPMARK; /* pop src */ - items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; - (void)POPMARK; /* pop dst */ - SP = PL_stack_base + POPMARK; /* pop original mark */ - if (gimme == G_SCALAR) { + I32 items; + const U8 gimme = GIMME_V; + + LEAVE_with_name("grep"); /* exit outer scope */ + (void)POPMARK; /* pop src */ + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; + (void)POPMARK; /* pop dst */ + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (gimme == G_SCALAR) { if (PL_op->op_private & OPpTRUEBOOL) PUSHs(items ? &PL_sv_yes : &PL_sv_zero); else { - dTARGET; - PUSHi(items); + dTARGET; + PUSHi(items); } - } - else if (gimme == G_ARRAY) - SP += items; - RETURN; + } + else if (gimme == G_LIST) + SP += items; + RETURN; } else { - SV *src; + SV *src; - ENTER_with_name("grep_item"); /* enter inner scope */ - SAVEVPTR(PL_curpm); + ENTER_with_name("grep_item"); /* enter inner scope */ + SAVEVPTR(PL_curpm); - src = PL_stack_base[TOPMARK]; - if (SvPADTMP(src)) { - src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); - PL_tmps_floor++; - } - SvTEMP_off(src); - DEFSV_set(src); + src = PL_stack_base[TOPMARK]; + if (SvPADTMP(src)) { + src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); + PL_tmps_floor++; + } + SvTEMP_off(src); + DEFSV_set(src); - RETURNOP(cLOGOP->op_other); + RETURNOP(cLOGOP->op_other); } } @@ -3779,7 +4664,6 @@ PP(pp_grepwhile) void Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) { - dVAR; dSP; SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */ SSize_t nargs; @@ -3788,7 +4672,7 @@ Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) TAINT_NOT; - if (gimme == G_ARRAY) { + if (gimme == G_LIST) { nargs = SP - from_sp; from_sp++; } @@ -3808,7 +4692,7 @@ Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) } } - /* common code for G_SCALAR and G_ARRAY */ + /* common code for G_SCALAR and G_LIST */ tmps_base = PL_tmps_floor + 1; @@ -4055,7 +4939,7 @@ PP(pp_leavesub) /* entry zero of a stack is always PL_sv_undef, which * simplifies converting a '()' return into undef in scalar context */ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); - return 0; + return 0; } gimme = cx->blk_gimme; @@ -4082,8 +4966,6 @@ PP(pp_leavesub) void Perl_clear_defarray(pTHX_ AV* av, bool abandon) { - const SSize_t fill = AvFILLp(av); - PERL_ARGS_ASSERT_CLEAR_DEFARRAY; if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) { @@ -4091,8 +4973,9 @@ Perl_clear_defarray(pTHX_ AV* av, bool abandon) AvREIFY_only(av); } else { - AV *newav = newAV(); - av_extend(newav, fill); + const SSize_t size = AvFILLp(av) + 1; + /* The ternary gives consistency with av_extend() */ + AV *newav = newAV_alloc_x(size < 4 ? 4 : size); AvREIFY_only(newav); PAD_SVl(0) = MUTABLE_SV(newav); SvREFCNT_dec_NN(av); @@ -4109,7 +4992,7 @@ PP(pp_entersub) I32 old_savestack_ix; if (UNLIKELY(!sv)) - goto do_die; + goto do_die; /* Locate the CV to call: * - most common case: RV->CV: f(), $ref->(): @@ -4163,16 +5046,6 @@ PP(pp_entersub) if (UNLIKELY(!SvOK(sv))) DIE(aTHX_ PL_no_usym, "a subroutine"); - if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */ - if (PL_op->op_flags & OPf_STACKED) /* hasargs */ - SP = PL_stack_base + POPMARK; - else - (void)POPMARK; - if (GIMME_V == G_SCALAR) - PUSHs(&PL_sv_undef); - RETURN; - } - sym = SvPV_nomg_const(sv, len); if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : ""); @@ -4203,32 +5076,32 @@ PP(pp_entersub) assert(cv); assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv)); while (UNLIKELY(!CvROOT(cv))) { - GV* autogv; - SV* sub_name; - - /* anonymous or undef'd function leaves us no recourse */ - if (CvLEXICAL(cv) && CvHASGV(cv)) - DIE(aTHX_ "Undefined subroutine &%" SVf " called", - SVfARG(cv_name(cv, NULL, 0))); - if (CvANON(cv) || !CvHASGV(cv)) { - DIE(aTHX_ "Undefined subroutine called"); - } - - /* autoloaded stub? */ - if (cv != GvCV(gv = CvGV(cv))) { - cv = GvCV(gv); - } - /* should call AUTOLOAD now? */ - else { + GV* autogv; + SV* sub_name; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvLEXICAL(cv) && CvHASGV(cv)) + DIE(aTHX_ "Undefined subroutine &%" SVf " called", + SVfARG(cv_name(cv, NULL, 0))); + if (CvANON(cv) || !CvHASGV(cv)) { + DIE(aTHX_ "Undefined subroutine called"); + } + + /* autoloaded stub? */ + if (cv != GvCV(gv = CvGV(cv))) { + cv = GvCV(gv); + } + /* should call AUTOLOAD now? */ + else { try_autoload: - autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), (GvNAMEUTF8(gv) ? SVf_UTF8 : 0) |(PL_op->op_flags & OPf_REF ? GV_AUTOLOAD_ISMETHOD : 0)); cv = autogv ? GvCV(autogv) : NULL; - } - if (!cv) { + } + if (!cv) { sub_name = sv_newmortal(); gv_efullname3(sub_name, gv, NULL); DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name)); @@ -4237,31 +5110,31 @@ PP(pp_entersub) /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */ if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE)) - DIE(aTHX_ "Closure prototype called"); + DIE(aTHX_ "Closure prototype called"); if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv))) { - Perl_get_db_sub(aTHX_ &sv, cv); - if (CvISXSUB(cv)) - PL_curcopdb = PL_curcop; + Perl_get_db_sub(aTHX_ &sv, cv); + if (CvISXSUB(cv)) + PL_curcopdb = PL_curcop; if (CvLVALUE(cv)) { /* check for lsub that handles lvalue subroutines */ - cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); + cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); /* if lsub not found then fall back to DB::sub */ - if (!cv) cv = GvCV(PL_DBsub); + if (!cv) cv = GvCV(PL_DBsub); } else { cv = GvCV(PL_DBsub); } - if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) - DIE(aTHX_ "No DB::sub routine defined"); + if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) + DIE(aTHX_ "No DB::sub routine defined"); } if (!(CvISXSUB(cv))) { - /* This path taken at least 75% of the time */ - dMARK; - PADLIST *padlist; + /* This path taken at least 75% of the time */ + dMARK; + PADLIST *padlist; I32 depth; bool hasargs; U8 gimme; @@ -4271,7 +5144,7 @@ PP(pp_entersub) * in the caller's tmps frame, so they won't be freed until after * we return from the sub. */ - { + { SV **svp = MARK; while (svp < SP) { SV *sv = *++svp; @@ -4280,26 +5153,26 @@ PP(pp_entersub) if (SvPADTMP(sv)) *svp = sv = sv_mortalcopy(sv); SvTEMP_off(sv); - } + } } gimme = GIMME_V; - cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); + cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); hasargs = cBOOL(PL_op->op_flags & OPf_STACKED); - cx_pushsub(cx, cv, PL_op->op_next, hasargs); - - padlist = CvPADLIST(cv); - if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) - pad_push(padlist, depth); - PAD_SET_CUR_NOSAVE(padlist, depth); - if (LIKELY(hasargs)) { - AV *const av = MUTABLE_AV(PAD_SVl(0)); + cx_pushsub(cx, cv, PL_op->op_next, hasargs); + + padlist = CvPADLIST(cv); + if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) + pad_push(padlist, depth); + PAD_SET_CUR_NOSAVE(padlist, depth); + if (LIKELY(hasargs)) { + AV *const av = MUTABLE_AV(PAD_SVl(0)); SSize_t items; AV **defavp; - defavp = &GvAV(PL_defgv); - cx->blk_sub.savearray = *defavp; - *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); + defavp = &GvAV(PL_defgv); + cx->blk_sub.savearray = *defavp; + *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); /* it's the responsibility of whoever leaves a sub to ensure * that a clean, empty AV is left in pad[0]. This is normally @@ -4307,7 +5180,7 @@ PP(pp_entersub) assert(!AvREAL(av) && AvFILLp(av) == -1); items = SP - MARK; - if (UNLIKELY(items - 1 > AvMAX(av))) { + if (UNLIKELY(items - 1 > AvMAX(av))) { SV **ary = AvALLOC(av); Renew(ary, items, SV*); AvMAX(av) = items - 1; @@ -4315,106 +5188,122 @@ PP(pp_entersub) AvARRAY(av) = ary; } - Copy(MARK+1,AvARRAY(av),items,SV*); - AvFILLp(av) = items - 1; - } - if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv))) + if (items) + Copy(MARK+1,AvARRAY(av),items,SV*); + AvFILLp(av) = items - 1; + } + if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, SVfARG(cv_name(cv, NULL, 0))); - /* warning must come *after* we fully set up the context - * stuff so that __WARN__ handlers can safely dounwind() - * if they want to - */ - if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))) - sub_crush_depth(cv); - RETURNOP(CvSTART(cv)); + sub_crush_depth(cv); + RETURNOP(CvSTART(cv)); } else { - SSize_t markix = TOPMARK; + SSize_t markix = TOPMARK; bool is_scalar; ENTER; /* pretend we did the ENTER earlier */ - PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix; + PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix; - SAVETMPS; - PUTBACK; + SAVETMPS; + PUTBACK; - if (UNLIKELY(((PL_op->op_private - & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) + if (UNLIKELY(((PL_op->op_private + & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv))) + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, SVfARG(cv_name(cv, NULL, 0))); - if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) { - /* Need to copy @_ to stack. Alternative may be to - * switch stack to @_, and copy return values - * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV * const av = GvAV(PL_defgv); - const SSize_t items = AvFILL(av) + 1; - - if (items) { - SSize_t i = 0; - const bool m = cBOOL(SvRMAGICAL(av)); - /* Mark is at the end of the stack. */ - EXTEND(SP, items); - for (; i < items; ++i) - { - SV *sv; - if (m) { - SV ** const svp = av_fetch(av, i, 0); - sv = svp ? *svp : NULL; - } - else sv = AvARRAY(av)[i]; - if (sv) SP[i+1] = sv; - else { - SP[i+1] = newSVavdefelem(av, i, 1); - } - } - SP += items; - PUTBACK ; - } - } - else { - SV **mark = PL_stack_base + markix; - SSize_t items = SP - mark; - while (items--) { - mark++; - if (*mark && SvPADTMP(*mark)) { - *mark = sv_mortalcopy(*mark); + if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) { + /* Need to copy @_ to stack. Alternative may be to + * switch stack to @_, and copy return values + * back. This would allow popping @_ in XSUB, e.g.. XXXX */ + AV * const av = GvAV(PL_defgv); + const SSize_t items = AvFILL(av) + 1; + + if (items) { + SSize_t i = 0; + const bool m = cBOOL(SvRMAGICAL(av)); + /* Mark is at the end of the stack. */ + EXTEND(SP, items); + for (; i < items; ++i) + { + SV *sv; + if (m) { + SV ** const svp = av_fetch(av, i, 0); + sv = svp ? *svp : NULL; + } + else sv = AvARRAY(av)[i]; + if (sv) SP[i+1] = sv; + else { + SP[i+1] = av_nonelem(av, i); + } } - } - } - /* We assume first XSUB in &DB::sub is the called one. */ - if (UNLIKELY(PL_curcopdb)) { - SAVEVPTR(PL_curcop); - PL_curcop = PL_curcopdb; - PL_curcopdb = NULL; - } - /* Do we need to open block here? XXXX */ + SP += items; + PUTBACK ; + } + } + else { + SV **mark = PL_stack_base + markix; + SSize_t items = SP - mark; + while (items--) { + mark++; + if (*mark && SvPADTMP(*mark)) { + *mark = sv_mortalcopy(*mark); + } + } + } + /* We assume first XSUB in &DB::sub is the called one. */ + if (UNLIKELY(PL_curcopdb)) { + SAVEVPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; + } + /* Do we need to open block here? XXXX */ /* calculate gimme here as PL_op might get changed and then not * restored until the LEAVE further down */ is_scalar = (GIMME_V == G_SCALAR); - /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */ - assert(CvXSUB(cv)); - CvXSUB(cv)(aTHX_ cv); - - /* Enforce some sanity in scalar context. */ - if (is_scalar) { + /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */ + assert(CvXSUB(cv)); + CvXSUB(cv)(aTHX_ cv); + +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + /* This duplicates the check done in runops_debug(), but provides more + * information in the common case of the fault being with an XSUB. + * + * It should also catch an XSUB pushing more than it extends + * in scalar context. + */ + if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) + Perl_croak_nocontext( + "panic: XSUB %s::%s (%s) failed to extend arg stack: " + "base=%p, sp=%p, hwm=%p\n", + HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv), + PL_stack_base, PL_stack_sp, + PL_stack_base + PL_curstackinfo->si_stack_hwm); +#endif + /* Enforce some sanity in scalar context. */ + if (is_scalar) { SV **svp = PL_stack_base + markix + 1; if (svp != PL_stack_sp) { *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp; PL_stack_sp = svp; } - } - LEAVE; - return NORMAL; + } + LEAVE; + return NORMAL; } } @@ -4424,10 +5313,10 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH; if (CvANON(cv)) - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"", - SVfARG(cv_name(cv,NULL,0))); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"", + SVfARG(cv_name(cv,NULL,0))); } } @@ -4467,66 +5356,70 @@ PP(pp_aelem) SV *sv; if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Use of reference \"%" SVf "\" as array index", - SVfARG(elemsv)); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Use of reference \"%" SVf "\" as array index", + SVfARG(elemsv)); if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) - RETPUSHUNDEF; + RETPUSHUNDEF; if (UNLIKELY(localizing)) { - MAGIC *mg; - HV *stash; - - /* If we can determine whether the element exist, - * Try to preserve the existenceness of a tied array - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise. */ - if (SvCANEXISTDELETE(av)) - preeminent = av_exists(av, elem); + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(av)) + preeminent = av_exists(av, elem); } svp = av_fetch(av, elem, lval && !defer); if (lval) { #ifdef PERL_MALLOC_WRAP - if (SvUOK(elemsv)) { - const UV uv = SvUV(elemsv); - elem = uv > IV_MAX ? IV_MAX : uv; - } - else if (SvNOK(elemsv)) - elem = (IV)SvNV(elemsv); - if (elem > 0) { - static const char oom_array_extend[] = - "Out of memory during array extend"; /* Duplicated in av.c */ - MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); - } + if (SvUOK(elemsv)) { + const UV uv = SvUV(elemsv); + elem = uv > IV_MAX ? IV_MAX : uv; + } + else if (SvNOK(elemsv)) + elem = (IV)SvNV(elemsv); + if (elem > 0) { + MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); + } #endif - if (!svp || !*svp) { - IV len; - if (!defer) - DIE(aTHX_ PL_no_aelem, elem); - len = av_tindex(av); - mPUSHs(newSVavdefelem(av, - /* Resolve a negative index now, unless it points before the - beginning of the array, in which case record it for error - reporting in magic_setdefelem. */ - elem < 0 && len + elem >= 0 ? len + elem : elem, - 1)); - RETURN; - } - if (UNLIKELY(localizing)) { - if (preeminent) - save_aelem(av, elem, svp); - else - SAVEADELETE(av, elem); - } - else if (PL_op->op_private & OPpDEREF) { - PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); - RETURN; - } + if (!svp || !*svp) { + IV len; + if (!defer) + DIE(aTHX_ PL_no_aelem, elem); + len = av_top_index(av); + /* Resolve a negative index that falls within the array. Leave + it negative it if falls outside the array. */ + if (elem < 0 && len + elem >= 0) + elem = len + elem; + if (elem >= 0 && elem <= len) + /* Falls within the array. */ + PUSHs(av_nonelem(av,elem)); + else + /* Falls outside the array. If it is negative, + magic_setdefelem will use the index for error reporting. + */ + mPUSHs(newSVavdefelem(av, elem, 1)); + RETURN; + } + if (UNLIKELY(localizing)) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } + else if (PL_op->op_private & OPpDEREF) { + PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); + RETURN; + } } sv = (svp ? *svp : &PL_sv_undef); if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -4538,30 +5431,30 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) SvGETMAGIC(sv); if (!SvOK(sv)) { - if (SvREADONLY(sv)) - Perl_croak_no_modify(); - prepare_SV_for_RV(sv); - switch (to_what) { - case OPpDEREF_SV: - SvRV_set(sv, newSV(0)); - break; - case OPpDEREF_AV: - SvRV_set(sv, MUTABLE_SV(newAV())); - break; - case OPpDEREF_HV: - SvRV_set(sv, MUTABLE_SV(newHV())); - break; - } - SvROK_on(sv); - SvSETMAGIC(sv); - SvGETMAGIC(sv); + if (SvREADONLY(sv)) + Perl_croak_no_modify(); + prepare_SV_for_RV(sv); + switch (to_what) { + case OPpDEREF_SV: + SvRV_set(sv, newSV(0)); + break; + case OPpDEREF_AV: + SvRV_set(sv, MUTABLE_SV(newAV())); + break; + case OPpDEREF_HV: + SvRV_set(sv, MUTABLE_SV(newHV())); + break; + } + SvROK_on(sv); + SvSETMAGIC(sv); + SvGETMAGIC(sv); } if (SvGMAGICAL(sv)) { - /* copy the sv without magic to prevent magic from being - executed twice */ - SV* msv = sv_newmortal(); - sv_setsv_nomg(msv, sv); - return msv; + /* copy the sv without magic to prevent magic from being + executed twice */ + SV* msv = sv_newmortal(); + sv_setsv_nomg(msv, sv); + return msv; } return sv; } @@ -4573,78 +5466,78 @@ S_opmethod_stash(pTHX_ SV* meth) HV* stash; SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp - ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a " - "package or object reference", SVfARG(meth)), - (SV *)NULL) - : *(PL_stack_base + TOPMARK + 1); + ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a " + "package or object reference", SVfARG(meth)), + (SV *)NULL) + : *(PL_stack_base + TOPMARK + 1); PERL_ARGS_ASSERT_OPMETHOD_STASH; if (UNLIKELY(!sv)) undefined: - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value", - SVfARG(meth)); + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value", + SVfARG(meth)); if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv); else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */ - stash = gv_stashsv(sv, GV_CACHE_ONLY); - if (stash) return stash; + stash = gv_stashsv(sv, GV_CACHE_ONLY); + if (stash) return stash; } if (SvROK(sv)) - ob = MUTABLE_SV(SvRV(sv)); + ob = MUTABLE_SV(SvRV(sv)); else if (!SvOK(sv)) goto undefined; else if (isGV_with_GP(sv)) { - if (!GvIO(sv)) - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " - "without a package or object reference", - SVfARG(meth)); - ob = sv; - if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { - assert(!LvTARGLEN(ob)); - ob = LvTARG(ob); - assert(ob); - } - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); + if (!GvIO(sv)) + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " + "without a package or object reference", + SVfARG(meth)); + ob = sv; + if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { + assert(!LvTARGLEN(ob)); + ob = LvTARG(ob); + assert(ob); + } + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); } else { - /* this isn't a reference */ - GV* iogv; + /* this isn't a reference */ + GV* iogv; STRLEN packlen; const char * const packname = SvPV_nomg_const(sv, packlen); const U32 packname_utf8 = SvUTF8(sv); stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY); if (stash) return stash; - if (!(iogv = gv_fetchpvn_flags( - packname, packlen, packname_utf8, SVt_PVIO - )) || - !(ob=MUTABLE_SV(GvIO(iogv)))) - { - /* this isn't the name of a filehandle either */ - if (!packlen) - { - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " - "without a package or object reference", - SVfARG(meth)); - } - /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, packname_utf8); - if (stash) return stash; - else return MUTABLE_HV(sv); - } - /* it _is_ a filehandle name -- replace with a reference */ - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); + if (!(iogv = gv_fetchpvn_flags( + packname, packlen, packname_utf8, SVt_PVIO + )) || + !(ob=MUTABLE_SV(GvIO(iogv)))) + { + /* this isn't the name of a filehandle either */ + if (!packlen) + { + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " + "without a package or object reference", + SVfARG(meth)); + } + /* assume it's a package name */ + stash = gv_stashpvn(packname, packlen, packname_utf8); + if (stash) return stash; + else return MUTABLE_HV(sv); + } + /* it _is_ a filehandle name -- replace with a reference */ + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); } /* if we got here, ob should be an object or a glob */ if (!ob || !(SvOBJECT(ob) - || (isGV_with_GP(ob) - && (ob = MUTABLE_SV(GvIO((const GV *)ob))) - && SvOBJECT(ob)))) + || (isGV_with_GP(ob) + && (ob = MUTABLE_SV(GvIO((const GV *)ob))) + && SvOBJECT(ob)))) { - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", - SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", + SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) ? newSVpvs_flags("DOES", SVs_TEMP) : meth)); }