#define RF_tainted 1 /* tainted information used? */
#define RF_warned 2 /* warned about big count? */
-#define RF_evaled 4 /* Did an EVAL with setting? */
+
#define RF_utf8 8 /* Pattern contains multibyte chars? */
#define UTF ((PL_reg_flags & RF_utf8) != 0)
? (U8*)pos - off \
: NULL)
-#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
+#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
#define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
} \
} STMT_END
+
static void restore_pos(pTHX_ void *arg);
STATIC CHECKPOINT
if (paren_elems_to_push < 0)
Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
-#define REGCP_OTHER_ELEMS 6
+#define REGCP_OTHER_ELEMS 8
SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
for (p = PL_regsize; p > parenfloor; p--) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
));
}
/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
+ SSPUSHPTR(PL_regstartp);
+ SSPUSHPTR(PL_regendp);
SSPUSHINT(PL_regsize);
SSPUSHINT(*PL_reglastparen);
SSPUSHINT(*PL_reglastcloseparen);
*PL_reglastcloseparen = SSPOPINT;
*PL_reglastparen = SSPOPINT;
PL_regsize = SSPOPINT;
+ PL_regendp=(I32 *) SSPOPPTR;
+ PL_regstartp=(I32 *) SSPOPPTR;
+
/* Now restore the parentheses context. */
for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
i > 0; i -= REGCP_PAREN_ELEMS) {
register SV *check;
char *strbeg;
char *t;
- const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
+ const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
I32 ml_anch;
register char *other_last = NULL; /* other substr checked before this */
char *check_at = NULL; /* check substr found at this pos */
}
DEBUG_EXECUTE_r(
debug_start_match(prog, do_utf8, strpos, strend,
- "Guessing start of match for");
+ sv ? "Guessing start of match in sv for"
+ : "Guessing start of match in string for");
);
/* CHR_DIST() would be more correct here but it makes things slow. */
"String too short... [re_intuit_start]\n"));
goto fail;
}
+
strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
PL_regeol = strend;
if (do_utf8) {
to_byte_substr(prog);
check = prog->check_substr;
}
- if (check == &PL_sv_undef) {
+ if (check == &PL_sv_undef) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "Non-utf string cannot match utf check string\n"));
+ "Non-utf8 string cannot match utf8 check string\n"));
goto fail;
}
if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
I32 slen;
s = HOP3c(strpos, prog->check_offset_min, strend);
+
if (SvTAIL(check)) {
slen = SvCUR(check); /* >= 1 */
/* Match is anchored, but substr is not anchored wrt beg-of-str. */
s = strpos;
start_shift = prog->check_offset_min; /* okay to underestimate on CC */
- end_shift = prog->minlen - start_shift -
- CHR_SVLEN(check) + (SvTAIL(check) != 0);
+ end_shift = prog->check_end_shift;
+
if (!ml_anch) {
const I32 end = prog->check_offset_max + CHR_SVLEN(check)
- (SvTAIL(check) != 0);
else { /* Can match at random position */
ml_anch = 0;
s = strpos;
- start_shift = prog->check_offset_min; /* okay to underestimate on CC */
- /* Should be nonnegative! */
- end_shift = prog->minlen - start_shift -
- CHR_SVLEN(check) + (SvTAIL(check) != 0);
+ start_shift = prog->check_offset_min; /* okay to underestimate on CC */
+ end_shift = prog->check_end_shift;
+
+ /* end shift should be non negative here */
}
#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
- Perl_croak(aTHX_ "panic: end_shift");
+ Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
+ (IV)end_shift, prog->precomp);
#endif
restart:
/* Find a possible match in the region s..strend by looking for
the "check" substring in the region corrected by start/end_shift. */
+
+ {
+ I32 srch_start_shift = start_shift;
+ I32 srch_end_shift = end_shift;
+ if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
+ srch_end_shift -= ((strbeg - s) - srch_start_shift);
+ srch_start_shift = strbeg - s;
+ }
+ DEBUG_OPTIMISE_MORE_r({
+ PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
+ (IV)prog->check_offset_min,
+ (IV)srch_start_shift,
+ (IV)srch_end_shift,
+ (IV)prog->check_end_shift);
+ });
+
if (flags & REXEC_SCREAM) {
I32 p = -1; /* Internal iterator of scream. */
I32 * const pp = data ? data->scream_pos : &p;
&& (BmPREVIOUS(check) == SvCUR(check) - 1)
&& SvTAIL(check) ))
s = screaminstr(sv, check,
- start_shift + (s - strbeg), end_shift, pp, 0);
+ srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
else
goto fail_finish;
/* we may be pointing at the wrong string */
if (data)
*data->scream_olds = s;
}
- else if (prog->reganch & ROPT_CANY_SEEN)
- s = fbm_instr((U8*)(s + start_shift),
- (U8*)(strend - end_shift),
- check, multiline ? FBMrf_MULTILINE : 0);
- else
- s = fbm_instr(HOP3(s, start_shift, strend),
- HOP3(strend, -end_shift, strbeg),
+ else {
+ U8* start_point;
+ U8* end_point;
+ if (prog->reganch & ROPT_CANY_SEEN) {
+ start_point= (U8*)(s + srch_start_shift);
+ end_point= (U8*)(strend - srch_end_shift);
+ } else {
+ start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
+ end_point= HOP3(strend, -srch_end_shift, strbeg);
+ }
+ DEBUG_OPTIMISE_MORE_r({
+ PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
+ (int)(end_point - start_point),
+ (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
+ start_point);
+ });
+
+ s = fbm_instr( start_point, end_point,
check, multiline ? FBMrf_MULTILINE : 0);
-
+ }
+ }
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
if (!s)
goto fail_finish;
-
- check_at = s;
-
/* Finish the diagnostic message */
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
+ /* XXX dmq: first branch is for positive lookbehind...
+ Our check string is offset from the beginning of the pattern.
+ So we need to do any stclass tests offset forward from that
+ point. I think. :-(
+ */
+
+
+
+ check_at=s;
+
+
/* Got a candidate. Check MBOL anchoring, and the *other* substr.
Start with the other substr.
XXXX no SCREAM optimization yet - and a very coarse implementation
Probably it is right to do no SCREAM here...
*/
- if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
+ if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
+ : (prog->float_substr && prog->anchored_substr))
+ {
/* Take into account the "other" substring. */
/* XXXX May be hopelessly wrong for UTF... */
if (!other_last)
last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
if (last < last1)
last1 = last;
- /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
+ /* XXXX It is not documented what units *_offsets are in.
+ We assume bytes, but this is clearly wrong.
+ Meaning this code needs to be carefully reviewed for errors.
+ dmq.
+ */
+
/* On end-of-str: see comment below. */
must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
if (must == &PL_sv_undef) {
s = (char*)NULL;
- DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
+ DEBUG_r(must = prog->anchored_utf8); /* for debug */
}
else
s = fbm_instr(
and end-of-str is not later than strend we are OK. */
if (must == &PL_sv_undef) {
s = (char*)NULL;
- DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
+ DEBUG_r(must = prog->float_utf8); /* for debug message */
}
else
s = fbm_instr((unsigned char*)s,
}
}
- t = s - prog->check_offset_max;
+
+ t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
+
+ DEBUG_OPTIMISE_MORE_r(
+ PerlIO_printf(Perl_debug_log,
+ "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
+ (IV)prog->check_offset_min,
+ (IV)prog->check_offset_max,
+ (IV)(s-strpos),
+ (IV)(t-strpos),
+ (IV)(t-s),
+ (IV)(strend-strpos)
+ )
+ );
+
if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
&& (!do_utf8
- || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*)strpos))
- && t > strpos))) {
+ || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
+ && t > strpos)))
+ {
/* Fixed substring is found far enough so that the match
cannot start at strpos. */
try_at_offset:
/* Last resort... */
/* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
+ /* trie stclasses are too expensive to use here, we are better off to
+ leave it to regmatch itself */
if (prog->regstclass && PL_regkind[OP(prog->regstclass)]!=TRIE) {
/* minlen == 0 is possible if regstclass is \b or \B,
and the fixed substr is ''$.
const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
? CHR_DIST(str+STR_LEN(prog->regstclass), str)
: 1);
- const char * endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
- ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
- : (prog->float_substr || prog->float_utf8
- ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
- cl_l, strend)
- : strend);
- /*if (OP(prog->regstclass) == TRIE)
- endpos++;*/
+ char * endpos;
+ if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
+ endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
+ else if (prog->float_substr || prog->float_utf8)
+ endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
+ else
+ endpos= strend;
+
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %d s: %d endpos: %d\n",
+ (IV)start_shift, check_at - strbeg, s - strbeg, endpos - strbeg));
+
t = s;
s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
if (!s) {
!isDIGIT_LC_utf8((U8*)s),
!isDIGIT_LC(*s)
);
- case TRIEC:
- case TRIE:
+ case AHOCORASICKC:
+ case AHOCORASICK:
{
const enum { trie_plain, trie_utf8, trie_utf8_fold }
trie_type = do_utf8 ?
SvPOK_on(sv_points);
sv_2mortal(sv_points);
points=(U8**)SvPV_nolen(sv_points );
- if ( trie_type != trie_utf8_fold && (trie->bitmap || OP(c)==TRIEC) ) {
+ if ( trie_type != trie_utf8_fold
+ && (trie->bitmap || OP(c)==AHOCORASICKC) )
+ {
if (trie->bitmap)
bitmap=(U8*)trie->bitmap;
else
int failed=0;
U32 word = aho->states[ state ].wordnum;
- if( state==1 && bitmap ) {
- DEBUG_TRIE_EXECUTE_r(
- if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
- dump_exec_pos( (char *)uc, c, strend, real_start,
- (char*)uc, do_utf8 );
- PerlIO_printf( Perl_debug_log,
- " Scanning for legal start char...\n");
+ if( state==1 ) {
+ if ( bitmap ) {
+ DEBUG_TRIE_EXECUTE_r(
+ if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
+ dump_exec_pos( (char *)uc, c, strend, real_start,
+ (char *)uc, do_utf8 );
+ PerlIO_printf( Perl_debug_log,
+ " Scanning for legal start char...\n");
+ }
+ );
+ while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
+ uc++;
}
- );
- while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
- uc++;
+ s= (char *)uc;
}
- s= (char *)uc;
if (uc >(U8*)last_start) break;
}
I32 scream_pos = -1; /* Internal iterator of scream. */
char *scream_olds = NULL;
SV* const oreplsv = GvSV(PL_replgv);
- const bool do_utf8 = DO_UTF8(sv);
+ const bool do_utf8 = (bool)DO_UTF8(sv);
I32 multiline;
regmatch_info reginfo; /* create some info to pass to regtry etc */
reginfo.prog = prog;
RX_MATCH_UTF8_set(prog, do_utf8);
+ DEBUG_EXECUTE_r(
+ debug_start_match(prog, do_utf8, startpos, strend,
+ "Matching");
+ );
minlen = prog->minlen;
- if (strend - startpos < minlen) {
+
+ if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"String too short [regexec_flags]...\n"));
goto phooey;
}
+
/* Check validity of program. */
if (UCHARAT(prog->program) != REG_MAGIC) {
Perl_croak(aTHX_ "corrupted regexp program");
}
}
- DEBUG_EXECUTE_r(
- debug_start_match(prog, do_utf8, startpos, strend,
- "Matching");
- );
+
/* Simplest case: anchored match need be tried only once. */
/* [unless only anchor is BOL and multiline is set] */
}
}
goto phooey;
- } else if (prog->reganch & ROPT_ANCH_GPOS) {
+ } else if (ROPT_GPOS_CHECK == (prog->reganch & ROPT_GPOS_CHECK))
+ {
+ /* the warning about reginfo.ganch being used without intialization
+ is bogus -- we set it above, when prog->reganch & ROPT_GPOS_SEEN
+ and we only enter this block when the same bit is set. */
if (regtry(®info, reginfo.ganch))
goto got_it;
goto phooey;
back_max = prog->float_max_offset;
back_min = prog->float_min_offset;
}
+
+
if (must == &PL_sv_undef)
/* could not downgrade utf8 check substring, so must fail */
goto phooey;
- last = HOP3c(strend, /* Cannot start after this */
- -(I32)(CHR_SVLEN(must)
- - (SvTAIL(must) != 0) + back_min), strbeg);
-
+ if (back_min<0) {
+ last = strend;
+ } else {
+ last = HOP3c(strend, /* Cannot start after this */
+ -(I32)(CHR_SVLEN(must)
+ - (SvTAIL(must) != 0) + back_min), strbeg);
+ }
if (s > PL_bostr)
last1 = HOPc(s, -1);
else
strend = HOPc(strend, -dontbother);
while ( (s <= last) &&
((flags & REXEC_SCREAM)
- ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
+ ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
end_shift, &scream_pos, 0))
- : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
+ : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
(unsigned char*)strend, must,
multiline ? FBMrf_MULTILINE : 0))) ) {
/* we may be pointing at the wrong string */
}
}
if (last == NULL) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "%sCan't trim the tail, match fails (should not happen)%s\n",
- PL_colors[4], PL_colors[5]));
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sCan't trim the tail, match fails (should not happen)%s\n",
+ PL_colors[4], PL_colors[5]));
goto phooey; /* Should not happen! */
}
dontbother = strend - last + prog->float_min_offset;
return 0;
}
+
/*
- regtry - try match at specific point
*/
regexp *prog = reginfo->prog;
GET_RE_DEBUG_FLAGS_DECL;
-#ifdef DEBUGGING
- PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
-#endif
if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
MAGIC *mg;
prog->subbeg = PL_bostr;
prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
}
+ DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
prog->startp[0] = startpos - PL_bostr;
PL_reginput = startpos;
- PL_regstartp = prog->startp;
- PL_regendp = prog->endp;
PL_reglastparen = &prog->lastparen;
PL_reglastcloseparen = &prog->lastcloseparen;
prog->lastparen = 0;
prog->lastcloseparen = 0;
PL_regsize = 0;
- DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
+ PL_regstartp = prog->startp;
+ PL_regendp = prog->endp;
if (PL_reg_start_tmpl <= prog->nparens) {
PL_reg_start_tmpl = prog->nparens*3/2 + 3;
if(PL_reg_start_tmp)
#define sayYES goto yes
#define sayNO goto no
-#define sayNO_ANYOF goto no_anyof
-#define sayYES_FINAL goto yes_final
-#define sayNO_FINAL goto no_final
-#define sayNO_SILENT goto do_no
-#define saySAME(x) if (x) goto yes; else goto no
-
-#define CACHEsayNO STMT_START { \
- if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) \
- PL_reg_poscache[st->u.whilem.cache_offset] |= \
- (1<<st->u.whilem.cache_bit); \
- sayNO; \
-} STMT_END
+#define sayNO_SILENT goto no_silent
+/* we dont use STMT_START/END here because it leads to
+ "unreachable code" warnings, which are bogus, but distracting. */
+#define CACHEsayNO \
+ if (ST.cache_mask) \
+ PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
+ sayNO
/* this is used to determine how far from the left messages like
- 'failed...' are printed. Currently 29 makes these messages line
- up with the opcode they refer to. Earlier perls used 25 which
- left these messages outdented making reviewing a debug output
- quite difficult.
+ 'failed...' are printed. It should be set such that messages
+ are inline with the regop output that created them.
*/
-#define REPORT_CODE_OFF 29
+#define REPORT_CODE_OFF 32
/* Make sure there is a test for this +1 options in re_tests */
return SLAB_FIRST(s);
}
-/* simulate a recursive call to regmatch */
-
-#define REGMATCH(ns, where) \
- st->scan = scan; \
- scan = (ns); \
- st->resume_state = resume_##where; \
- goto start_recurse; \
- resume_point_##where:
/* push a new state then goto it */
* allocated since entry are freed.
*/
-/* *** every FOO_fail should = FOO+1 */
-#define TRIE_next (REGNODE_MAX+1)
-#define TRIE_next_fail (REGNODE_MAX+2)
-#define EVAL_A (REGNODE_MAX+3)
-#define EVAL_A_fail (REGNODE_MAX+4)
-#define resume_CURLYX (REGNODE_MAX+5)
-#define resume_WHILEM1 (REGNODE_MAX+6)
-#define resume_WHILEM2 (REGNODE_MAX+7)
-#define resume_WHILEM3 (REGNODE_MAX+8)
-#define resume_WHILEM4 (REGNODE_MAX+9)
-#define resume_WHILEM5 (REGNODE_MAX+10)
-#define resume_WHILEM6 (REGNODE_MAX+11)
-#define BRANCH_next (REGNODE_MAX+12)
-#define BRANCH_next_fail (REGNODE_MAX+13)
-#define CURLYM_A (REGNODE_MAX+14)
-#define CURLYM_A_fail (REGNODE_MAX+15)
-#define CURLYM_B (REGNODE_MAX+16)
-#define CURLYM_B_fail (REGNODE_MAX+17)
-#define IFMATCH_A (REGNODE_MAX+18)
-#define IFMATCH_A_fail (REGNODE_MAX+19)
-#define CURLY_B_min_known (REGNODE_MAX+20)
-#define CURLY_B_min_known_fail (REGNODE_MAX+21)
-#define CURLY_B_min (REGNODE_MAX+22)
-#define CURLY_B_min_fail (REGNODE_MAX+23)
-#define CURLY_B_max (REGNODE_MAX+24)
-#define CURLY_B_max_fail (REGNODE_MAX+25)
+
+#define DEBUG_STATE_pp(pp) \
+ DEBUG_STATE_r({ \
+ DUMP_EXEC_POS(locinput, scan, do_utf8); \
+ PerlIO_printf(Perl_debug_log, \
+ " %*s"pp" %s\n", \
+ depth*2, "", \
+ reg_name[st->resume_state] ); \
+ });
#define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
#ifdef DEBUGGING
+
STATIC void
S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
const char *start, const char *end, const char *blurb)
PL_colors[4], blurb, PL_colors[5], s0, s1);
if (do_utf8||utf8_pat)
- PerlIO_printf(Perl_debug_log, "UTF-8 %s...\n",
- !do_utf8 ? "pattern" : !utf8_pat ? "string" :
- "pattern and string"
+ PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
+ utf8_pat ? "pattern" : "",
+ utf8_pat && do_utf8 ? " and " : "",
+ do_utf8 ? "string" : ""
);
}
}
const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
- (locinput - pref_len),pref0_len, pref0_len, 4, 5);
+ (locinput - pref_len),pref0_len, 60, 4, 5);
RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
(locinput - pref_len + pref0_len),
- pref_len - pref0_len, pref_len - pref0_len, 2, 3);
+ pref_len - pref0_len, 60, 2, 3);
RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
- locinput, loc_regeol - locinput, l, 0, 1);
+ locinput, loc_regeol - locinput, 10, 0, 1);
+ const STRLEN tlen=len0+len1+len2;
PerlIO_printf(Perl_debug_log,
"%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
(IV)(locinput - loc_bostr),
len1, s1,
(docolor ? "" : "> <"),
len2, s2,
- 15 - l - pref_len + 1,
+ (int)(tlen > 19 ? 0 : 19 - tlen),
"");
}
}
/* cache heavy used fields of st in registers */
register regnode *scan;
register regnode *next;
- register I32 n = 0; /* initialize to shut up compiler warning */
+ register I32 n = 0; /* general value; init to avoid compiler warning */
+ register I32 ln = 0; /* len or last; init to avoid compiler warning */
register char *locinput = PL_reginput;
-
- /* these variables are NOT saved during a recusive RFEGMATCH: */
register I32 nextchr; /* is always set to UCHARAT(locinput) */
+
bool result = 0; /* return value of S_regmatch */
- int depth = 0; /* depth of recursion */
+ int depth = 0; /* depth of backtrack stack */
+ int nochange_depth = 0; /* depth of RECURSE recursion with nochange*/
regmatch_state *yes_state = NULL; /* state to pop to on success of
subpattern */
+ regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
+ struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
U32 state_num;
-
- I32 parenfloor = 0;
+
+ /* these three flags are set by various ops to signal information to
+ * the very next op. They have a useful lifetime of exactly one loop
+ * iteration, and are not preserved or restored by state pushes/pops
+ */
+ bool sw = 0; /* the condition value in (?(cond)a|b) */
+ bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
+ int logical = 0; /* the following EVAL is:
+ 0: (?{...})
+ 1: (?(?{...})X|Y)
+ 2: (??{...})
+ or the following IFMATCH/UNLESSM is:
+ false: plain (?=foo)
+ true: used as a condition: (?(?=foo))
+ */
#ifdef DEBUGGING
GET_RE_DEBUG_FLAGS_DECL;
- PL_regindent++;
#endif
/* on first ever call to regmatch, allocate first slab */
if (st > SLAB_LAST(PL_regmatch_slab))
st = PL_regmatch_state = S_push_slab(aTHX);
- st->minmod = 0;
- st->sw = 0;
- st->logical = 0;
- st->cc = NULL;
-
/* Note that nextchr is a byte even in UTF */
nextchr = UCHARAT(locinput);
scan = prog;
DEBUG_EXECUTE_r( {
SV * const prop = sv_newmortal();
+ regnode *rnext=regnext(scan);
DUMP_EXEC_POS( locinput, scan, do_utf8 );
regprop(rex, prop, scan);
PerlIO_printf(Perl_debug_log,
"%3"IVdf":%*s%s(%"IVdf")\n",
- (IV)(scan - rex->program), PL_regindent*2, "",
+ (IV)(scan - rex->program), depth*2, "",
SvPVX_const(prop),
- PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
+ (PL_regkind[OP(scan)] == END || !rnext) ?
+ 0 : (IV)(rnext - rex->program));
});
next = scan + NEXT_OFF(scan);
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %sfailed to match trie start class...%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
/* NOTREACHED */
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %smatched empty string...%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
);
break;
} else {
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %sfailed to match trie start class...%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
}
while ( state && uc <= (U8*)PL_regeol ) {
U32 base = trie->states[ state ].trans.base;
- UV uvc;
+ UV uvc = 0;
U16 charid;
/* We use charid to hold the wordnum as we don't use it
for charid until after we have done the wordnum logic.
DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
PerlIO_printf( Perl_debug_log,
"%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
- 2+PL_regindent * 2, "", PL_colors[4],
+ 2+depth * 2, "", PL_colors[4],
(UV)state, (UV)ST.accepted );
});
DEBUG_EXECUTE_r(
PerlIO_printf( Perl_debug_log,
"%*s %sgot %"IVdf" possible matches%s\n",
- REPORT_CODE_OFF + PL_regindent * 2, "",
+ REPORT_CODE_OFF + depth * 2, "",
PL_colors[4], (IV)ST.accepted, PL_colors[5] );
);
}}
: NULL;
PerlIO_printf( Perl_debug_log,
"%*s %sonly one match left: #%d <%s>%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4],
ST.accept_buff[ 0 ].wordnum,
tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
PL_colors[5] );
DEBUG_TRIE_EXECUTE_r(
PerlIO_printf( Perl_debug_log,
"%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
- REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
+ REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
(IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
ST.accept_buff[ cur ].wordnum, PL_colors[5] );
);
SV ** const tmp = RX_DEBUG(reginfo->prog)
? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
: NULL;
- PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at node #%d %s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
+ regnode *nextop=!ST.jump ?
+ ST.B :
+ ST.B - ST.jump[ST.accept_buff[best].wordnum];
+ PerlIO_printf( Perl_debug_log,
+ "%*s %strying alternation #%d <%s> at node #%d %s\n",
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4],
ST.accept_buff[best].wordnum,
- tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
+ tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
+ REG_NODE_NUM(nextop),
PL_colors[5] );
});
case EXACT: {
char *s = STRING(scan);
- st->ln = STR_LEN(scan);
+ ln = STR_LEN(scan);
if (do_utf8 != UTF) {
/* The target and the pattern have differing utf8ness. */
char *l = locinput;
- const char * const e = s + st->ln;
+ const char * const e = s + ln;
if (do_utf8) {
/* The target is utf8, the pattern is not utf8. */
/* Inline the first character, for speed. */
if (UCHARAT(s) != nextchr)
sayNO;
- if (PL_regeol - locinput < st->ln)
+ if (PL_regeol - locinput < ln)
sayNO;
- if (st->ln > 1 && memNE(s, locinput, st->ln))
+ if (ln > 1 && memNE(s, locinput, ln))
sayNO;
- locinput += st->ln;
+ locinput += ln;
nextchr = UCHARAT(locinput);
break;
}
/* FALL THROUGH */
case EXACTF: {
char * const s = STRING(scan);
- st->ln = STR_LEN(scan);
+ ln = STR_LEN(scan);
if (do_utf8 || UTF) {
/* Either target or the pattern are utf8. */
const char * const l = locinput;
char *e = PL_regeol;
- if (ibcmp_utf8(s, 0, st->ln, (bool)UTF,
+ if (ibcmp_utf8(s, 0, ln, (bool)UTF,
l, &e, 0, do_utf8)) {
/* One more case for the sharp s:
* pack("U0U*", 0xDF) =~ /ss/i,
* byte sequence for the U+00DF. */
if (!(do_utf8 &&
toLOWER(s[0]) == 's' &&
- st->ln >= 2 &&
+ ln >= 2 &&
toLOWER(s[1]) == 's' &&
(U8)l[0] == 0xC3 &&
e - l >= 2 &&
UCHARAT(s) != ((OP(scan) == EXACTF)
? PL_fold : PL_fold_locale)[nextchr])
sayNO;
- if (PL_regeol - locinput < st->ln)
+ if (PL_regeol - locinput < ln)
sayNO;
- if (st->ln > 1 && (OP(scan) == EXACTF
- ? ibcmp(s, locinput, st->ln)
- : ibcmp_locale(s, locinput, st->ln)))
+ if (ln > 1 && (OP(scan) == EXACTF
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln)))
sayNO;
- locinput += st->ln;
+ locinput += ln;
nextchr = UCHARAT(locinput);
break;
}
STRLEN inclasslen = PL_regeol - locinput;
if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
- sayNO_ANYOF;
+ goto anyof_fail;
if (locinput >= PL_regeol)
sayNO;
locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
if (nextchr < 0)
nextchr = UCHARAT(locinput);
if (!REGINCLASS(rex, scan, (U8*)locinput))
- sayNO_ANYOF;
+ goto anyof_fail;
if (!nextchr && locinput >= PL_regeol)
sayNO;
nextchr = UCHARAT(++locinput);
break;
}
- no_anyof:
+ anyof_fail:
/* If we might have the case of the German sharp s
* in a casefolding Unicode character class. */
/* was last char in word? */
if (do_utf8) {
if (locinput == PL_bostr)
- st->ln = '\n';
+ ln = '\n';
else {
const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
- st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
+ ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
}
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
- st->ln = isALNUM_uni(st->ln);
+ ln = isALNUM_uni(ln);
LOAD_UTF8_CHARCLASS_ALNUM();
n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
}
else {
- st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
+ ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
n = isALNUM_LC_utf8((U8*)locinput);
}
}
else {
- st->ln = (locinput != PL_bostr) ?
+ ln = (locinput != PL_bostr) ?
UCHARAT(locinput - 1) : '\n';
if (OP(scan) == BOUND || OP(scan) == NBOUND) {
- st->ln = isALNUM(st->ln);
+ ln = isALNUM(ln);
n = isALNUM(nextchr);
}
else {
- st->ln = isALNUM_LC(st->ln);
+ ln = isALNUM_LC(ln);
n = isALNUM_LC(nextchr);
}
}
- if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
+ if (((!ln) == (!n)) == (OP(scan) == BOUND ||
OP(scan) == BOUNDL))
sayNO;
break;
case REFF: {
char *s;
n = ARG(scan); /* which paren pair */
- st->ln = PL_regstartp[n];
+ ln = PL_regstartp[n];
PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
- if ((I32)*PL_reglastparen < n || st->ln == -1)
+ if ((I32)*PL_reglastparen < n || ln == -1)
sayNO; /* Do not match unless seen CLOSEn. */
- if (st->ln == PL_regendp[n])
+ if (ln == PL_regendp[n])
break;
- s = PL_bostr + st->ln;
+ s = PL_bostr + ln;
if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */
char *l = locinput;
const char *e = PL_bostr + PL_regendp[n];
(UCHARAT(s) != ((OP(scan) == REFF
? PL_fold : PL_fold_locale)[nextchr]))))
sayNO;
- st->ln = PL_regendp[n] - st->ln;
- if (locinput + st->ln > PL_regeol)
+ ln = PL_regendp[n] - ln;
+ if (locinput + ln > PL_regeol)
sayNO;
- if (st->ln > 1 && (OP(scan) == REF
- ? memNE(s, locinput, st->ln)
+ if (ln > 1 && (OP(scan) == REF
+ ? memNE(s, locinput, ln)
: (OP(scan) == REFF
- ? ibcmp(s, locinput, st->ln)
- : ibcmp_locale(s, locinput, st->ln))))
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln))))
sayNO;
- locinput += st->ln;
+ locinput += ln;
nextchr = UCHARAT(locinput);
break;
}
#undef ST
#define ST st->u.eval
-
- case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
{
SV *ret;
+ regexp *re;
+ regnode *startpoint;
+
+ case SRECURSE:
+ case RECURSE: /* /(...(?1))/ */
+ if (cur_eval && cur_eval->locinput==locinput) {
+ if (cur_eval->u.eval.close_paren == ARG(scan))
+ Perl_croak(aTHX_ "Infinite recursion in RECURSE in regexp");
+ if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
+ Perl_croak(aTHX_ "RECURSE without pos change exceeded limit in regexp");
+ } else {
+ nochange_depth = 0;
+ }
+ re = rex;
+ (void)ReREFCNT_inc(rex);
+ if (OP(scan)==RECURSE) {
+ startpoint = scan + ARG2L(scan);
+ ST.close_paren = ARG(scan);
+ } else {
+ startpoint = re->program+1;
+ ST.close_paren = 0;
+ }
+ goto eval_recurse_doit;
+ /* NOTREACHED */
+ case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
+ if (cur_eval && cur_eval->locinput==locinput) {
+ if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
+ Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regexp");
+ } else {
+ nochange_depth = 0;
+ }
{
/* execute the code in the {...} */
dSP;
PL_op = oop;
PAD_RESTORE_LOCAL(old_comppad);
PL_curcop = ocurcop;
- if (!st->logical) {
+ if (!logical) {
/* /(?{...})/ */
sv_setsv(save_scalar(PL_replgv), ret);
break;
}
}
- if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
- regexp *re;
+ if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
+ logical = 0;
{
/* extract RE object from returned value; compiling if
* necessary */
Zero(&pm, 1, PMOP);
if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
- re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
+ re = CALLREGCOMP((char*)t, (char*)t + len, &pm);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY
| SVs_GMG)))
PL_regsize = osize;
}
}
-
- /* run the pattern returned from (??{...}) */
- DEBUG_EXECUTE_r(
+ DEBUG_EXECUTE_r(
debug_start_match(re, do_utf8, locinput, PL_regeol,
"Matching embedded");
- );
+ );
+ startpoint = re->program + 1;
+ ST.close_paren = 0; /* only used for RECURSE */
+ /* borrowed from regtry */
+ if (PL_reg_start_tmpl <= re->nparens) {
+ PL_reg_start_tmpl = re->nparens*3/2 + 3;
+ if(PL_reg_start_tmp)
+ Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
+ else
+ Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
+ }
+ eval_recurse_doit: /* Share code with RECURSE below this line */
+ /* run the pattern returned from (??{...}) */
ST.cp = regcppush(0); /* Save *all* the positions. */
REGCP_SET(ST.lastcp);
+
+ PL_regstartp = re->startp; /* essentially NOOP on RECURSE */
+ PL_regendp = re->endp; /* essentially NOOP on RECURSE */
+
*PL_reglastparen = 0;
*PL_reglastcloseparen = 0;
PL_reginput = locinput;
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
- st->logical = 0;
- ST.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
- ((re->reganch & ROPT_UTF8) != 0);
- if (ST.toggleutf) PL_reg_flags ^= RF_utf8;
+ ST.toggle_reg_flags = PL_reg_flags;
+ if (re->reganch & ROPT_UTF8)
+ PL_reg_flags |= RF_utf8;
+ else
+ PL_reg_flags &= ~RF_utf8;
+ ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
+
ST.prev_rex = rex;
+ ST.prev_curlyx = cur_curlyx;
rex = re;
-
+ cur_curlyx = NULL;
ST.B = next;
- /* now continue from first node in postoned RE */
- PUSH_YES_STATE_GOTO(EVAL_A, re->program + 1);
+ ST.prev_eval = cur_eval;
+ cur_eval = st;
+ /* now continue from first node in postoned RE */
+ PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
/* NOTREACHED */
}
- /* /(?(?{...})X|Y)/ */
- st->sw = SvTRUE(ret);
- st->logical = 0;
+ /* logical is 1, /(?(?{...})X|Y)/ */
+ sw = (bool)SvTRUE(ret);
+ logical = 0;
break;
}
- case EVAL_A: /* successfully ran inner rex (??{rex}) */
- if (ST.toggleutf)
- PL_reg_flags ^= RF_utf8;
+ case EVAL_AB: /* cleanup after a successful (??{A})B */
+ /* note: this is called twice; first after popping B, then A */
+ PL_reg_flags ^= ST.toggle_reg_flags;
ReREFCNT_dec(rex);
rex = ST.prev_rex;
+ regcpblow(ST.cp);
+ cur_eval = ST.prev_eval;
+ cur_curlyx = ST.prev_curlyx;
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
- /* Restore parens of the caller without popping the
- * savestack */
- {
- const I32 tmp = PL_savestack_ix;
- PL_savestack_ix = ST.lastcp;
- regcppop(rex);
- PL_savestack_ix = tmp;
- }
- PL_reginput = locinput;
- /* continue at the node following the (??{...}) */
- scan = ST.B;
- continue;
+ sayYES;
+
- case EVAL_A_fail: /* unsuccessfully ran inner rex (??{rex}) */
- /* Restore state to the outer re then re-throw the failure */
- if (ST.toggleutf)
- PL_reg_flags ^= RF_utf8;
+ case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
+ /* note: this is called twice; first after popping B, then A */
+ PL_reg_flags ^= ST.toggle_reg_flags;
ReREFCNT_dec(rex);
rex = ST.prev_rex;
-
- /* XXXX This is too dramatic a measure... */
- PL_reg_maxiter = 0;
-
PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
regcppop(rex);
+ cur_eval = ST.prev_eval;
+ cur_curlyx = ST.prev_curlyx;
+ /* XXXX This is too dramatic a measure... */
+ PL_reg_maxiter = 0;
sayNO_SILENT;
-
#undef ST
case OPEN:
if (n > (I32)*PL_reglastparen)
*PL_reglastparen = n;
*PL_reglastcloseparen = n;
+ if (cur_eval && cur_eval->u.eval.close_paren == (U32)n) {
+ goto fake_end;
+ }
break;
case GROUPP:
n = ARG(scan); /* which paren pair */
- st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
+ sw = (bool)((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
break;
case IFTHEN:
PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
- if (st->sw)
+ if (sw)
next = NEXTOPER(NEXTOPER(scan));
else {
next = scan + ARG(scan);
}
break;
case LOGICAL:
- st->logical = scan->flags;
+ logical = scan->flags;
break;
+
/*******************************************************************
- cc points to the regmatch_state associated with the most recent CURLYX.
- This struct contains info about the innermost (...)* loop (an
- "infoblock"), and a pointer to the next outer cc.
- Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
+The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
+pattern, where A and B are subpatterns. (For simple A, CURLYM or
+STAR/PLUS/CURLY/CURLYN are used instead.)
- 1) After matching Y, regnode for CURLYX is processed;
+A*B is compiled as <CURLYX><A><WHILEM><B>
- 2) This regnode populates cc, and calls regmatch() recursively
- with the starting point at WHILEM node;
+On entry to the subpattern, CURLYX is called. This pushes a CURLYX
+state, which contains the current count, initialised to -1. It also sets
+cur_curlyx to point to this state, with any previous value saved in the
+state block.
- 3) Each hit of WHILEM node tries to match A and Z (in the order
- depending on the current iteration, min/max of {min,max} and
- greediness). The information about where are nodes for "A"
- and "Z" is read from cc, as is info on how many times "A"
- was already matched, and greediness.
+CURLYX then jumps straight to the WHILEM op, rather than executing A,
+since the pattern may possibly match zero times (i.e. it's a while {} loop
+rather than a do {} while loop).
- 4) After A matches, the same WHILEM node is hit again.
+Each entry to WHILEM represents a successful match of A. The count in the
+CURLYX block is incremented, another WHILEM state is pushed, and execution
+passes to A or B depending on greediness and the current count.
- 5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
- of the same pair. Thus when WHILEM tries to match Z, it temporarily
- resets cc, since this Y(A)*Z can be a part of some other loop:
- as in (Y(A)*Z)*. If Z matches, the automaton will hit the WHILEM node
- of the external loop.
+For example, if matching against the string a1a2a3b (where the aN are
+substrings that match /A/), then the match progresses as follows: (the
+pushed states are interspersed with the bits of strings matched so far):
- Currently present infoblocks form a tree with a stem formed by st->cc
- and whatever it mentions via ->next, and additional attached trees
- corresponding to temporarily unset infoblocks as in "5" above.
+ <CURLYX cnt=-1>
+ <CURLYX cnt=0><WHILEM>
+ <CURLYX cnt=1><WHILEM> a1 <WHILEM>
+ <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
+ <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
+ <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
- In the following picture, infoblocks for outer loop of
- (Y(A)*?Z)*?T are denoted O, for inner I. NULL starting block
- is denoted by x. The matched string is YAAZYAZT. Temporarily postponed
- infoblocks are drawn below the "reset" infoblock.
+(Contrast this with something like CURLYM, which maintains only a single
+backtrack state:
- In fact in the picture below we do not show failed matches for Z and T
- by WHILEM blocks. [We illustrate minimal matches, since for them it is
- more obvious *why* one needs to *temporary* unset infoblocks.]
+ <CURLYM cnt=0> a1
+ a1 <CURLYM cnt=1> a2
+ a1 a2 <CURLYM cnt=2> a3
+ a1 a2 a3 <CURLYM cnt=3> b
+)
- Matched REx position InfoBlocks Comment
- (Y(A)*?Z)*?T x
- Y(A)*?Z)*?T x <- O
- Y (A)*?Z)*?T x <- O
- Y A)*?Z)*?T x <- O <- I
- YA )*?Z)*?T x <- O <- I
- YA A)*?Z)*?T x <- O <- I
- YAA )*?Z)*?T x <- O <- I
- YAA Z)*?T x <- O # Temporary unset I
- I
+Each WHILEM state block marks a point to backtrack to upon partial failure
+of A or B, and also contains some minor state data related to that
+iteration. The CURLYX block, pointed to by cur_curlyx, contains the
+overall state, such as the count, and pointers to the A and B ops.
- YAAZ Y(A)*?Z)*?T x <- O
- I
+This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
+must always point to the *current* CURLYX block, the rules are:
- YAAZY (A)*?Z)*?T x <- O
- I
+When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
+and set cur_curlyx to point the new block.
- YAAZY A)*?Z)*?T x <- O <- I
- I
+When popping the CURLYX block after a successful or unsuccessful match,
+restore the previous cur_curlyx.
- YAAZYA )*?Z)*?T x <- O <- I
- I
+When WHILEM is about to execute B, save the current cur_curlyx, and set it
+to the outer one saved in the CURLYX block.
- YAAZYA Z)*?T x <- O # Temporary unset I
- I,I
+When popping the WHILEM block after a successful or unsuccessful B match,
+restore the previous cur_curlyx.
- YAAZYAZ )*?T x <- O
- I,I
+Here's an example for the pattern (AI* BI)*BO
+I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
- YAAZYAZ T x # Temporary unset O
- O
- I,I
+cur_
+curlyx backtrack stack
+------ ---------------
+NULL
+CO <CO prev=NULL> <WO>
+CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
+CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
+NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
- YAAZYAZT x
- O
- I,I
- *******************************************************************/
+At this point the pattern succeeds, and we work back down the stack to
+clean up, restoring as we go:
- case CURLYX: {
- /* No need to save/restore up to this paren */
- parenfloor = scan->flags;
-
- /* Dave says:
-
- CURLYX and WHILEM are always paired: they're the moral
- equivalent of pp_enteriter anbd pp_iter.
-
- The only time next could be null is if the node tree is
- corrupt. This was mentioned on p5p a few days ago.
-
- See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
- So we'll assert that this is true:
- */
- assert(next);
- if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
- next += ARG(next);
- /* XXXX Probably it is better to teach regpush to support
- parenfloor > PL_regsize... */
- if (parenfloor > (I32)*PL_reglastparen)
- parenfloor = *PL_reglastparen; /* Pessimization... */
-
- st->u.curlyx.cp = PL_savestack_ix;
- st->u.curlyx.outercc = st->cc;
- st->cc = st;
- /* these fields contain the state of the current curly.
- * they are accessed by subsequent WHILEMs;
- * cur and lastloc are also updated by WHILEM */
- st->u.curlyx.parenfloor = parenfloor;
- st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
- st->u.curlyx.min = ARG1(scan);
- st->u.curlyx.max = ARG2(scan);
- st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
- st->u.curlyx.lastloc = 0;
- /* st->next and st->minmod are also read by WHILEM */
+CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
+CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
+CO <CO prev=NULL> <WO>
+NULL
- PL_reginput = locinput;
- REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
- /*** all unsaved local vars undefined at this point */
- regcpblow(st->u.curlyx.cp);
- st->cc = st->u.curlyx.outercc;
- saySAME(result);
- }
+*******************************************************************/
+
+#define ST st->u.curlyx
+
+ case CURLYX: /* start of /A*B/ (for complex A) */
+ {
+ /* No need to save/restore up to this paren */
+ I32 parenfloor = scan->flags;
+
+ assert(next); /* keep Coverity happy */
+ if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
+ next += ARG(next);
+
+ /* XXXX Probably it is better to teach regpush to support
+ parenfloor > PL_regsize... */
+ if (parenfloor > (I32)*PL_reglastparen)
+ parenfloor = *PL_reglastparen; /* Pessimization... */
+
+ ST.prev_curlyx= cur_curlyx;
+ cur_curlyx = st;
+ ST.cp = PL_savestack_ix;
+
+ /* these fields contain the state of the current curly.
+ * they are accessed by subsequent WHILEMs */
+ ST.parenfloor = parenfloor;
+ ST.min = ARG1(scan);
+ ST.max = ARG2(scan);
+ ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
+ ST.B = next;
+ ST.minmod = minmod;
+ minmod = 0;
+ ST.count = -1; /* this will be updated by WHILEM */
+ ST.lastloc = NULL; /* this will be updated by WHILEM */
+
+ PL_reginput = locinput;
+ PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
/* NOTREACHED */
- case WHILEM: {
- /*
- * This is really hard to understand, because after we match
- * what we're trying to match, we must make sure the rest of
- * the REx is going to match for sure, and to do that we have
- * to go back UP the parse tree by recursing ever deeper. And
- * if it fails, we have to reset our parent's current state
- * that we can try again after backing off.
- */
+ }
- /* Dave says:
-
- st->cc gets initialised by CURLYX ready for use by WHILEM.
- So again, unless somethings been corrupted, st->cc cannot
- be null at that point in WHILEM.
-
- See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
- So we'll assert that this is true:
- */
- assert(st->cc);
- st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
- st->u.whilem.cache_offset = 0;
- st->u.whilem.cache_bit = 0;
-
- n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
- PL_reginput = locinput;
+ case CURLYX_end: /* just finished matching all of A*B */
+ regcpblow(ST.cp);
+ cur_curlyx = ST.prev_curlyx;
+ sayYES;
+ /* NOTREACHED */
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s %ld out of %ld..%ld cc=%"UVxf"\n",
- REPORT_CODE_OFF+PL_regindent*2, "",
- (long)n, (long)st->cc->u.curlyx.min,
- (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
- );
+ case CURLYX_end_fail: /* just failed to match all of A*B */
+ regcpblow(ST.cp);
+ cur_curlyx = ST.prev_curlyx;
+ sayNO;
+ /* NOTREACHED */
- /* If degenerate scan matches "", assume scan done. */
-
- if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
- st->u.whilem.savecc = st->cc;
- st->cc = st->cc->u.curlyx.outercc;
- if (st->cc)
- st->ln = st->cc->u.curlyx.cur;
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s empty match detected, try continuation...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
- REGMATCH(st->u.whilem.savecc->next, WHILEM1);
- /*** all unsaved local vars undefined at this point */
- st->cc = st->u.whilem.savecc;
- if (result)
- sayYES;
- if (st->cc->u.curlyx.outercc)
- st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
- sayNO;
- }
- /* First just match a string of min scans. */
+#undef ST
+#define ST st->u.whilem
- if (n < st->cc->u.curlyx.min) {
- st->cc->u.curlyx.cur = n;
- st->cc->u.curlyx.lastloc = locinput;
- REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
- /*** all unsaved local vars undefined at this point */
- if (result)
- sayYES;
- st->cc->u.curlyx.cur = n - 1;
- st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
- sayNO;
- }
+ case WHILEM: /* just matched an A in /A*B/ (for complex A) */
+ {
+ /* see the discussion above about CURLYX/WHILEM */
+
+ I32 n;
+ assert(cur_curlyx); /* keep Coverity happy */
+ n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
+ ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
+ ST.cache_offset = 0;
+ ST.cache_mask = 0;
+
+ PL_reginput = locinput;
+
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
+ "%*s whilem: matched %ld out of %ld..%ld\n",
+ REPORT_CODE_OFF+depth*2, "", (long)n,
+ (long)cur_curlyx->u.curlyx.min,
+ (long)cur_curlyx->u.curlyx.max)
+ );
+
+ /* First just match a string of min A's. */
+
+ if (n < cur_curlyx->u.curlyx.min) {
+ cur_curlyx->u.curlyx.lastloc = locinput;
+ PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
+ /* NOTREACHED */
+ }
+
+ /* If degenerate A matches "", assume A done. */
+
+ if (locinput == cur_curlyx->u.curlyx.lastloc) {
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
+ "%*s whilem: empty match detected, trying continuation...\n",
+ REPORT_CODE_OFF+depth*2, "")
+ );
+ goto do_whilem_B_max;
+ }
+
+ /* super-linear cache processing */
+
+ if (scan->flags) {
- if (scan->flags) {
- /* Check whether we already were at this position.
- Postpone detection until we know the match is not
- *that* much linear. */
if (!PL_reg_maxiter) {
+ /* start the countdown: Postpone detection until we
+ * know the match is not *that* much linear. */
PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
/* possible overflow for long strings and many CURLYX's */
if (PL_reg_maxiter < 0)
PL_reg_maxiter = I32_MAX;
PL_reg_leftiter = PL_reg_maxiter;
}
+
if (PL_reg_leftiter-- == 0) {
+ /* initialise cache */
const I32 size = (PL_reg_maxiter + 7)/8;
if (PL_reg_poscache) {
if ((I32)PL_reg_poscache_size < size) {
PL_reg_poscache_size = size;
Newxz(PL_reg_poscache, size, char);
}
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%sDetected a super-linear match, switching on caching%s...\n",
- PL_colors[4], PL_colors[5])
- );
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
+ "%swhilem: Detected a super-linear match, switching on caching%s...\n",
+ PL_colors[4], PL_colors[5])
+ );
}
+
if (PL_reg_leftiter < 0) {
- st->u.whilem.cache_offset = locinput - PL_bostr;
-
- st->u.whilem.cache_offset = (scan->flags & 0xf) - 1
- + st->u.whilem.cache_offset * (scan->flags>>4);
- st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
- st->u.whilem.cache_offset /= 8;
- if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s already tried at this position...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
+ /* have we already failed at this position? */
+ I32 offset, mask;
+ offset = (scan->flags & 0xf) - 1
+ + (locinput - PL_bostr) * (scan->flags>>4);
+ mask = 1 << (offset % 8);
+ offset /= 8;
+ if (PL_reg_poscache[offset] & mask) {
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
+ "%*s whilem: (cache) already tried at this position...\n",
+ REPORT_CODE_OFF+depth*2, "")
);
sayNO; /* cache records failure */
}
+ ST.cache_offset = offset;
+ ST.cache_mask = mask;
}
- }
+ }
- /* Prefer next over scan for minimal matching. */
-
- if (st->cc->minmod) {
- st->u.whilem.savecc = st->cc;
- st->cc = st->cc->u.curlyx.outercc;
- if (st->cc)
- st->ln = st->cc->u.curlyx.cur;
- st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
- REGCP_SET(st->u.whilem.lastcp);
- REGMATCH(st->u.whilem.savecc->next, WHILEM3);
- /*** all unsaved local vars undefined at this point */
- st->cc = st->u.whilem.savecc;
- if (result) {
- regcpblow(st->u.whilem.cp);
- sayYES; /* All done. */
- }
- REGCP_UNWIND(st->u.whilem.lastcp);
- regcppop(rex);
- if (st->cc->u.curlyx.outercc)
- st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
-
- if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
- if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
- && !(PL_reg_flags & RF_warned)) {
- PL_reg_flags |= RF_warned;
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
- "Complex regular subexpression recursion",
- REG_INFTY - 1);
- }
- CACHEsayNO;
- }
+ /* Prefer B over A for minimal matching. */
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s trying longer...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
- /* Try scanning more and see if it helps. */
- PL_reginput = locinput;
- st->cc->u.curlyx.cur = n;
- st->cc->u.curlyx.lastloc = locinput;
- st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
- REGCP_SET(st->u.whilem.lastcp);
- REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
- /*** all unsaved local vars undefined at this point */
- if (result) {
- regcpblow(st->u.whilem.cp);
- sayYES;
- }
- REGCP_UNWIND(st->u.whilem.lastcp);
- regcppop(rex);
- st->cc->u.curlyx.cur = n - 1;
- st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
- CACHEsayNO;
- }
+ if (cur_curlyx->u.curlyx.minmod) {
+ ST.save_curlyx = cur_curlyx;
+ cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
+ ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
+ REGCP_SET(ST.lastcp);
+ PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
+ /* NOTREACHED */
+ }
- /* Prefer scan over next for maximal matching. */
-
- if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
- st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
- st->cc->u.curlyx.cur = n;
- st->cc->u.curlyx.lastloc = locinput;
- REGCP_SET(st->u.whilem.lastcp);
- REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
- /*** all unsaved local vars undefined at this point */
- if (result) {
- regcpblow(st->u.whilem.cp);
- sayYES;
- }
- REGCP_UNWIND(st->u.whilem.lastcp);
- regcppop(rex); /* Restore some previous $<digit>s? */
- PL_reginput = locinput;
- DEBUG_EXECUTE_r(
- PerlIO_printf(Perl_debug_log,
- "%*s failed, try continuation...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
- }
- if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
- && !(PL_reg_flags & RF_warned)) {
+ /* Prefer A over B for maximal matching. */
+
+ if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
+ ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
+ cur_curlyx->u.curlyx.lastloc = locinput;
+ REGCP_SET(ST.lastcp);
+ PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
+ /* NOTREACHED */
+ }
+ goto do_whilem_B_max;
+ }
+ /* NOTREACHED */
+
+ case WHILEM_B_min: /* just matched B in a minimal match */
+ case WHILEM_B_max: /* just matched B in a maximal match */
+ cur_curlyx = ST.save_curlyx;
+ sayYES;
+ /* NOTREACHED */
+
+ case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
+ cur_curlyx = ST.save_curlyx;
+ cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
+ cur_curlyx->u.curlyx.count--;
+ CACHEsayNO;
+ /* NOTREACHED */
+
+ case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
+ REGCP_UNWIND(ST.lastcp);
+ regcppop(rex);
+ /* FALL THROUGH */
+ case WHILEM_A_pre_fail: /* just failed to match even minimal A */
+ cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
+ cur_curlyx->u.curlyx.count--;
+ CACHEsayNO;
+ /* NOTREACHED */
+
+ case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
+ REGCP_UNWIND(ST.lastcp);
+ regcppop(rex); /* Restore some previous $<digit>s? */
+ PL_reginput = locinput;
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ "%*s whilem: failed, trying continuation...\n",
+ REPORT_CODE_OFF+depth*2, "")
+ );
+ do_whilem_B_max:
+ if (cur_curlyx->u.curlyx.count >= REG_INFTY
+ && ckWARN(WARN_REGEXP)
+ && !(PL_reg_flags & RF_warned))
+ {
+ PL_reg_flags |= RF_warned;
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
+ "Complex regular subexpression recursion",
+ REG_INFTY - 1);
+ }
+
+ /* now try B */
+ ST.save_curlyx = cur_curlyx;
+ cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
+ PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
+ /* NOTREACHED */
+
+ case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
+ cur_curlyx = ST.save_curlyx;
+ REGCP_UNWIND(ST.lastcp);
+ regcppop(rex);
+
+ if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
+ /* Maximum greed exceeded */
+ if (cur_curlyx->u.curlyx.count >= REG_INFTY
+ && ckWARN(WARN_REGEXP)
+ && !(PL_reg_flags & RF_warned))
+ {
PL_reg_flags |= RF_warned;
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
- "Complex regular subexpression recursion",
- REG_INFTY - 1);
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "%s limit (%d) exceeded",
+ "Complex regular subexpression recursion",
+ REG_INFTY - 1);
}
-
- /* Failed deeper matches of scan, so see if this one works. */
- st->u.whilem.savecc = st->cc;
- st->cc = st->cc->u.curlyx.outercc;
- if (st->cc)
- st->ln = st->cc->u.curlyx.cur;
- REGMATCH(st->u.whilem.savecc->next, WHILEM6);
- /*** all unsaved local vars undefined at this point */
- st->cc = st->u.whilem.savecc;
- if (result)
- sayYES;
- if (st->cc->u.curlyx.outercc)
- st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
- st->cc->u.curlyx.cur = n - 1;
- st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
+ cur_curlyx->u.curlyx.count--;
CACHEsayNO;
}
+
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
+ );
+ /* Try grabbing another A and see if it helps. */
+ PL_reginput = locinput;
+ cur_curlyx->u.curlyx.lastloc = locinput;
+ ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
+ REGCP_SET(ST.lastcp);
+ PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
/* NOTREACHED */
#undef ST
/* NOTREACHED */
case MINMOD:
- st->minmod = 1;
+ minmod = 1;
break;
#undef ST
ST.B = next;
ST.alen = 0;
ST.count = 0;
- ST.minmod = st->minmod;
- st->minmod = 0;
+ ST.minmod = minmod;
+ minmod = 0;
ST.c1 = CHRTEST_UNINIT;
REGCP_SET(ST.cp);
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
- (int)(REPORT_CODE_OFF+(PL_regindent*2)), "",
+ (int)(REPORT_CODE_OFF+(depth*2)), "",
(IV) ST.count, (IV)ST.alen)
);
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s CURLYM trying tail with matches=%"IVdf"...\n",
- (int)(REPORT_CODE_OFF+(PL_regindent*2)),
+ (int)(REPORT_CODE_OFF+(depth*2)),
"", (IV)ST.count)
);
if (ST.c1 != CHRTEST_VOID
ST.A = scan;
ST.B = next;
PL_reginput = locinput;
- if (st->minmod) {
- st->minmod = 0;
+ if (minmod) {
+ minmod = 0;
if (ST.min && regrepeat(rex, ST.A, ST.min) < ST.min)
sayNO;
ST.count = ST.min;
case END:
+ fake_end:
+ if (cur_eval) {
+ /* we've just finished A in /(??{A})B/; now continue with B */
+ I32 tmpix;
+
+
+ st->u.eval.toggle_reg_flags
+ = cur_eval->u.eval.toggle_reg_flags;
+ PL_reg_flags ^= st->u.eval.toggle_reg_flags;
+
+ st->u.eval.prev_rex = rex; /* inner */
+ rex = cur_eval->u.eval.prev_rex; /* outer */
+ cur_curlyx = cur_eval->u.eval.prev_curlyx;
+ ReREFCNT_inc(rex);
+ st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
+ REGCP_SET(st->u.eval.lastcp);
+ PL_reginput = locinput;
+
+ /* Restore parens of the outer rex without popping the
+ * savestack */
+ tmpix = PL_savestack_ix;
+ PL_savestack_ix = cur_eval->u.eval.lastcp;
+ regcppop(rex);
+ PL_savestack_ix = tmpix;
+
+ st->u.eval.prev_eval = cur_eval;
+ cur_eval = cur_eval->u.eval.prev_eval;
+ DEBUG_EXECUTE_r(
+ PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %x\n",
+ REPORT_CODE_OFF+depth*2, "",(int)cur_eval););
+ PUSH_YES_STATE_GOTO(EVAL_AB,
+ st->u.eval.prev_eval->u.eval.B); /* match B */
+ }
+
if (locinput < reginfo->till) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
(long)(locinput - PL_reg_starttry),
(long)(reginfo->till - PL_reg_starttry),
PL_colors[5]));
- sayNO_FINAL; /* Cannot match: too short. */
+ sayNO_SILENT; /* Cannot match: too short. */
}
PL_reginput = locinput; /* put where regtry can find it */
- sayYES_FINAL; /* Success! */
+ sayYES; /* Success! */
case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %ssubpattern success...%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
+ REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
PL_reginput = locinput; /* put where regtry can find it */
- sayYES_FINAL; /* Success! */
+ sayYES; /* Success! */
#undef ST
#define ST st->u.ifmatch
char * const s = HOPBACKc(locinput, scan->flags);
if (!s) {
/* trivial fail */
- if (st->logical) {
- st->logical = 0;
- st->sw = 1 - (bool)ST.wanted;
+ if (logical) {
+ logical = 0;
+ sw = 1 - (bool)ST.wanted;
}
else if (ST.wanted)
sayNO;
do_ifmatch:
ST.me = scan;
+ ST.logical = logical;
/* execute body of (?...A) */
PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
/* NOTREACHED */
/* FALL THROUGH */
case IFMATCH_A: /* body of (?...A) succeeded */
- if (st->logical) {
- st->logical = 0;
- st->sw = (bool)ST.wanted;
+ if (ST.logical) {
+ sw = (bool)ST.wanted;
}
else if (!ST.wanted)
sayNO;
{
regmatch_state *newst;
+ DEBUG_STATE_pp("push");
depth++;
- DEBUG_STATE_r(PerlIO_printf(Perl_debug_log,
- "PUSH STATE(%d)\n", depth));
st->locinput = locinput;
newst = st+1;
if (newst > SLAB_LAST(PL_regmatch_slab))
newst = S_push_slab(aTHX);
PL_regmatch_state = newst;
- newst->cc = st->cc;
- /* XXX probably don't need to initialise these */
- newst->minmod = 0;
- newst->sw = 0;
- newst->logical = 0;
-
locinput = PL_reginput;
nextchr = UCHARAT(locinput);
continue;
/* NOTREACHED */
}
-
- /* simulate recursively calling regmatch(), but without actually
- * recursing - ie save the current state on the heap rather than on
- * the stack, then re-enter the loop. This avoids complex regexes
- * blowing the processor stack */
-
- start_recurse:
- {
- /* push new state */
- regmatch_state *oldst = st;
-
- depth++;
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH RECURSE STATE(%d)\n", depth));
-
- /* grab the next free state slot */
- st++;
- if (st > SLAB_LAST(PL_regmatch_slab))
- st = S_push_slab(aTHX);
- PL_regmatch_state = st;
-
- oldst->next = next;
- oldst->n = n;
- oldst->locinput = locinput;
-
- st->cc = oldst->cc;
- locinput = PL_reginput;
- nextchr = UCHARAT(locinput);
- st->minmod = 0;
- st->sw = 0;
- st->logical = 0;
-
-#ifdef DEBUGGING
- PL_regindent++;
-#endif
- }
}
-
-
/*
* We get here only if there's trouble -- normally "case END" is
* the terminating point.
/*NOTREACHED*/
sayNO;
-yes_final:
-
+yes:
if (yes_state) {
/* we have successfully completed a subexpression, but we must now
* pop to the state marked by yes_state and continue from there */
-
assert(st != yes_state);
+#ifdef DEBUGGING
+ while (st != yes_state) {
+ st--;
+ if (st < SLAB_FIRST(PL_regmatch_slab)) {
+ PL_regmatch_slab = PL_regmatch_slab->prev;
+ st = SLAB_LAST(PL_regmatch_slab);
+ }
+ DEBUG_STATE_pp("pop (yes)");
+ depth--;
+ }
+#else
while (yes_state < SLAB_FIRST(PL_regmatch_slab)
|| yes_state > SLAB_LAST(PL_regmatch_slab))
{
st = SLAB_LAST(PL_regmatch_slab);
}
depth -= (st - yes_state);
- DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATES (%"UVuf"..%"UVuf")\n",
- (UV)(depth+1), (UV)(depth+(st - yes_state))));
+#endif
st = yes_state;
yes_state = st->u.yes.prev_yes_state;
PL_regmatch_state = st;
- switch (st->resume_state) {
- case IFMATCH_A:
- case CURLYM_A:
- case EVAL_A:
- state_num = st->resume_state;
- goto reenter_switch;
-
- case CURLYM_B:
- case BRANCH_next:
- case TRIE_next:
- case CURLY_B_max:
- default:
- Perl_croak(aTHX_ "unexpected yes resume state");
- }
+ state_num = st->resume_state;
+ goto reenter_switch;
}
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
PL_colors[4], PL_colors[5]));
-yes:
-#ifdef DEBUGGING
- PL_regindent--;
-#endif
result = 1;
- /* XXX this is duplicate(ish) code to that in the do_no section.
- * will disappear when REGFMATCH goes */
- if (depth) {
- /* restore previous state and re-enter */
- DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
- depth--;
- st--;
- if (st < SLAB_FIRST(PL_regmatch_slab)) {
- PL_regmatch_slab = PL_regmatch_slab->prev;
- st = SLAB_LAST(PL_regmatch_slab);
- }
- PL_regmatch_state = st;
- scan = st->scan;
- next = st->next;
- n = st->n;
- locinput= st->locinput;
- nextchr = UCHARAT(locinput);
-
- switch (st->resume_state) {
- case resume_CURLYX:
- goto resume_point_CURLYX;
- case resume_WHILEM1:
- goto resume_point_WHILEM1;
- case resume_WHILEM2:
- goto resume_point_WHILEM2;
- case resume_WHILEM3:
- goto resume_point_WHILEM3;
- case resume_WHILEM4:
- goto resume_point_WHILEM4;
- case resume_WHILEM5:
- goto resume_point_WHILEM5;
- case resume_WHILEM6:
- goto resume_point_WHILEM6;
-
- case TRIE_next:
- case CURLYM_A:
- case CURLYM_B:
- case EVAL_A:
- case IFMATCH_A:
- case BRANCH_next:
- case CURLY_B_max:
- case CURLY_B_min:
- case CURLY_B_min_known:
- break;
-
- default:
- Perl_croak(aTHX_ "regexp resume memory corruption");
- }
- }
goto final_exit;
no:
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %sfailed...%s\n",
- REPORT_CODE_OFF+PL_regindent*2, "",
+ REPORT_CODE_OFF+depth*2, "",
PL_colors[4], PL_colors[5])
);
-no_final:
-do_no:
-
-#ifdef DEBUGGING
- PL_regindent--;
-#endif
- result = 0;
+no_silent:
if (depth) {
/* there's a previous state to backtrack to */
- DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
- depth--;
st--;
if (st < SLAB_FIRST(PL_regmatch_slab)) {
PL_regmatch_slab = PL_regmatch_slab->prev;
st = SLAB_LAST(PL_regmatch_slab);
}
PL_regmatch_state = st;
- scan = st->scan;
- next = st->next;
- n = st->n;
locinput= st->locinput;
nextchr = UCHARAT(locinput);
- switch (st->resume_state) {
- case resume_CURLYX:
- goto resume_point_CURLYX;
- case resume_WHILEM1:
- goto resume_point_WHILEM1;
- case resume_WHILEM2:
- goto resume_point_WHILEM2;
- case resume_WHILEM3:
- goto resume_point_WHILEM3;
- case resume_WHILEM4:
- goto resume_point_WHILEM4;
- case resume_WHILEM5:
- goto resume_point_WHILEM5;
- case resume_WHILEM6:
- goto resume_point_WHILEM6;
-
- case TRIE_next:
- case EVAL_A:
- case BRANCH_next:
- case CURLYM_A:
- case CURLYM_B:
- case IFMATCH_A:
- case CURLY_B_max:
- case CURLY_B_min:
- case CURLY_B_min_known:
- if (yes_state == st)
- yes_state = st->u.yes.prev_yes_state;
- state_num = st->resume_state + 1; /* failure = success + 1 */
- goto reenter_switch;
+ DEBUG_STATE_pp("pop");
+ depth--;
+ if (yes_state == st)
+ yes_state = st->u.yes.prev_yes_state;
- default:
- Perl_croak(aTHX_ "regexp resume memory corruption");
- }
+ state_num = st->resume_state + 1; /* failure = success + 1 */
+ goto reenter_switch;
}
+ result = 0;
-final_exit:
+ final_exit:
/* restore original high-water mark */
PL_regmatch_slab = orig_slab;
}
return result;
-
}
/*
c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
(UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
/* see [perl #37836] for UTF8_ALLOW_ANYUV */
- if (len == (STRLEN)-1)
+ if (len == (STRLEN)-1)
Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
}
}
}
else {
- while (off++) {
- if (s > lim) {
- s--;
- if (UTF8_IS_CONTINUED(*s)) {
- while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
- s--;
- }
- /* XXX could check well-formedness here */
+ while (off++ && s > lim) {
+ s--;
+ if (UTF8_IS_CONTINUED(*s)) {
+ while (s > lim && UTF8_IS_CONTINUATION(*s))
+ s--;
}
+ /* XXX could check well-formedness here */
}
}
return s;
}
+#ifdef XXX_dmq
+/* there are a bunch of places where we use two reghop3's that should
+ be replaced with this routine. but since thats not done yet
+ we ifdef it out - dmq
+*/
+STATIC U8 *
+S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
+{
+ dVAR;
+ if (off >= 0) {
+ while (off-- && s < rlim) {
+ /* XXX could check well-formedness here */
+ s += UTF8SKIP(s);
+ }
+ }
+ else {
+ while (off++ && s > llim) {
+ s--;
+ if (UTF8_IS_CONTINUED(*s)) {
+ while (s > llim && UTF8_IS_CONTINUATION(*s))
+ s--;
+ }
+ /* XXX could check well-formedness here */
+ }
+ }
+ return s;
+}
+#endif
+
STATIC U8 *
S_reghopmaybe3(U8* s, I32 off, const U8* lim)
{
return NULL;
}
else {
- while (off++) {
- if (s > lim) {
- s--;
- if (UTF8_IS_CONTINUED(*s)) {
- while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
- s--;
- }
- /* XXX could check well-formedness here */
+ while (off++ && s > lim) {
+ s--;
+ if (UTF8_IS_CONTINUED(*s)) {
+ while (s > lim && UTF8_IS_CONTINUATION(*s))
+ s--;
}
- else
- break;
+ /* XXX could check well-formedness here */
}
if (off <= 0)
return NULL;
https://perl5.git.perl.org / perl5.git / blobdiff