#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
+#include "regcomp.h"
/* Hot code. */
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;
else { /* $l .= $r and left == TARG */
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);
}
}
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;
}
}
sprintf "...%s...". Don't call '.'
overloading: only use '""' overloading.
- OPpMULTICONCAT_STRINGIFY: (for Deparse's benefit) the RHS was of the
- form "...$a...$b..." rather than
+ 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
{
dSP;
SV *targ; /* The SV to be assigned or appended to */
- SV *dsv; /* the SV to concat args to (often == targ) */
- char *dsv_pv; /* where within SvPVX(dsv) we're writing 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 */
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 (dsv) */
+ 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 */
toparg = SP;
SP -= (nargs - 1);
- dsv = targ; /* Set the destination for all concats. This is
- initially targ; later on, dsv may be switched
- to point to a TEMP SV if overloading is
- encountered. */
grow = 1; /* allow for '\0' at minimum */
targ_count = 0;
targ_chain = NULL;
* 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 an overloaded arg is found, the loop is abandoned at that point,
- * and dsv is set to an SvTEMP SV where the results-so-far will be
- * accumulated.
+ * 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++) {
- bool simple_flags;
U32 utf8;
STRLEN len;
SV *sv;
assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG);
sv = *SP;
- simple_flags = (SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK;
/* this if/else chain is arranged so that common/simple cases
* take few conditionals */
- if (LIKELY(simple_flags && (sv != targ))) {
- /* common case: sv is a simple PV and not the targ */
- svpv_end->pv = SvPVX(sv);
+ 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 (simple_flags) {
- /* sv is targ (but can't be magic or overloaded).
- * 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.
+ 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.
*/
- 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;
- }
- else {
- if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) {
- /* its got magic, is tied, and/or is overloaded */
- SvGETMAGIC(sv);
-
- if (UNLIKELY(SvAMAGIC(sv))
- && !(PL_op->op_private & OPpMULTICONCAT_FAKE))
- {
- /* One of the RHS args is overloaded. Abandon stringifying
- * the args at this point, then in the concat loop later
- * on, concat the plain args stringified so far into a
- * TEMP SV. At the end of this function the remaining
- * args (including the current one) will be handled
- * specially, using overload calls.
- * FAKE implies an optimised sprintf which doesn't use
- * concat overloading, only "" overloading.
- */
-
- if ( svpv_end == svpv_buf + 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- && aux[PERL_MULTICONCAT_IX_LENGTHS + 1].ssize == -1
- ) {
- /* special case: if the overloaded sv is the
- * second arg in the concat chain, stop at the
- * first arg rather than this, so that
- *
- * $arg1 . $arg2
- *
- * invokes overloading as
- *
- * concat($arg2, $arg1, 1)
- *
- * rather than
- *
- * concat($arg2, "$arg1", 1)
- *
- * This means that if for example arg1 is a ref,
- * it gets passed as-is to the concat method
- * rather than a stringified copy. If it's not the
- * first arg, it doesn't matter, as in $arg0 .
- * $arg1 . $arg2, where the result of ($arg0 .
- * $arg1) will already be a string.
- * THis isn't perfect: we'll have already
- * done SvPV($arg1) on the previous iteration;
- * and are now throwing away that result and
- * hoping arg1 hasn;t been affected.
- */
- svpv_end--;
- SP--;
- }
-
- setup_overload:
- dsv = newSVpvn_flags("", 0, SVs_TEMP);
-
- if (targ_chain) {
- /* Get the string value of targ and populate any
- * RHS slots which use it */
- char *pv = SvPV_nomg(targ, len);
- dst_utf8 |= (SvFLAGS(targ) & SVf_UTF8);
- grow += len * targ_count;
- do {
- struct multiconcat_svpv *p = targ_chain;
- targ_chain = (struct multiconcat_svpv *)(p->pv);
- p->pv = pv;
- p->len = len;
- } while (targ_chain);
- }
- else if (is_append)
- SvGETMAGIC(targ);
-
- goto phase3;
- }
-
- if (SvFLAGS(sv) & SVs_RMG) {
- /* probably tied; copy it to guarantee separate values
- * each time it's used, e.g. "-$tied-$tied-$tied-",
- * since FETCH() isn't necessarily idempotent */
- SV *nsv = newSV(0);
- sv_setsv_flags(nsv, sv, SV_NOSTEAL);
- sv_2mortal(nsv);
- if ( sv == targ
- && is_append
- && nargs == 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- && aux[PERL_MULTICONCAT_IX_LENGTHS+1].ssize == -1)
- {
- /* special-case $tied .= $tied.
- *
- * For something like
- * sub FETCH { $i++ }
- * then
- * $tied .= $tied . $tied . $tied;
- * will STORE "4123"
- * while
- * $tied .= $tied
- * will STORE "12"
- *
- * i.e. for a single mutator concat, the LHS is
- * retrieved first; in all other cases it is
- * retrieved last. Whether this is sane behaviour
- * is open to debate; but for now, multiconcat (as
- * it is an optimisation) tries to reproduce
- * existing behaviour.
- */
- sv_catsv(nsv, sv);
- sv_setsv(sv,nsv);
- SP++;
- goto phase7; /* just return targ as-is */
- }
-
- sv = nsv;
- }
- }
-
- if (sv == targ) {
- /* must warn for each RH usage of targ, except that
- * we will later get one warning when doing
- * SvPV_force(targ), *except* on '.=' */
- if ( !SvOK(sv)
- && (targ_chain || is_append)
- && ckWARN(WARN_UNINITIALIZED)
- )
- report_uninit(sv);
- goto targ_on_rhs;
- }
-
- /* stringify general SV */
+ 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 = (char*)"";
+ len = 0;
+ }
+ else
+ goto do_magical; /* something weird */
utf8 = (SvFLAGS(sv) & SVf_UTF8);
dst_utf8 |= utf8;
*/
if (is_append) {
- if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) {
- SvGETMAGIC(targ); /* must do before SvAMAGIC() check */
- if (UNLIKELY(SvAMAGIC(targ))) {
- /* $overloaded .= ....;
- * accumulate RHS in a temp SV rather than targ,
- * then append tmp to targ at the end using overload
- */
- assert(!targ_chain);
- dsv = newSVpvn_flags("", 0, SVs_TEMP);
-
- if ( svpv_end == svpv_buf + 1
- /* no const string segments */
- && aux[PERL_MULTICONCAT_IX_LENGTHS].ssize == -1
- ) {
- /* special case $overloaded .= $arg1:
- * avoid stringifying $arg1.
- * Similar to the $arg1 . $arg2 case in phase1
- */
- svpv_end--;
- SP--;
- }
-
- goto phase3;
- }
- }
+ /* 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;
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
* (which makes the 'F' typeglob an alias to the
* '*main::F*main::F' typeglob).
*/
- goto setup_overload;
+ goto do_magical;
}
- else if (targ_chain) {
+ else if (targ_chain)
/* targ was found on RHS.
- * We don't need the SvGETMAGIC() call and SvAMAGIC() test as
- * both were already done earlier in the SvPV() loop; other
- * than that we can share the same code with the append
- * branch below.
- * Note that this goto jumps directly into the SvOK() branch
- * even if targ isn't SvOK(), to force an 'uninitialised'
- * warning; e.g.
- * $undef .= .... targ only on LHS: don't warn
- * $undef .= $undef .... targ on RHS too: warn
+ * 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.
*/
- assert(!SvAMAGIC(targ));
goto stringify_targ;
- }
-
/* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0;
* those will be done later. */
- assert(targ == dsv);
SV_CHECK_THINKFIRST_COW_DROP(targ);
SvUPGRADE(targ, SVt_PV);
SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8);
/* --------------------------------------------------------------
* Phase 3:
*
- * UTF-8 tweaks and grow dsv:
+ * UTF-8 tweaks and grow targ:
*
* Now that we know the length and utf8-ness of both the targ and
- * args, grow dsv to the size needed to accumulate all the args, based
+ * 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.
*
/* turn off utf8 handling if 'use bytes' is in scope */
if (UNLIKELY(dst_utf8 && IN_BYTES)) {
dst_utf8 = 0;
- SvUTF8_off(dsv);
+ 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;
/* unrolled SvGROW(), except don't check for SVf_IsCOW, which should
* already have been dropped */
- assert(!SvIsCOW(dsv));
- dsv_pv = (SvLEN(dsv) < (grow) ? sv_grow(dsv,grow) : SvPVX(dsv));
+ assert(!SvIsCOW(targ));
+ targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ));
/* --------------------------------------------------------------
* Phase 4:
*
- * Now that dsv (which is probably 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.
+ * 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.
*
* 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(dsv) where the
+ * and dst_pv will point to the location within SvPVX(targ) where the
* next arg should be copied.
*/
if (targ_len) {
struct multiconcat_svpv *tc_stop;
- char *targ_pv = dsv_pv;
+ char *targ_buf = targ_pv; /* ptr to original targ string */
- assert(targ == dsv);
assert(is_append || targ_count);
if (is_append) {
- dsv_pv += targ_len;
+ targ_pv += targ_len;
tc_stop = NULL;
}
else {
}
if (offset) {
- targ_pv += offset;
- Move(dsv_pv, targ_pv, targ_len, char);
+ targ_buf += offset;
+ Move(targ_pv, targ_buf, targ_len, char);
/* a negative length implies don't Copy(), but do increment */
- svpv_p->len = -targ_len;
+ svpv_p->len = -((SSize_t)targ_len);
slow_concat = TRUE;
}
else {
/* skip the first targ copy */
svpv_base++;
const_lens++;
- dsv_pv += targ_len;
+ targ_pv += targ_len;
}
/* Don't populate the first targ slot in the loop below; it's
while (targ_chain != tc_stop) {
struct multiconcat_svpv *p = targ_chain;
targ_chain = (struct multiconcat_svpv *)(p->pv);
- p->pv = targ_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 dsv.
+ * 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+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 dsv_pv by len.
+ * been copied. Just advance targ_pv by len.
*/
/* If there are no constant strings and no special case args
SSize_t len = svpv_p->len;
if (!len)
continue;
- Copy(svpv_p->pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(svpv_p->pv, targ_pv, len, char);
+ targ_pv += len;
}
const_lens += (svpv_end - svpv_base + 1);
}
/* append next const string segment */
if (len > 0) {
- Copy(const_pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(const_pv, targ_pv, len, char);
+ targ_pv += len;
const_pv += len;
}
len = svpv_p->len;
if (LIKELY(len > 0)) {
- Copy(svpv_p->pv, dsv_pv, len, char);
- dsv_pv += len;
+ Copy(svpv_p->pv, targ_pv, len, char);
+ targ_pv += len;
}
else if (UNLIKELY(len < 0)) {
/* negative length indicates two special cases */
len = -len;
if (UNLIKELY(p)) {
/* copy plain-but-variant pv to a utf8 targ */
- char * end_pv = dsv_pv + len;
+ char * end_pv = targ_pv + len;
assert(dst_utf8);
- while (dsv_pv < end_pv) {
+ while (targ_pv < end_pv) {
U8 c = (U8) *p++;
- append_utf8_from_native_byte(c, (U8**)&dsv_pv);
+ append_utf8_from_native_byte(c, (U8**)&targ_pv);
}
}
else
/* arg is already-copied targ */
- dsv_pv += len;
+ targ_pv += len;
}
}
}
- *dsv_pv = '\0';
- SvCUR_set(dsv, dsv_pv - SvPVX(dsv));
- assert(grow >= SvCUR(dsv) + 1);
- assert(SvLEN(dsv) >= SvCUR(dsv) + 1);
+ *targ_pv = '\0';
+ SvCUR_set(targ, targ_pv - SvPVX(targ));
+ assert(grow >= SvCUR(targ) + 1);
+ assert(SvLEN(targ) >= SvCUR(targ) + 1);
/* --------------------------------------------------------------
* Phase 6:
*
- * Handle overloading. If an overloaded arg or targ was detected
- * earlier, dsv will have been set to a new mortal, and any args and
- * consts to the left of the first overloaded arg will have been
- * accumulated to it. This section completes any further concatenation
- * steps with overloading handled.
+ * 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.
*/
- if (UNLIKELY(dsv != targ)) {
- SV *res;
+ 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;
- SvFLAGS(dsv) |= dst_utf8;
+ /* 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 (SP <= toparg) {
- /* Stringifying the RHS was abandoned because *SP
- * is overloaded. dsv contains all the concatted strings
- * before *SP. Apply the rest of the args using overloading.
+ /* if necessary, stringify the final RHS result in
+ * something like $targ .= "$a$b$c" - simulating
+ * pp_stringify
*/
- SV *left, *right, *res;
- int i;
- bool getmg = FALSE;
- /* number of args already concatted */
- SSize_t n = (nargs - 1) - (toparg - SP);
- /* current arg is either the first
- * or second value to be concatted
- * (including constant strings), so would
- * form part of the first concat */
- bool first_concat = ( n == 0
- || (n == 1 && const_lens[-2].ssize < 0
- && const_lens[-1].ssize < 0));
- int f_assign = first_concat ? 0 : AMGf_assign;
-
- left = dsv;
-
- for (; n < nargs; n++) {
- /* loop twice, first applying the arg, then the const segment */
- for (i = 0; i < 2; i++) {
- if (i) {
- /* append next const string segment */
- STRLEN len = (STRLEN)((const_lens++)->ssize);
- /* a length of -1 implies no constant string
- * rather than a zero-length one, e.g.
- * ($a . $b) versus ($a . "" . $b)
- */
- if ((SSize_t)len < 0)
- continue;
+ 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;
+ }
- /* set right to the next constant string segment */
- right = newSVpvn_flags(const_pv, len,
- (dst_utf8 | SVs_TEMP));
- const_pv += len;
- }
- else {
- /* append next arg */
- right = *SP++;
- if (getmg)
- SvGETMAGIC(right);
- else
- /* SvGETMAGIC already called on this SV just
- * before we broke from the loop earlier */
- getmg = TRUE;
-
- if (first_concat && n == 0 && const_lens[-1].ssize < 0) {
- /* nothing before the current arg; repeat the
- * loop to get a second arg */
- left = right;
- first_concat = FALSE;
- continue;
- }
- }
+ /* 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))
- && (res = amagic_call(left, right, concat_amg, f_assign))
+ if ((SvAMAGIC(left) || SvAMAGIC(right))
+ /* sprintf doesn't do concat overloading,
+ * but allow for $x .= sprintf(...)
+ */
+ && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE)
+ || i == n)
)
- left = res;
- else {
- if (left != dsv) {
- sv_setsv(dsv, left);
- left = dsv;
+ {
+ 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);
}
- sv_catsv_nomg(left, right);
+ 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);
}
- f_assign = AMGf_assign;
+ else
+ sv_setsv_flags(left, right, 0);
+ SvGETMAGIC(right);
}
}
- dsv = left;
+
+ /* nexttarg = left . right */
+ S_do_concat(aTHX_ left, right, nexttarg, 0);
+ left = nexttarg;
}
- /* assign/append RHS (dsv) to LHS (targ) */
- if (is_append) {
- if ((SvAMAGIC(targ) || SvAMAGIC(dsv))
- && (res = amagic_call(targ, dsv, concat_amg, AMGf_assign))
- )
- sv_setsv(targ, res);
- else
- sv_catsv_nomg(targ, dsv);
+ 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
- sv_setsv(targ, dsv);
+ targ = left;
+ SETs(targ);
+ RETURN;
}
-
- /* --------------------------------------------------------------
- * Phase 7:
- *
- * return result
- */
-
- phase7:
-
- SP -= stack_adj;
- SvTAINT(targ);
- SETTARG;
- RETURN;
}
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;
dSP;
SV *left, *right;
- tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
+ tryAMAGICbin_MG(eq_amg, AMGf_numeric);
right = POPs;
left = TOPs;
SETs(boolSV(
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);
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
} else {
- auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
+ /* Using 0- here and later to silence bogus warning
+ * from MS VC */
+ auv = (UV) (0 - (UV) aiv);
}
}
a_valid = 1;
buv = biv;
buvok = 1;
} else
- buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
+ 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.
PUSHi(i);
}
else
-#ifdef PERL_OP_PARENT
if (is_keys) {
/* parent op should be an unused OP_KEYS whose targ we can
* use */
PUSHi(i);
}
else
-#endif
mPUSHi(i);
}
}
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;
pm->op_pmflags & PMf_USED
#endif
) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
+ if (UNLIKELY(should_we_output_Debug_r(prog))) {
+ PerlIO_printf(Perl_debug_log, "?? already matched once");
+ }
goto nope;
}
}
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)));
+ 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;
}
}
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) {
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));
+ /* 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)) {
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
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)
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;
+ }
}
(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));
+ | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0));
TAINT_NOT;
}
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);
}
SvPV_set(dstr, NULL);
SPAGAIN;
- mPUSHi(iters);
+ if (PL_op->op_private & OPpTRUEBOOL)
+ PUSHs(&PL_sv_yes);
+ else
+ mPUSHi(iters);
}
}
else sv = AvARRAY(av)[i];
if (sv) SP[i+1] = sv;
else {
- SP[i+1] = newSVavdefelem(av, i, 1);
+ SP[i+1] = av_nonelem(av, i);
}
}
SP += items;
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);
+ MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend");
}
#endif
if (!svp || !*svp) {
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));
+ /* 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)) {
https://perl5.git.perl.org / perl5.git / blobdiff