#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
+#include "regcomp.h"
/* Hot code. */
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 */
/* 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
* 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.
* 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++) {
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
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;
}
#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,
+ 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)));
+ 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 */
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. */
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;
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)