#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
+#include "regcomp.h"
/* Hot code. */
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 */
for ease of testing and setting) */
/* for each arg, holds the result of an SvPV() call */
struct multiconcat_svpv {
- char *pv;
+ const char *pv;
SSize_t len;
}
*targ_chain, /* chain of slots where targ has appeared on RHS */
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;
/* an undef value in the presence of warnings may trigger
* side affects */
goto do_magical;
- svpv_end->pv = (char*)"";
+ svpv_end->pv = "";
len = 0;
}
else
/* 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.
*
* one set of segment lengths.
*
* * If the string has different plain and utf8 representations
- * (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
+ * (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.
/* 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;
* 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 this is a variant string. Conversely, un-negate the
+ * 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++) {
/* 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 = -((SSize_t)targ_len);
slow_concat = TRUE;
/* 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:
SV **svp;
const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
- bool first = TRUE; /* first call to S_do_concat */
+ Size_t arg_count = 0; /* how many args have been processed */
if (!cpv) {
cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
*/
n = nargs *2 + 1;
- for (i = 0; i < n + is_append; i++) {
+ 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 */
- SSize_t len = lens[i >> 1].ssize;
+ len = lens[i >> 1].ssize;
if (i == n) {
/* handle the final targ .= (....) */
right = left;
cpv += len;
}
- if (!left) {
+ arg_count++;
+
+ if (arg_count <= 1) {
left = right;
continue; /* need at least two SVs to concat together */
}
- if (first && i < n) {
+ 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;
- first = FALSE;
}
else {
nexttarg = left;
SV * const tmpsv = amagic_call(left, right, concat_amg,
(nextappend ? AMGf_assign: 0));
if (tmpsv) {
- /* NB: tryAMAGICbin_MG() includes an SvPADMY test
- * here, which isn;t needed as any implicit
- * assign does under OPpTARGET_MY is done after
+ /* 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);
SP = toparg - stack_adj + 1;
- /* Assign result of all RHS concats (left) to LHS (targ).
+ /* 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)
- SvTAINT(targ);
- else {
+ 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;
}
{
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;
}
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);
}
}
#endif
)
{
- dVAR;
SV **relem;
SV **lelem;
SSize_t lcount = lastlelem - firstlelem + 1;
PP(pp_aassign)
{
- dVAR; dSP;
+ dSP;
SV **lastlelem = PL_stack_sp;
SV **lastrelem = PL_stack_base + POPMARK;
SV **firstrelem = PL_stack_base + POPMARK + 1;
if (!SvIMMORTAL(lsv)) {
sv_set_undef(lsv);
SvSETMAGIC(lsv);
- *relem++ = lsv;
}
+ *relem++ = lsv;
break;
} /* switch */
} /* while */
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;
}
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
- if (av_tindex(GvAVn(PL_last_in_gv)) < 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 */
}
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) {
IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- len = av_tindex(av);
+ len = av_top_index(av);
/* Resolve a negative index that falls within
* the array. Leave it negative it if falls
* outside the array. */
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;
+ }
}
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;
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) {
IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- len = av_tindex(av);
+ 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)
https://perl5.git.perl.org / perl5.git / blobdiff