/* A failure to find a constant substring means that there is no need to make
an expensive call to REx engine, thus we celebrate a failure. Similarly,
finding a substring too deep into the string means that less calls to
- regtry() should be needed. */
+ regtry() should be needed.
+
+ REx compiler's optimizer found 4 possible hints:
+ a) Anchored substring;
+ b) Fixed substring;
+ c) Whether we are anchored (beginning-of-line or \G);
+ d) First node (of those at offset 0) which may distingush positions;
+ We use 'a', 'b', multiline-part of 'c', and try to find a position in the
+ string which does not contradict any of them.
+ */
char *
Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
I32 ml_anch;
char *tmp;
register char *other_last = Nullch;
+#ifdef DEBUGGING
+ char *i_strpos = strpos;
+#endif
DEBUG_r( if (!PL_colorset) reginitcolors() );
DEBUG_r(PerlIO_printf(Perl_debug_log,
#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
- croak("panic: end_shift");
+ Perl_croak(aTHX_ "panic: end_shift");
#endif
check = prog->check_substr;
goto fail_finish;
/* Finish the diagnostic message */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - strpos)) );
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
/* Got a candidate. Check MBOL anchoring, and the *other* substr.
Start with the other substr.
*/
if (prog->float_substr && prog->anchored_substr) {
- /* Take into account the anchored substring. */
+ /* Take into account the "other" substring. */
/* XXXX May be hopelessly wrong for UTF... */
if (!other_last)
other_last = strpos - 1;
if (check == prog->float_substr) {
+ do_other_anchored:
+ {
char *last = s - start_shift, *last1, *last2;
char *s1 = s;
|| (PL_bostr = strpos, /* Used in regcopmaybe() */
(t = reghopmaybe_c(s, -(prog->check_offset_max)))
&& t > strpos)))
- ;
+ /* EMPTY */;
else
t = strpos;
t += prog->anchored_offset;
}
DEBUG_r(PerlIO_printf(Perl_debug_log,
", trying floating at offset %ld...\n",
- (long)(s1 + 1 - strpos)));
+ (long)(s1 + 1 - i_strpos)));
PL_regeol = strend; /* Used in HOP() */
other_last = last1 + prog->anchored_offset;
s = HOPc(last, 1);
}
else {
DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
- (long)(s - strpos)));
+ (long)(s - i_strpos)));
t = s - prog->anchored_offset;
other_last = s - 1;
+ s = s1;
if (t == strpos)
goto try_at_start;
- s = s1;
goto try_at_offset;
}
+ }
}
else { /* Take into account the floating substring. */
char *last, *last1;
}
DEBUG_r(PerlIO_printf(Perl_debug_log,
", trying anchored starting at offset %ld...\n",
- (long)(s1 + 1 - strpos)));
+ (long)(s1 + 1 - i_strpos)));
other_last = last;
PL_regeol = strend; /* Used in HOP() */
s = HOPc(t, 1);
}
else {
DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
- (long)(s - strpos)));
+ (long)(s - i_strpos)));
other_last = s - 1;
+ s = s1;
if (t == strpos)
goto try_at_start;
- s = s1;
goto try_at_offset;
}
}
cannot start at strpos. */
try_at_offset:
if (ml_anch && t[-1] != '\n') {
- find_anchor: /* Eventually fbm_*() should handle this */
+ /* Eventually fbm_*() should handle this, but often
+ anchored_offset is not 0, so this check will not be wasted. */
+ /* XXXX In the code below we prefer to look for "^" even in
+ presence of anchored substrings. And we search even
+ beyond the found float position. These pessimizations
+ are historical artefacts only. */
+ find_anchor:
while (t < strend - prog->minlen) {
if (*t == '\n') {
if (t < s - prog->check_offset_min) {
+ if (prog->anchored_substr) {
+ /* We definitely contradict the found anchored
+ substr. Due to the above check we do not
+ contradict "check" substr.
+ Thus we can arrive here only if check substr
+ is float. Redo checking for "other"=="fixed".
+ */
+ strpos = t + 1;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
+ PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
+ goto do_other_anchored;
+ }
s = t + 1;
DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
- PL_colors[0],PL_colors[1], (long)(s - strpos)));
+ PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
goto set_useful;
}
DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n",
- PL_colors[0],PL_colors[1], (long)(t + 1 - strpos)));
- s = t + 1;
+ PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
+ strpos = s = t + 1;
goto restart;
}
t++;
t = strpos;
goto find_anchor;
}
+ DEBUG_r( if (ml_anch)
+ PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n",
+ PL_colors[0],PL_colors[1]);
+ );
success_at_start:
- if (!(prog->reganch & ROPT_NAUGHTY)
+ if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
&& --BmUSEFUL(prog->check_substr) < 0
&& prog->check_substr == prog->float_substr) { /* boo */
/* If flags & SOMETHING - do not do it many times on the same match */
}
DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n",
- PL_colors[4], PL_colors[5], (long)(s - strpos)) );
+ PL_colors[4], PL_colors[5], (long)(s - i_strpos)) );
return s;
fail_finish: /* Substring not found */
register I32 tmp;
I32 minlen; /* must match at least this many chars */
I32 dontbother = 0; /* how many characters not to try at end */
- CURCUR cc;
I32 start_shift = 0; /* Offset of the start to find
constant substr. */ /* CC */
I32 end_shift = 0; /* Same for the end. */ /* CC */
char *scream_olds;
SV* oreplsv = GvSV(PL_replgv);
- cc.cur = 0;
- cc.oldcc = 0;
- PL_regcc = &cc;
+ PL_regcc = 0;
cache_re(prog);
#ifdef DEBUGGING
/* If there is a "must appear" string, look for it. */
s = startpos;
- if (prog->reganch & ROPT_GPOS_SEEN) {
+ if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
MAGIC *mg;
- if (!(flags & REXEC_IGNOREPOS) && sv && SvTYPE(sv) >= SVt_PVMG
- && SvMAGIC(sv) && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
- PL_reg_ganch = strbeg + mg->mg_len;
- else
+ if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
PL_reg_ganch = startpos;
- if (prog->reganch & ROPT_ANCH_GPOS) {
- if (s > PL_reg_ganch)
- goto phooey;
- s = PL_reg_ganch;
+ else if (sv && SvTYPE(sv) >= SVt_PVMG
+ && SvMAGIC(sv)
+ && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0) {
+ PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
+ if (prog->reganch & ROPT_ANCH_GPOS) {
+ if (s > PL_reg_ganch)
+ goto phooey;
+ s = PL_reg_ganch;
+ }
}
+ else /* pos() not defined */
+ PL_reg_ganch = strbeg;
}
if (!(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) {
end = HOPc(strend, -dontbother) - 1;
/* for multiline we only have to try after newlines */
if (prog->check_substr) {
+ if (s == startpos)
+ goto after_try;
while (1) {
if (regtry(prog, s))
goto got_it;
+ after_try:
if (s >= end)
goto phooey;
s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
/* We know what class it must start with. */
switch (OP(c)) {
case ANYOFUTF8:
- cc = (char *) OPERAND(c);
+ cc = MASK(c);
while (s < strend) {
if (REGINCLASSUTF8(c, (U8*)s)) {
if (tmp && regtry(prog, s))
}
break;
case ANYOF:
- cc = (char *) OPERAND(c);
+ cc = MASK(c);
while (s < strend) {
if (REGINCLASS(cc, *s)) {
if (tmp && regtry(prog, s))
}
PL_reg_magic = mg;
PL_reg_oldpos = mg->mg_len;
- SAVEDESTRUCTOR(restore_pos, 0);
+ SAVEDESTRUCTOR_X(restore_pos, 0);
}
if (!PL_reg_curpm)
New(22,PL_reg_curpm, 1, PMOP);
#ifdef DEBUGGING
# define sayYES goto yes
# define sayNO goto no
+# define sayYES_FINAL goto yes_final
+# define sayYES_LOUD goto yes_loud
+# define sayNO_FINAL goto no_final
+# define sayNO_SILENT goto do_no
# define saySAME(x) if (x) goto yes; else goto no
# define REPORT_CODE_OFF 24
#else
# define sayYES return 1
# define sayNO return 0
+# define sayYES_FINAL return 1
+# define sayYES_LOUD return 1
+# define sayNO_FINAL return 0
+# define sayNO_SILENT return 0
# define saySAME(x) return x
#endif
DEBUG_r( {
nextchr = UCHARAT(++locinput);
break;
case EXACT:
- s = (char *) OPERAND(scan);
- ln = UCHARAT(s++);
+ s = STRING(scan);
+ ln = STR_LEN(scan);
/* Inline the first character, for speed. */
if (UCHARAT(s) != nextchr)
sayNO;
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case EXACTF:
- s = (char *) OPERAND(scan);
- ln = UCHARAT(s++);
+ s = STRING(scan);
+ ln = STR_LEN(scan);
if (UTF) {
char *l = locinput;
nextchr = UCHARAT(locinput);
break;
case ANYOFUTF8:
- s = (char *) OPERAND(scan);
+ s = MASK(scan);
if (!REGINCLASSUTF8(scan, (U8*)locinput))
sayNO;
if (locinput >= PL_regeol)
nextchr = UCHARAT(locinput);
break;
case ANYOF:
- s = (char *) OPERAND(scan);
+ s = MASK(scan);
if (nextchr < 0)
nextchr = UCHARAT(locinput);
if (!REGINCLASS(s, nextchr))
regexp *re;
MAGIC *mg = Null(MAGIC*);
re_cc_state state;
- CURCUR cctmp;
CHECKPOINT cp, lastcp;
if(SvROK(ret) || SvRMAGICAL(ret)) {
state.cc = PL_regcc;
state.re = PL_reg_re;
- cctmp.cur = 0;
- cctmp.oldcc = 0;
- PL_regcc = &cctmp;
+ PL_regcc = 0;
cp = regcppush(0); /* Save *all* the positions. */
REGCP_SET;
PL_reg_maxiter = 0;
if (regmatch(re->program + 1)) {
+ /* Even though we succeeded, we need to restore
+ global variables, since we may be wrapped inside
+ SUSPEND, thus the match may be not finished yet. */
+
+ /* XXXX Do this only if SUSPENDed? */
+ PL_reg_call_cc = state.prev;
+ PL_regcc = state.cc;
+ PL_reg_re = state.re;
+ cache_re(PL_reg_re);
+
+ /* XXXX This is too dramatic a measure... */
+ PL_reg_maxiter = 0;
+
+ /* These are needed even if not SUSPEND. */
ReREFCNT_dec(re);
regcpblow(cp);
sayYES;
}
- DEBUG_r(
- PerlIO_printf(Perl_debug_log,
- "%*s failed...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
ReREFCNT_dec(re);
REGCP_UNWIND;
regcppop();
case LOGICAL:
logical = scan->flags;
break;
+/*******************************************************************
+ PL_regcc contains infoblock about the innermost (...)* loop, and
+ a pointer to the next outer infoblock.
+
+ Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
+
+ 1) After matching X, regnode for CURLYX is processed;
+
+ 2) This regnode creates infoblock on the stack, and calls
+ regmatch() recursively with the starting point at WHILEM node;
+
+ 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 the infoblock, as is info on how many times "A"
+ was already matched, and greediness.
+
+ 4) After A matches, the same WHILEM node is hit again.
+
+ 5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
+ of the same pair. Thus when WHILEM tries to match Z, it temporarily
+ resets PL_regcc, 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.
+
+ Currently present infoblocks form a tree with a stem formed by PL_curcc
+ and whatever it mentions via ->next, and additional attached trees
+ corresponding to temporarily unset infoblocks as in "5" above.
+
+ 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.
+
+ 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.]
+
+ 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
+
+ YAAZ Y(A)*?Z)*?T x <- O
+ I
+
+ YAAZY (A)*?Z)*?T x <- O
+ I
+
+ YAAZY A)*?Z)*?T x <- O <- I
+ I
+
+ YAAZYA )*?Z)*?T x <- O <- I
+ I
+
+ YAAZYA Z)*?T x <- O # Temporary unset I
+ I,I
+
+ YAAZYAZ )*?T x <- O
+ I,I
+
+ YAAZYAZ T x # Temporary unset O
+ O
+ I,I
+
+ YAAZYAZT x
+ O
+ I,I
+ *******************************************************************/
case CURLYX: {
CURCUR cc;
CHECKPOINT cp = PL_savestack_ix;
if (locinput == cc->lastloc && n >= cc->min) {
PL_regcc = cc->oldcc;
- ln = PL_regcc->cur;
+ if (PL_regcc)
+ ln = PL_regcc->cur;
DEBUG_r(
PerlIO_printf(Perl_debug_log,
"%*s empty match detected, try continuation...\n",
);
if (regmatch(cc->next))
sayYES;
- DEBUG_r(
- PerlIO_printf(Perl_debug_log,
- "%*s failed...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
- PL_regcc->cur = ln;
+ if (PL_regcc)
+ PL_regcc->cur = ln;
PL_regcc = cc;
sayNO;
}
sayYES;
cc->cur = n - 1;
cc->lastloc = lastloc;
- DEBUG_r(
- PerlIO_printf(Perl_debug_log,
- "%*s failed...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
sayNO;
}
"%*s already tried at this position...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
);
- sayNO;
+ sayNO_SILENT;
}
PL_reg_poscache[o] |= (1<<b);
}
if (cc->minmod) {
PL_regcc = cc->oldcc;
- ln = PL_regcc->cur;
+ if (PL_regcc)
+ ln = PL_regcc->cur;
cp = regcppush(cc->parenfloor);
REGCP_SET;
if (regmatch(cc->next)) {
}
REGCP_UNWIND;
regcppop();
- PL_regcc->cur = ln;
+ if (PL_regcc)
+ PL_regcc->cur = ln;
PL_regcc = cc;
if (n >= cc->max) { /* Maximum greed exceeded? */
regcpblow(cp);
sayYES;
}
- DEBUG_r(
- PerlIO_printf(Perl_debug_log,
- "%*s failed...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
REGCP_UNWIND;
regcppop();
cc->cur = n - 1;
/* Failed deeper matches of scan, so see if this one works. */
PL_regcc = cc->oldcc;
- ln = PL_regcc->cur;
+ if (PL_regcc)
+ ln = PL_regcc->cur;
if (regmatch(cc->next))
sayYES;
- DEBUG_r(
- PerlIO_printf(Perl_debug_log, "%*s failed...\n",
- REPORT_CODE_OFF+PL_regindent*2, "")
- );
- PL_regcc->cur = ln;
+ if (PL_regcc)
+ PL_regcc->cur = ln;
PL_regcc = cc;
cc->cur = n - 1;
cc->lastloc = lastloc;
ln = n;
locinput = PL_reginput;
if (PL_regkind[(U8)OP(next)] == EXACT) {
- c1 = UCHARAT(OPERAND(next) + 1);
+ c1 = (U8)*STRING(next);
if (OP(next) == EXACTF)
c2 = PL_fold[c1];
else if (OP(next) == EXACTFL)
);
if (n >= ln) {
if (PL_regkind[(U8)OP(next)] == EXACT) {
- c1 = UCHARAT(OPERAND(next) + 1);
+ c1 = (U8)*STRING(next);
if (OP(next) == EXACTF)
c2 = PL_fold[c1];
else if (OP(next) == EXACTFL)
* when we know what character comes next.
*/
if (PL_regkind[(U8)OP(next)] == EXACT) {
- c1 = UCHARAT(OPERAND(next) + 1);
+ c1 = (U8)*STRING(next);
if (OP(next) == EXACTF)
c2 = PL_fold[c1];
else if (OP(next) == EXACTFL)
"%*s continuation failed...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
);
- sayNO;
+ sayNO_SILENT;
+ }
+ if (locinput < PL_regtill) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
+ PL_colors[4],
+ (long)(locinput - PL_reg_starttry),
+ (long)(PL_regtill - PL_reg_starttry),
+ PL_colors[5]));
+ sayNO_FINAL; /* Cannot match: too short. */
}
- if (locinput < PL_regtill)
- sayNO; /* Cannot match: too short. */
- /* Fall through */
+ PL_reginput = locinput; /* put where regtry can find it */
+ sayYES_FINAL; /* Success! */
case SUCCEED:
PL_reginput = locinput; /* put where regtry can find it */
- sayYES; /* Success! */
+ sayYES_LOUD; /* Success! */
case SUSPEND:
n = 1;
PL_reginput = locinput;
next = NULL;
break;
default:
- PerlIO_printf(PerlIO_stderr(), "%lx %d\n",
+ PerlIO_printf(Perl_error_log, "%lx %d\n",
(unsigned long)scan, OP(scan));
Perl_croak(aTHX_ "regexp memory corruption");
}
/*NOTREACHED*/
sayNO;
+yes_loud:
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s %scould match...%s\n",
+ REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
+ );
+ goto yes;
+yes_final:
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
+ PL_colors[4],PL_colors[5]));
yes:
#ifdef DEBUGGING
PL_regindent--;
return 1;
no:
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s %sfailed...%s\n",
+ REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
+ );
+ goto do_no;
+no_final:
+do_no:
#ifdef DEBUGGING
PL_regindent--;
#endif
scan = PL_reginput;
if (max != REG_INFTY && max < loceol - scan)
loceol = scan + max;
- opnd = (char *) OPERAND(p);
switch (OP(p)) {
case REG_ANY:
while (scan < loceol && *scan != '\n')
}
break;
case EXACT: /* length of string is 1 */
- c = UCHARAT(++opnd);
+ c = (U8)*STRING(p);
while (scan < loceol && UCHARAT(scan) == c)
scan++;
break;
case EXACTF: /* length of string is 1 */
- c = UCHARAT(++opnd);
+ c = (U8)*STRING(p);
while (scan < loceol &&
(UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
scan++;
break;
case EXACTFL: /* length of string is 1 */
PL_reg_flags |= RF_tainted;
- c = UCHARAT(++opnd);
+ c = (U8)*STRING(p);
while (scan < loceol &&
(UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
scan++;
}
break;
case ANYOF:
+ opnd = MASK(p);
while (scan < loceol && REGINCLASS(opnd, *scan))
scan++;
break;
projects / p5sagit/p5-mst-13.2.git / blobdiff