#endif
#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
- DEBUG_EXECUTE_r(re_printf( "%s", non_utf8_target_but_utf8_required));\
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%s", non_utf8_target_but_utf8_required));\
goto target; \
} STMT_END
#define HOPBACKc(pos, off) \
(char*)(reginfo->is_utf8_target \
- ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \
+ ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(reginfo->strbeg)) \
: (pos - off >= reginfo->strbeg) \
? (U8*)pos - off \
: NULL)
DEBUG_BUFFERS_r(
if ((int)maxopenparen > (int)parenfloor)
- re_printf(
+ Perl_re_printf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
PTR2UV(rex),
PTR2UV(rex->offs)
SSPUSHIV(rex->offs[p].end);
SSPUSHIV(rex->offs[p].start);
SSPUSHINT(rex->offs[p].start_tmp);
- DEBUG_BUFFERS_r(re_printf(
+ DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
" \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
(UV)p,
(IV)rex->offs[p].start,
/* These are needed since we do not localize EVAL nodes: */
#define REGCP_SET(cp) \
DEBUG_STATE_r( \
- re_exec_indentf( \
+ Perl_re_exec_indentf( aTHX_ \
"Setting an EVAL scope, savestack=%"IVdf",\n", \
depth, (IV)PL_savestack_ix \
) \
#define REGCP_UNWIND(cp) \
DEBUG_STATE_r( \
if (cp != PL_savestack_ix) \
- re_exec_indentf( \
+ Perl_re_exec_indentf( aTHX_ \
"Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n",\
depth, (IV)(cp), (IV)PL_savestack_ix \
) \
/* Now restore the parentheses context. */
DEBUG_BUFFERS_r(
if (i || rex->lastparen + 1 <= rex->nparens)
- re_printf(
+ Perl_re_printf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
PTR2UV(rex),
PTR2UV(rex->offs)
tmps = SSPOPIV;
if (paren <= rex->lastparen)
rex->offs[paren].end = tmps;
- DEBUG_BUFFERS_r( re_printf(
+ DEBUG_BUFFERS_r( Perl_re_printf( aTHX_
" \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
(UV)paren,
(IV)rex->offs[paren].start,
if (i > *maxopenparen_p)
rex->offs[i].start = -1;
rex->offs[i].end = -1;
- DEBUG_BUFFERS_r( re_printf(
+ DEBUG_BUFFERS_r( Perl_re_printf( aTHX_
" \\%"UVuf": %s ..-1 undeffing\n",
(UV)i,
(i > *maxopenparen_p) ? "-1" : " "
case _CC_ENUM_ALPHA: return isALPHA_LC(character);
case _CC_ENUM_ASCII: return isASCII_LC(character);
case _CC_ENUM_BLANK: return isBLANK_LC(character);
- case _CC_ENUM_CASED: return isLOWER_LC(character)
+ case _CC_ENUM_CASED: return isLOWER_LC(character)
|| isUPPER_LC(character);
case _CC_ENUM_CNTRL: return isCNTRL_LC(character);
case _CC_ENUM_DIGIT: return isDIGIT_LC(character);
PERL_UNUSED_ARG(flags);
PERL_UNUSED_ARG(data);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"Intuit: trying to determine minimum start position...\n"));
/* for now, assume that all substr offsets are positive. If at some point
* to quickly reject some cases that can't match, but will reject
* them later after doing full char arithmetic */
if (prog->minlen > strend - strpos) {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" String too short...\n"));
goto fail;
}
if (!sv)
continue;
- re_printf(
+ Perl_re_printf( aTHX_
" substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf
" useful=%"IVdf" utf8=%d [%s]\n",
i,
if ( strpos != strbeg
&& (prog->intflags & PREGf_ANCH_SBOL))
{
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Not at start...\n"));
goto fail;
}
SSize_t slen = SvCUR(check);
char *s = HOP3c(strpos, prog->check_offset_min, strend);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Looking for check substr at fixed offset %"IVdf"...\n",
(IV)prog->check_offset_min));
|| strend - s < slen - 1
|| (strend - s == slen && strend[-1] != '\n')))
{
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" String too long...\n"));
goto fail_finish;
}
if (slen && (*SvPVX_const(check) != *s
|| (slen > 1 && memNE(SvPVX_const(check), s, slen))))
{
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" String not equal...\n"));
goto fail_finish;
}
U8* end_point;
DEBUG_OPTIMISE_MORE_r({
- re_printf(
+ Perl_re_printf( aTHX_
" At restart: rx_origin=%"IVdf" Check offset min: %"IVdf
" Start shift: %"IVdf" End shift %"IVdf
" Real end Shift: %"IVdf"\n",
check_at = fbm_instr( start_point, end_point,
check, multiline ? FBMrf_MULTILINE : 0);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" doing 'check' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
(IV)((char*)start_point - strbeg),
(IV)((char*)end_point - strbeg),
DEBUG_EXECUTE_r({
RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
- re_printf( " %s %s substr %s%s%s",
+ Perl_re_printf( aTHX_ " %s %s substr %s%s%s",
(check_at ? "Found" : "Did not find"),
(check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
? "anchored" : "floating"),
if (check_at - rx_origin > prog->check_offset_max)
rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
/* Finish the diagnostic message */
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"%ld (rx_origin now %"IVdf")...\n",
(long)(check_at - strbeg),
(IV)(rx_origin - strbeg)
char *from = s;
char *to = last + SvCUR(must) - (SvTAIL(must)!=0);
+ if (to > strend)
+ to = strend;
if (from > to) {
s = NULL;
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" skipping 'other' fbm scan: %"IVdf" > %"IVdf"\n",
(IV)(from - strbeg),
(IV)(to - strbeg)
must,
multiline ? FBMrf_MULTILINE : 0
);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" doing 'other' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
(IV)(from - strbeg),
(IV)(to - strbeg),
DEBUG_EXECUTE_r({
RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
- re_printf( " %s %s substr %s%s",
+ Perl_re_printf( aTHX_ " %s %s substr %s%s",
s ? "Found" : "Contradicts",
other_ix ? "floating" : "anchored",
quoted, RE_SV_TAIL(must));
/* last1 is latest possible substr location. If we didn't
* find it before there, we never will */
if (last >= last1) {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"; giving up...\n"));
goto fail_finish;
}
other_ix /* i.e. if other-is-float */
? HOP3c(rx_origin, 1, strend)
: HOP4c(last, 1 - other->min_offset, strbeg, strend);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"; about to retry %s at offset %ld (rx_origin now %"IVdf")...\n",
(other_ix ? "floating" : "anchored"),
(long)(HOP3c(check_at, 1, strend) - strbeg),
rx_origin = HOP3c(s, -other->min_offset, strbeg);
other_last = HOP3c(s, 1, strend);
}
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" at offset %ld (rx_origin now %"IVdf")...\n",
(long)(s - strbeg),
(IV)(rx_origin - strbeg)
}
else {
DEBUG_OPTIMISE_MORE_r(
- re_printf(
+ Perl_re_printf( aTHX_
" Check-only match: offset min:%"IVdf" max:%"IVdf
" check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf
" strend:%"IVdf"\n",
if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') {
char *s;
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" looking for /^/m anchor"));
/* we have failed the constraint of a \n before rx_origin.
if (s <= rx_origin ||
! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
{
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Did not find /%s^%s/m...\n",
PL_colors[0], PL_colors[1]));
goto fail_finish;
/* Position contradicts check-string; either because
* check was anchored (and thus has no wiggle room),
* or check was float and rx_origin is above the float range */
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n",
PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
goto restart;
* contradict. On the other hand, the float "check" substr
* didn't contradict, so just retry the anchored "other"
* substr */
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n",
PL_colors[0], PL_colors[1],
(IV)(rx_origin - strbeg + prog->anchored_offset),
/* success: we don't contradict the found floating substring
* (and there's no anchored substr). */
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Found /%s^%s/m with rx_origin %ld...\n",
PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
}
else {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" (multiline anchor test skipped)\n"));
}
else
endpos= strend;
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" looking for class: start_shift: %"IVdf" check_at: %"IVdf
" rx_origin: %"IVdf" endpos: %"IVdf"\n",
(IV)start_shift, (IV)(check_at - strbeg),
reginfo);
if (!s) {
if (endpos == strend) {
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" Could not match STCLASS...\n") );
goto fail;
}
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" This position contradicts STCLASS...\n") );
if ((prog->intflags & PREGf_ANCH) && !ml_anch
&& !(prog->intflags & PREGf_IMPLICIT))
* an extra anchored search may get done, but in
* practice the extra fbm_instr() is likely to
* get skipped anyway. */
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" about to retry anchored at offset %ld (rx_origin now %"IVdf")...\n",
(long)(other_last - strbeg),
(IV)(rx_origin - strbeg)
* but since we goto a block of code that's going to
* search for the next \n if any, its safe here */
rx_origin++;
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" about to look for /%s^%s/m starting at rx_origin %ld...\n",
PL_colors[0], PL_colors[1],
(long)(rx_origin - strbeg)) );
* It's conservative: it errs on the side of doing 'goto restart',
* where there is code that does a proper char-based test */
if (rx_origin + start_shift + end_shift > strend) {
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" Could not match STCLASS...\n") );
goto fail;
}
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
" about to look for %s substr starting at offset %ld (rx_origin now %"IVdf")...\n",
(prog->substrs->check_ix ? "floating" : "anchored"),
(long)(rx_origin + start_shift - strbeg),
/* Success !!! */
if (rx_origin != s) {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" By STCLASS: moving %ld --> %ld\n",
(long)(rx_origin - strbeg), (long)(s - strbeg))
);
}
else {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
" Does not contradict STCLASS...\n");
);
}
/* Fixed substring is found far enough so that the match
cannot start at strpos. */
- DEBUG_EXECUTE_r(re_printf( " try at offset...\n"));
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " try at offset...\n"));
++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
}
else {
)))
{
/* If flags & SOMETHING - do not do it many times on the same match */
- DEBUG_EXECUTE_r(re_printf( " ... Disabling check substring...\n"));
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " ... Disabling check substring...\n"));
/* XXX Does the destruction order has to change with utf8_target? */
SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
}
}
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"Intuit: %sSuccessfully guessed:%s match at offset %ld\n",
PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) );
if (prog->check_substr || prog->check_utf8) /* could be removed already */
BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
fail:
- DEBUG_EXECUTE_r(re_printf( "%sMatch rejected by optimizer%s\n",
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch rejected by optimizer%s\n",
PL_colors[4], PL_colors[5]));
return NULL;
}
while (s < strend) {
GCB_enum after = getGCB_VAL_UTF8((U8*) s,
(U8*) reginfo->strend);
- if ( (to_complement ^ isGCB(before, after))
+ if ( (to_complement ^ isGCB(before,
+ after,
+ (U8*) reginfo->strbeg,
+ (U8*) s,
+ utf8_target))
&& (reginfo->intuit || regtry(reginfo, &s)))
{
goto got_it;
if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
dump_exec_pos( (char *)uc, c, strend, real_start,
(char *)uc, utf8_target, 0 );
- re_printf(
+ Perl_re_printf( aTHX_
" Scanning for legal start char...\n");
}
);
DEBUG_TRIE_EXECUTE_r({
dump_exec_pos( (char *)uc, c, strend,
real_start, s, utf8_target, 0);
- re_printf(
+ Perl_re_printf( aTHX_
" Charid:%3u CP:%4"UVxf" ",
charid, uvc);
});
if (failed)
dump_exec_pos( (char *)uc, c, strend, real_start,
s, utf8_target, 0 );
- re_printf(
+ Perl_re_printf( aTHX_
"%sState: %4"UVxf", word=%"UVxf,
failed ? " Fail transition to " : "",
(UV)state, (UV)word);
&& (tmp=trie->trans[offset].next))
{
DEBUG_TRIE_EXECUTE_r(
- re_printf(" - legal\n"));
+ Perl_re_printf( aTHX_ " - legal\n"));
state = tmp;
break;
}
else {
DEBUG_TRIE_EXECUTE_r(
- re_printf(" - fail\n"));
+ Perl_re_printf( aTHX_ " - fail\n"));
failed = 1;
state = aho->fail[state];
}
else {
/* we must be accepting here */
DEBUG_TRIE_EXECUTE_r(
- re_printf(" - accepting\n"));
+ Perl_re_printf( aTHX_ " - accepting\n"));
failed = 1;
break;
}
if (leftmost) {
s = (char*)leftmost;
DEBUG_TRIE_EXECUTE_r({
- re_printf( "Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
+ Perl_re_printf( aTHX_ "Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
(UV)accepted_word, (IV)(s - real_start)
);
});
}
s = HOPc(s,1);
DEBUG_TRIE_EXECUTE_r({
- re_printf("Pattern failed. Looking for new start point...\n");
+ Perl_re_printf( aTHX_ "Pattern failed. Looking for new start point...\n");
});
} else {
DEBUG_TRIE_EXECUTE_r(
- re_printf("No match.\n"));
+ Perl_re_printf( aTHX_ "No match.\n"));
break;
}
}
if (flags & REXEC_COPY_STR) {
#ifdef PERL_ANY_COW
if (SvCANCOW(sv)) {
- if (DEBUG_C_TEST) {
- re_printf(
+ DEBUG_C(Perl_re_printf( aTHX_
"Copy on write: regexp capture, type %d\n",
- (int) SvTYPE(sv));
- }
+ (int) SvTYPE(sv)));
/* Create a new COW SV to share the match string and store
* in saved_copy, unless the current COW SV in saved_copy
* is valid and suitable for our purpose */
? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
: strbeg; /* pos() not defined; use start of string */
- DEBUG_GPOS_r(re_printf(
+ DEBUG_GPOS_r(Perl_re_printf( aTHX_
"GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg)));
/* in the presence of \G, we may need to start looking earlier in
if (!startpos ||
((flags & REXEC_FAIL_ON_UNDERFLOW) && startpos < stringarg))
{
- DEBUG_r(re_printf(
+ DEBUG_r(Perl_re_printf( aTHX_
"fail: ganch-gofs before earliest possible start\n"));
return 0;
}
minlen = prog->minlen;
if ((startpos + minlen) > strend || startpos < strbeg) {
- DEBUG_r(re_printf(
+ DEBUG_r(Perl_re_printf( aTHX_
"Regex match can't succeed, so not even tried\n"));
return 0;
}
{
/* this should only be possible under \G */
assert(prog->intflags & PREGf_GPOS_SEEN);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
goto phooey;
}
multiline = prog->extflags & RXf_PMf_MULTILINE;
if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"String too short [regexec_flags]...\n"));
goto phooey;
}
swap = prog->offs;
/* do we need a save destructor here for eval dies? */
Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
- DEBUG_BUFFERS_r(re_printf(
+ DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
"rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
PTR2UV(prog),
PTR2UV(swap),
);
}
DEBUG_EXECUTE_r(if (!did_match)
- re_printf(
+ Perl_re_printf( aTHX_
"Did not find anchored character...\n")
);
}
DEBUG_EXECUTE_r(if (!did_match) {
RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
- re_printf( "Did not find %s substr %s%s...\n",
+ Perl_re_printf( aTHX_ "Did not find %s substr %s%s...\n",
((must == prog->anchored_substr || must == prog->anchored_utf8)
? "anchored" : "floating"),
quoted, RE_SV_TAIL(must));
{
RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
s,strend-s,60);
- re_printf(
+ Perl_re_printf( aTHX_
"Matching stclass %.*s against %s (%d bytes)\n",
(int)SvCUR(prop), SvPVX_const(prop),
quoted, (int)(strend - s));
});
if (find_byclass(prog, c, s, strend, reginfo))
goto got_it;
- DEBUG_EXECUTE_r(re_printf( "Contradicts stclass... [regexec_flags]\n"));
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Contradicts stclass... [regexec_flags]\n"));
}
else {
dontbother = 0;
* the \n. */
char *checkpos= strend - len;
DEBUG_OPTIMISE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"%sChecking for float_real.%s\n",
PL_colors[4], PL_colors[5]));
if (checkpos + 1 < strbeg) {
/* can't match, even if we remove the trailing \n
* string is too short to match */
DEBUG_EXECUTE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"%sString shorter than required trailing substring, cannot match.%s\n",
PL_colors[4], PL_colors[5]));
goto phooey;
/* cant match, string is too short when the "\n" is
* included */
DEBUG_EXECUTE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"%sString does not contain required trailing substring, cannot match.%s\n",
PL_colors[4], PL_colors[5]));
goto phooey;
last= checkpos;
} else {
DEBUG_EXECUTE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"%sString does not contain required trailing substring, cannot match.%s\n",
PL_colors[4], PL_colors[5]));
goto phooey;
* pretty sure it is not anymore, so I have removed the comment
* and replaced it with this one. Yves */
DEBUG_EXECUTE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"%sString does not contain required substring, cannot match.%s\n",
PL_colors[4], PL_colors[5]
));
{
/* this should only be possible under \G */
assert(prog->intflags & PREGf_GPOS_SEEN);
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
goto phooey;
}
DEBUG_BUFFERS_r(
if (swap)
- re_printf(
+ Perl_re_printf( aTHX_
"rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
PTR2UV(prog),
PTR2UV(swap)
return 1;
phooey:
- DEBUG_EXECUTE_r(re_printf( "%sMatch failed%s\n",
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch failed%s\n",
PL_colors[4], PL_colors[5]));
/* clean up; this will trigger destructors that will free all slabs
if (swap) {
/* we failed :-( roll it back */
- DEBUG_BUFFERS_r(re_printf(
+ DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
"rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
PTR2UV(prog),
PTR2UV(prog->offs),
messages are inline with the regop output that created them.
*/
#define REPORT_CODE_OFF 29
-#define INDENT_CHARS(depth) ((depth) % 20)
+#define INDENT_CHARS(depth) ((int)(depth) % 20)
#ifdef DEBUGGING
int
Perl_re_exec_indentf(pTHX_ const char *fmt, U32 depth, ...)
PerlIO *f= Perl_debug_log;
PERL_ARGS_ASSERT_RE_EXEC_INDENTF;
va_start(ap, depth);
- PerlIO_printf(f, "%*s|%4d| %*s", REPORT_CODE_OFF, "", depth, INDENT_CHARS(depth), "" );
+ PerlIO_printf(f, "%*s|%4"UVuf"| %*s", REPORT_CODE_OFF, "", (UV)depth, INDENT_CHARS(depth), "" );
result = PerlIO_vprintf(f, fmt, ap);
va_end(ap);
return result;
#define DEBUG_STATE_pp(pp) \
DEBUG_STATE_r({ \
DUMP_EXEC_POS(locinput, scan, utf8_target,depth); \
- re_printf( \
+ Perl_re_printf( aTHX_ \
"%*s" pp " %s%s%s%s%s\n", \
INDENT_CHARS(depth), "", \
PL_reg_name[st->resume_state], \
RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
start, end - start, 60);
- re_printf(
+ Perl_re_printf( aTHX_
"%s%s REx%s %s against %s\n",
PL_colors[4], blurb, PL_colors[5], s0, s1);
if (utf8_target||utf8_pat)
- re_printf( "UTF-8 %s%s%s...\n",
+ Perl_re_printf( aTHX_ "UTF-8 %s%s%s...\n",
utf8_pat ? "pattern" : "",
utf8_pat && utf8_target ? " and " : "",
utf8_target ? "string" : ""
locinput, loc_regeol - locinput, 10, 0, 1);
const STRLEN tlen=len0+len1+len2;
- re_printf(
+ Perl_re_printf( aTHX_
"%4"IVdf" <%.*s%.*s%s%.*s>%*s|%4u| ",
(IV)(locinput - loc_bostr),
len0, s0,
return TRUE;
}
-PERL_STATIC_INLINE bool
-S_isGCB(const GCB_enum before, const GCB_enum after)
+STATIC bool
+S_isGCB(pTHX_ const GCB_enum before, const GCB_enum after, const U8 * const strbeg, const U8 * const curpos, const bool utf8_target)
{
/* returns a boolean indicating if there is a Grapheme Cluster Boundary
- * between the inputs. See http://www.unicode.org/reports/tr29/ */
+ * between the inputs. See http://www.unicode.org/reports/tr29/. */
+
+ PERL_ARGS_ASSERT_ISGCB;
+
+ switch (GCB_table[before][after]) {
+ case GCB_BREAKABLE:
+ return TRUE;
+
+ case GCB_NOBREAK:
+ return FALSE;
+
+ case GCB_RI_then_RI:
+ {
+ int RI_count = 1;
+ U8 * temp_pos = (U8 *) curpos;
+
+ /* Do not break within emoji flag sequences. That is, do not
+ * break between regional indicator (RI) symbols if there is an
+ * odd number of RI characters before the break point.
+ * GB12 ^ (RI RI)* RI × RI
+ * GB13 [^RI] (RI RI)* RI × RI */
+
+ while (backup_one_GCB(strbeg,
+ &temp_pos,
+ utf8_target) == GCB_Regional_Indicator)
+ {
+ RI_count++;
+ }
+
+ return RI_count % 2 != 1;
+ }
+
+ case GCB_EX_then_EM:
+
+ /* GB10 ( E_Base | E_Base_GAZ ) Extend* × E_Modifier */
+ {
+ U8 * temp_pos = (U8 *) curpos;
+ GCB_enum prev;
+
+ do {
+ prev = backup_one_GCB(strbeg, &temp_pos, utf8_target);
+ }
+ while (prev == GCB_Extend);
+
+ return prev != GCB_E_Base && prev != GCB_E_Base_GAZ;
+ }
+
+ default:
+ break;
+ }
+
+#ifdef DEBUGGING
+ Perl_re_printf( aTHX_ "Unhandled GCB pair: GCB_table[%d, %d] = %d\n",
+ before, after, GCB_table[before][after]);
+ assert(0);
+#endif
+ return TRUE;
+}
+
+STATIC GCB_enum
+S_backup_one_GCB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
+{
+ GCB_enum gcb;
+
+ PERL_ARGS_ASSERT_BACKUP_ONE_GCB;
+
+ if (*curpos < strbeg) {
+ return GCB_EDGE;
+ }
+
+ if (utf8_target) {
+ U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
+ U8 * prev_prev_char_pos;
+
+ if (! prev_char_pos) {
+ return GCB_EDGE;
+ }
+
+ if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos, -1, strbeg))) {
+ gcb = getGCB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
+ *curpos = prev_char_pos;
+ prev_char_pos = prev_prev_char_pos;
+ }
+ else {
+ *curpos = (U8 *) strbeg;
+ return GCB_EDGE;
+ }
+ }
+ else {
+ if (*curpos - 2 < strbeg) {
+ *curpos = (U8 *) strbeg;
+ return GCB_EDGE;
+ }
+ (*curpos)--;
+ gcb = getGCB_VAL_CP(*(*curpos - 1));
+ }
- return GCB_table[before][after];
+ return gcb;
}
/* Combining marks attach to most classes that precede them, but this defines
PERL_ARGS_ASSERT_ISLB;
- /* Rule numbers in the comments below are as of Unicode 8.0 */
+ /* Rule numbers in the comments below are as of Unicode 9.0 */
redo:
before = prev;
* that is overriden */
return LB_table[prev][after] != LB_NOBREAK_EVEN_WITH_SP_BETWEEN;
- case LB_CM_foo:
+ case LB_CM_ZWJ_foo:
/* We don't know how to treat the CM except by looking at the first
- * non-CM character preceding it */
+ * non-CM character preceding it. ZWJ is treated as CM */
do {
prev = backup_one_LB(strbeg, &temp_pos, utf8_target);
}
- while (prev == LB_Combining_Mark);
+ while (prev == LB_Combining_Mark || prev == LB_ZWJ);
/* Here, 'prev' is that first earlier non-CM character. If the CM
* attatches to it, then it inherits the behavior of 'prev'. If it
return LB_various_then_PO_or_PR;
}
+ case LB_RI_then_RI + LB_NOBREAK:
+ case LB_RI_then_RI + LB_BREAKABLE:
+ {
+ int RI_count = 1;
+
+ /* LB30a Break between two regional indicator symbols if and
+ * only if there are an even number of regional indicators
+ * preceding the position of the break.
+ *
+ * sot (RI RI)* RI × RI
+ * [^RI] (RI RI)* RI × RI */
+
+ while (backup_one_LB(strbeg,
+ &temp_pos,
+ utf8_target) == LB_Regional_Indicator)
+ {
+ RI_count++;
+ }
+
+ return RI_count % 2 == 0;
+ }
+
default:
break;
}
#ifdef DEBUGGING
- re_printf( "Unhandled LB pair: LB_table[%d, %d] = %d\n",
+ Perl_re_printf( aTHX_ "Unhandled LB pair: LB_table[%d, %d] = %d\n",
before, after, LB_table[before][after]);
assert(0);
#endif
PERL_ARGS_ASSERT_ISWB;
- /* Rule numbers in the comments below are as of Unicode 8.0 */
+ /* Rule numbers in the comments below are as of Unicode 9.0 */
redo:
before = prev;
* the beginning of a region of text', the rule is to break before
* them, just like any other character. Therefore, the default rule
* applies and we don't have to look in more depth. Should this ever
- * change, we would have to have 2 'case' statements, like in the
- * rules below, and backup a single character (not spacing over the
- * extend ones) and then see if that is one of the region-end
- * characters and go from there */
- case WB_Ex_or_FO_then_foo:
+ * change, we would have to have 2 'case' statements, like in the rules
+ * below, and backup a single character (not spacing over the extend
+ * ones) and then see if that is one of the region-end characters and
+ * go from there */
+ case WB_Ex_or_FO_or_ZWJ_then_foo:
prev = backup_one_WB(&previous, strbeg, &before_pos, utf8_target);
goto redo;
return WB_table[before][after]
- WB_NU_then_MB_or_MN_or_SQ == WB_BREAKABLE;
+ case WB_RI_then_RI + WB_NOBREAK:
+ case WB_RI_then_RI + WB_BREAKABLE:
+ {
+ int RI_count = 1;
+
+ /* Do not break within emoji flag sequences. That is, do not
+ * break between regional indicator (RI) symbols if there is an
+ * odd number of RI characters before the potential break
+ * point.
+ *
+ * WB15 ^ (RI RI)* RI × RI
+ * WB16 [^RI] (RI RI)* RI × RI */
+
+ while (backup_one_WB(&previous,
+ strbeg,
+ &before_pos,
+ utf8_target) == WB_Regional_Indicator)
+ {
+ RI_count++;
+ }
+
+ return RI_count % 2 != 1;
+ }
+
default:
break;
}
#ifdef DEBUGGING
- re_printf( "Unhandled WB pair: WB_table[%d, %d] = %d\n",
+ Perl_re_printf( aTHX_ "Unhandled WB pair: WB_table[%d, %d] = %d\n",
before, after, WB_table[before][after]);
assert(0);
#endif
*previous = (*curpos <= strbeg) ? WB_EDGE : WB_UNKNOWN;
}
- /* And we always back up over these two types */
- if (wb != WB_Extend && wb != WB_Format) {
+ /* And we always back up over these three types */
+ if (wb != WB_Extend && wb != WB_Format && wb != WB_ZWJ) {
return wb;
}
}
*curpos = (U8 *) strbeg;
return WB_EDGE;
}
- } while (wb == WB_Extend || wb == WB_Format);
+ } while (wb == WB_Extend || wb == WB_Format || wb == WB_ZWJ);
}
else {
do {
return wb;
}
+#define EVAL_CLOSE_PAREN_IS(st,expr) \
+( \
+ ( ( st ) ) && \
+ ( ( st )->u.eval.close_paren ) && \
+ ( ( ( st )->u.eval.close_paren ) == ( (expr) + 1 ) ) \
+)
+
+#define EVAL_CLOSE_PAREN_IS_TRUE(st,expr) \
+( \
+ ( ( st ) ) && \
+ ( ( st )->u.eval.close_paren ) && \
+ ( ( expr ) ) && \
+ ( ( ( st )->u.eval.close_paren ) == ( (expr) + 1 ) ) \
+)
+
+
+#define EVAL_CLOSE_PAREN_SET(st,expr) \
+ (st)->u.eval.close_paren = ( (expr) + 1 )
+
+#define EVAL_CLOSE_PAREN_CLEAR(st) \
+ (st)->u.eval.close_paren = 0
+
/* returns -1 on failure, $+[0] on success */
STATIC SSize_t
S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
bool is_utf8_pat = reginfo->is_utf8_pat;
bool match = FALSE;
+/* Solaris Studio 12.3 messes up fetching PL_charclass['\n'] */
+#if (defined(__SUNPRO_C) && (__SUNPRO_C == 0x5120) && defined(__x86_64) && defined(USE_64_BIT_ALL))
+# define SOLARIS_BAD_OPTIMIZER
+ const U32 *pl_charclass_dup = PL_charclass;
+# define PL_charclass pl_charclass_dup
+#endif
+
#ifdef DEBUGGING
GET_RE_DEBUG_FLAGS_DECL;
#endif
PERL_ARGS_ASSERT_REGMATCH;
DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
- re_printf("regmatch start\n");
+ Perl_re_printf( aTHX_ "regmatch start\n");
}));
st = PL_regmatch_state;
DUMP_EXEC_POS( locinput, scan, utf8_target, depth );
regprop(rex, prop, scan, reginfo, NULL);
- re_printf(
+ Perl_re_printf( aTHX_
"%*s%"IVdf":%s(%"IVdf")\n",
INDENT_CHARS(depth), "",
(IV)(scan - rexi->program),
*/
if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
DEBUG_EXECUTE_r(
- re_exec_indentf( "%sfailed to match trie start class...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n",
depth, PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
{
if (trie->states[ state ].wordnum) {
DEBUG_EXECUTE_r(
- re_exec_indentf( "%smatched empty string...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%smatched empty string...%s\n",
depth, PL_colors[4], PL_colors[5])
);
if (!trie->jump)
break;
} else {
DEBUG_EXECUTE_r(
- re_exec_indentf( "%sfailed to match trie start class...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n",
depth, PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
DEBUG_TRIE_EXECUTE_r({
DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth );
- re_exec_indentf(
+ Perl_re_exec_indentf( aTHX_
"%sState: %4"UVxf" Accepted: %c ",
depth, PL_colors[4],
(UV)state, (accepted ? 'Y' : 'N'));
state = 0;
}
DEBUG_TRIE_EXECUTE_r(
- re_printf(
+ Perl_re_printf( aTHX_
"Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
charid, uvc, (UV)state, PL_colors[5] );
);
}
DEBUG_EXECUTE_r(
- re_exec_indentf( "%sgot %"IVdf" possible matches%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sgot %"IVdf" possible matches%s\n",
depth,
PL_colors[4], (IV)ST.accepted, PL_colors[5] );
);
}
if (!--ST.accepted) {
DEBUG_EXECUTE_r({
- re_exec_indentf( "%sTRIE failed...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE failed...%s\n",
depth,
PL_colors[4],
PL_colors[5] );
: NEXT_OFF(ST.me));
DEBUG_EXECUTE_r({
- re_exec_indentf( "%sTRIE matched word #%d, continuing%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE matched word #%d, continuing%s\n",
depth,
PL_colors[4],
ST.nextword,
? av_fetch(trie_words, ST.nextword - 1, 0) : NULL;
SV *sv= tmp ? sv_newmortal() : NULL;
- re_exec_indentf( "%sonly one match left, short-circuiting: #%d <%s>%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sonly one match left, short-circuiting: #%d <%s>%s\n",
depth, PL_colors[4],
ST.nextword,
tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
b1 = (locinput == reginfo->strbeg)
? 0 /* isWORDCHAR_L1('\n') */
: isWORDCHAR_utf8(reghop3((U8*)locinput, -1,
- (U8*)(reginfo->strbeg)));
+ (U8*)(reginfo->strbeg)));
b2 = (NEXTCHR_IS_EOS)
? 0 /* isWORDCHAR_L1('\n') */
: isWORDCHAR_utf8((U8*)locinput);
(U8*)(reginfo->strbeg)),
(U8*) reginfo->strend),
getGCB_VAL_UTF8((U8*) locinput,
- (U8*) reginfo->strend));
+ (U8*) reginfo->strend),
+ (U8*) reginfo->strbeg,
+ (U8*) locinput,
+ utf8_target);
}
break;
if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) {
sayNO;
}
+
+ locinput++;
+ break;
}
- else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
- if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
- EIGHT_BIT_UTF8_TO_NATIVE(nextchr,
- *(locinput + 1))))))
- {
- sayNO;
- }
- }
- else { /* Here, must be an above Latin-1 code point */
+
+ if (! UTF8_IS_DOWNGRADEABLE_START(nextchr)) { /* An above Latin-1 code point */
_CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend);
goto utf8_posix_above_latin1;
}
- /* Here, must be utf8 */
- locinput += UTF8SKIP(locinput);
- break;
+ /* Here is a UTF-8 variant code point below 256 and the target is
+ * UTF-8 */
+ if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
+ EIGHT_BIT_UTF8_TO_NATIVE(nextchr,
+ *(locinput + 1))))))
+ {
+ sayNO;
+ }
+
+ goto increment_locinput;
case NPOSIXD: /* \W or [:^punct:] etc. under /d */
to_complement = 1;
while (locinput < reginfo->strend) {
GCB_enum cur_gcb = getGCB_VAL_UTF8((U8*) locinput,
(U8*) reginfo->strend);
- if (isGCB(prev_gcb, cur_gcb)) {
+ if (isGCB(prev_gcb, cur_gcb,
+ (U8*) reginfo->strbeg, (U8*) locinput,
+ utf8_target))
+ {
break;
}
DEBUG_r({
GET_RE_DEBUG_FLAGS_DECL;
DEBUG_STACK_r({
- re_exec_indentf(
+ Perl_re_exec_indentf( aTHX_
"entering GOSUB, prev_recurse_locinput=%p recurse_locinput[%d]=%p\n",
depth, ST.prev_recurse_locinput, arg, rex->recurse_locinput[arg]
);
}
nop = nop->op_next;
- DEBUG_STATE_r( re_printf(
+ DEBUG_STATE_r( Perl_re_printf( aTHX_
" re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
rex->offs[0].end = locinput - reginfo->strbeg;
}
case EVAL_AB: /* cleanup after a successful (??{A})B */
+ /* note: this is called twice; first after popping B, then A */
DEBUG_STACK_r({
- re_exec_indentf( "EVAL_AB cur_eval=%p prev_eval=%p\n",
+ Perl_re_exec_indentf( aTHX_ "EVAL_AB cur_eval=%p prev_eval=%p\n",
depth, cur_eval, ST.prev_eval);
});
#define SET_RECURSE_LOCINPUT(STR,VAL)\
if ( cur_eval && CUR_EVAL.close_paren ) {\
- DEBUG_EXECUTE_r({ \
- re_exec_indentf( "EVAL_AB[before] GOSUB%d ce=%p recurse_locinput=%p\n",\
+ DEBUG_STACK_r({ \
+ Perl_re_exec_indentf( aTHX_ STR " GOSUB%d ce=%p recurse_locinput=%p\n",\
depth, \
CUR_EVAL.close_paren - 1,\
cur_eval, \
case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
/* note: this is called twice; first after popping B, then A */
DEBUG_STACK_r({
- re_exec_indentf( "EVAL_AB_fail cur_eval=%p prev_eval=%p\n",
+ Perl_re_exec_indentf( aTHX_ "EVAL_AB_fail cur_eval=%p prev_eval=%p\n",
depth, cur_eval, ST.prev_eval);
});
rex->offs[n].start_tmp = locinput - reginfo->strbeg;
if (n > maxopenparen)
maxopenparen = n;
- DEBUG_BUFFERS_r(re_printf(
+ DEBUG_BUFFERS_r(Perl_re_printf( aTHX_
"rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
PTR2UV(rex),
PTR2UV(rex->offs),
#define CLOSE_CAPTURE \
rex->offs[n].start = rex->offs[n].start_tmp; \
rex->offs[n].end = locinput - reginfo->strbeg; \
- DEBUG_BUFFERS_r(re_printf( \
+ DEBUG_BUFFERS_r(Perl_re_printf( aTHX_ \
"rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
PTR2UV(rex), \
PTR2UV(rex->offs), \
case INSUBP: /* (?(R)) */
n = ARG(scan);
+ /* this does not need to use EVAL_CLOSE_PAREN macros, as the arg
+ * of SCAN is already set up as matches a eval.close_paren */
sw = cur_eval && (n == 0 || CUR_EVAL.close_paren == n);
break;
ST.cache_mask = 0;
- DEBUG_EXECUTE_r( re_exec_indentf( "whilem: matched %ld out of %d..%d\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: matched %ld out of %d..%d\n",
depth, (long)n, min, max)
);
/* If degenerate A matches "", assume A done. */
if (locinput == cur_curlyx->u.curlyx.lastloc) {
- DEBUG_EXECUTE_r( re_exec_indentf( "whilem: empty match detected, trying continuation...\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: empty match detected, trying continuation...\n",
depth)
);
goto do_whilem_B_max;
reginfo->poscache_size = size;
Newxz(aux->poscache, size, char);
}
- DEBUG_EXECUTE_r( re_printf(
+ DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
"%swhilem: Detected a super-linear match, switching on caching%s...\n",
PL_colors[4], PL_colors[5])
);
mask = 1 << (offset % 8);
offset /= 8;
if (reginfo->info_aux->poscache[offset] & mask) {
- DEBUG_EXECUTE_r( re_exec_indentf( "whilem: (cache) already tried at this position...\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n",
depth)
);
sayNO; /* cache records failure */
case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
REGCP_UNWIND(ST.lastcp);
regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
- DEBUG_EXECUTE_r(re_exec_indentf( "whilem: failed, trying continuation...\n",
+ DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "whilem: failed, trying continuation...\n",
depth)
);
do_whilem_B_max:
CACHEsayNO;
}
- DEBUG_EXECUTE_r(re_exec_indentf( "trying longer...\n", depth)
+ DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "trying longer...\n", depth)
);
/* Try grabbing another A and see if it helps. */
cur_curlyx->u.curlyx.lastloc = locinput;
/* no more branches? */
if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
DEBUG_EXECUTE_r({
- re_exec_indentf( "%sBRANCH failed...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sBRANCH failed...%s\n",
depth,
PL_colors[4],
PL_colors[5] );
ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
}
DEBUG_EXECUTE_r(
- re_exec_indentf( "CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
+ Perl_re_exec_indentf( aTHX_ "CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
depth, (IV) ST.count, (IV)ST.alen)
);
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.me->flags))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags))
goto fake_end;
{
if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
- || EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.me->flags))
+ || EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags))
sayNO;
curlym_do_B: /* execute the B in /A{m,n}B/ */
}
DEBUG_EXECUTE_r(
- re_exec_indentf( "CURLYM trying tail with matches=%"IVdf"...\n",
+ Perl_re_exec_indentf( aTHX_ "CURLYM trying tail with matches=%"IVdf"...\n",
depth, (IV)ST.count)
);
if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) {
{
/* simulate B failing */
DEBUG_OPTIMISE_r(
- re_exec_indentf( "CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n",
+ Perl_re_exec_indentf( aTHX_ "CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n",
depth,
valid_utf8_to_uvchr((U8 *) locinput, NULL),
valid_utf8_to_uvchr(ST.c1_utf8, NULL),
else if (nextchr != ST.c1 && nextchr != ST.c2) {
/* simulate B failing */
DEBUG_OPTIMISE_r(
- re_exec_indentf( "CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n",
+ Perl_re_exec_indentf( aTHX_ "CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n",
depth,
(int) nextchr, ST.c1, ST.c2)
);
else
rex->offs[paren].end = -1;
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.me->flags))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags))
{
if (ST.count)
goto fake_end;
maxopenparen = ST.paren;
ST.min = ARG1(scan); /* min to match */
ST.max = ARG2(scan); /* max to match */
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.paren))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren))
{
ST.min=1;
ST.max=1;
assert(n == REG_INFTY || locinput == li);
}
CURLY_SETPAREN(ST.paren, ST.count);
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.paren))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren))
goto fake_end;
PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput);
}
{
curly_try_B_min:
CURLY_SETPAREN(ST.paren, ST.count);
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.paren))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren))
goto fake_end;
PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput);
}
curly_try_B_max:
/* a successful greedy match: now try to match B */
- if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.paren))
+ if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren))
goto fake_end;
{
bool could_match = locinput < reginfo->strend;
SET_reg_curpm(rex_sv);
rex = ReANY(rex_sv);
rexi = RXi_GET(rex);
+
+ st->u.eval.prev_curlyx = cur_curlyx;
cur_curlyx = CUR_EVAL.prev_curlyx;
REGCP_SET(st->u.eval.lastcp);
st->u.eval.prev_eval = cur_eval;
cur_eval = CUR_EVAL.prev_eval;
DEBUG_EXECUTE_r(
- re_exec_indentf( "EVAL trying tail ... (cur_eval=%p)\n",
+ Perl_re_exec_indentf( aTHX_ "EVAL trying tail ... (cur_eval=%p)\n",
depth, cur_eval););
if ( nochange_depth )
nochange_depth--;
}
if (locinput < reginfo->till) {
- DEBUG_EXECUTE_r(re_printf(
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
"%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
PL_colors[4],
(long)(locinput - startpos),
case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
DEBUG_EXECUTE_r(
- re_exec_indentf( "%ssubpattern success...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%ssubpattern success...%s\n",
depth, PL_colors[4], PL_colors[5]));
sayYES; /* Success! */
sv_commit = ST.mark_name;
DEBUG_EXECUTE_r({
- re_exec_indentf( "%ssetting cutpoint to mark:%"SVf"...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%ssetting cutpoint to mark:%"SVf"...%s\n",
depth,
PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
});
slab = slab->prev;
cur = SLAB_LAST(slab);
}
- re_exec_indentf("#%-3d %-10s %s\n",
+ Perl_re_exec_indentf( aTHX_ "#%-3d %-10s %s\n",
depth,
curd, PL_reg_name[cur->resume_state],
(curyes == cur) ? "yes" : ""
/* NOTREACHED */
}
}
+#ifdef SOLARIS_BAD_OPTIMIZER
+# undef PL_charclass
+#endif
/*
* We get here only if there's trouble -- normally "case END" is
goto reenter_switch;
}
- DEBUG_EXECUTE_r(re_printf( "%sMatch successful!%s\n",
+ DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch successful!%s\n",
PL_colors[4], PL_colors[5]));
if (reginfo->info_aux_eval) {
no:
DEBUG_EXECUTE_r(
- re_exec_indentf( "%sfailed...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sfailed...%s\n",
depth,
PL_colors[4], PL_colors[5])
);
yes_state = st->u.yes.prev_yes_state;
state_num = st->resume_state + 1; /* failure = success + 1 */
+ PERL_ASYNC_CHECK();
goto reenter_switch;
}
result = 0;
DEBUG_EXECUTE_r({
SV * const prop = sv_newmortal();
regprop(prog, prop, p, reginfo, NULL);
- re_exec_indentf( "%s can match %"IVdf" times out of %"IVdf"...\n",
+ Perl_re_exec_indentf( aTHX_ "%s can match %"IVdf" times out of %"IVdf"...\n",
depth, SvPVX_const(prop),(IV)c,(IV)max);
});
});
* char pos */
STATIC U8 *
-S_reghopmaybe3(U8* s, SSize_t off, const U8* lim)
+S_reghopmaybe3(U8* s, SSize_t off, const U8* const lim)
{
PERL_ARGS_ASSERT_REGHOPMAYBE3;
https://perl5.git.perl.org / perl5.git / blobdiff