* "One Ring to rule them all, One Ring to find them..."
*/
+/* This file contains functions for executing a regular expression. See
+ * also regcomp.c which funnily enough, contains functions for compiling
+ * a regular expression.
+ *
+ * This file is also copied at build time to ext/re/re_exec.c, where
+ * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
+ * This causes the main functions to be compiled under new names and with
+ * debugging support added, which makes "use re 'debug'" work.
+
+ */
+
/* NOTE: this is derived from Henry Spencer's regexp code, and should not
* confused with the original package (see point 3 below). Thanks, Henry!
*/
**** Alterations to Henry's code are...
****
**** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- **** 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ **** 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
****
**** You may distribute under the terms of either the GNU General Public
**** License or the Artistic License, as specified in the README file.
#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
#define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim))
-#define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) { ENTER; save_re_context(); (void)CAT2(is_utf8_, a)((U8*)b); LEAVE; } } STMT_END
+#define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) { ENTER; save_re_context(); (void)CAT2(is_utf8_, a)((const U8*)b); LEAVE; } } STMT_END
/* for use after a quantifier and before an EXACT-like node -- japhy */
#define JUMPABLE(rn) ( \
}
/* These are needed since we do not localize EVAL nodes: */
-# define REGCP_SET(cp) DEBUG_r(PerlIO_printf(Perl_debug_log, \
+# define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \
" Setting an EVAL scope, savestack=%"IVdf"\n", \
(IV)PL_savestack_ix)); cp = PL_savestack_ix
-# define REGCP_UNWIND(cp) DEBUG_r(cp != PL_savestack_ix ? \
+# define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \
PerlIO_printf(Perl_debug_log, \
" Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
(IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
char *input;
I32 tmps;
+ GET_RE_DEBUG_FLAGS_DECL;
+
/* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
i = SSPOPINT;
assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
tmps = SSPOPINT;
if (paren <= *PL_reglastparen)
PL_regendp[paren] = tmps;
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
" restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
(UV)paren, (IV)PL_regstartp[paren],
(paren > *PL_reglastparen ? "(no)" : ""));
);
}
- DEBUG_r(
+ DEBUG_EXECUTE_r(
if ((I32)(*PL_reglastparen + 1) <= PL_regnpar) {
PerlIO_printf(Perl_debug_log,
" restoring \\%"IVdf"..\\%"IVdf" to undef\n",
I32 ml_anch;
register char *other_last = Nullch; /* other substr checked before this */
char *check_at = Nullch; /* check substr found at this pos */
+ I32 multiline = prog->reganch & PMf_MULTILINE;
#ifdef DEBUGGING
char *i_strpos = strpos;
SV *dsv = PERL_DEBUG_PAD_ZERO(0);
#endif
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
RX_MATCH_UTF8_set(prog,do_utf8);
if (prog->reganch & ROPT_UTF8) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"UTF-8 regex...\n"));
PL_reg_flags |= RF_utf8;
}
- DEBUG_r({
+ DEBUG_EXECUTE_r({
char *s = PL_reg_match_utf8 ?
sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
strpos;
if (!PL_colorset)
reginitcolors();
if (PL_reg_match_utf8)
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"UTF-8 target...\n"));
PerlIO_printf(Perl_debug_log,
"%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
/* CHR_DIST() would be more correct here but it makes things slow. */
if (prog->minlen > strend - strpos) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"String too short... [re_intuit_start]\n"));
goto fail;
}
check = prog->check_substr;
}
if (check == &PL_sv_undef) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"Non-utf string cannot match utf check string\n"));
goto fail;
}
if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
|| ( (prog->reganch & ROPT_ANCH_BOL)
- && !PL_multiline ) ); /* Check after \n? */
+ && !multiline ) ); /* Check after \n? */
if (!ml_anch) {
if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
/* SvCUR is not set on references: SvRV and SvPVX overlap */
&& sv && !SvROK(sv)
&& (strpos != strbeg)) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
goto fail;
}
if (prog->check_offset_min == prog->check_offset_max &&
if ( strend - s > slen || strend - s < slen - 1
|| (strend - s == slen && strend[-1] != '\n')) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
goto fail_finish;
}
/* Now should match s[0..slen-2] */
|| (slen > 1
&& memNE(SvPVX(check), s, slen)))) {
report_neq:
- DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
goto fail_finish;
}
}
else if (prog->reganch & ROPT_CANY_SEEN)
s = fbm_instr((U8*)(s + start_shift),
(U8*)(strend - end_shift),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);
else
s = fbm_instr(HOP3(s, start_shift, strend),
HOP3(strend, -end_shift, strbeg),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
(s ? "Found" : "Did not find"),
(check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
PL_colors[0],
check_at = s;
/* Finish the diagnostic message */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
+ DEBUG_EXECUTE_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.
must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
if (must == &PL_sv_undef) {
s = (char*)NULL;
- DEBUG_r(must = prog->anchored_utf8); /* for debug */
+ DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
}
else
s = fbm_instr(
HOP3(HOP3(last1, prog->anchored_offset, strend)
+ SvCUR(must), -(SvTAIL(must)!=0), strbeg),
must,
- PL_multiline ? FBMrf_MULTILINE : 0
+ multiline ? FBMrf_MULTILINE : 0
);
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"%s anchored substr `%s%.*s%s'%s",
(s ? "Found" : "Contradicts"),
PL_colors[0],
PL_colors[1], (SvTAIL(must) ? "$" : "")));
if (!s) {
if (last1 >= last2) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
", giving up...\n"));
goto fail_finish;
}
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
", trying floating at offset %ld...\n",
(long)(HOP3c(s1, 1, strend) - i_strpos)));
other_last = HOP3c(last1, prog->anchored_offset+1, strend);
goto restart;
}
else {
- DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
(long)(s - i_strpos)));
t = HOP3c(s, -prog->anchored_offset, strbeg);
other_last = HOP3c(s, 1, strend);
and end-of-str is not later than strend we are OK. */
if (must == &PL_sv_undef) {
s = (char*)NULL;
- DEBUG_r(must = prog->float_utf8); /* for debug message */
+ DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
}
else
s = fbm_instr((unsigned char*)s,
(unsigned char*)last + SvCUR(must)
- (SvTAIL(must)!=0),
- must, PL_multiline ? FBMrf_MULTILINE : 0);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
+ must, multiline ? FBMrf_MULTILINE : 0);
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
(s ? "Found" : "Contradicts"),
PL_colors[0],
(int)(SvCUR(must) - (SvTAIL(must)!=0)),
PL_colors[1], (SvTAIL(must) ? "$" : "")));
if (!s) {
if (last1 == last) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
", giving up...\n"));
goto fail_finish;
}
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
", trying anchored starting at offset %ld...\n",
(long)(s1 + 1 - i_strpos)));
other_last = last;
goto restart;
}
else {
- DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
(long)(s - i_strpos)));
other_last = s; /* Fix this later. --Hugo */
s = s1;
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",
+ DEBUG_EXECUTE_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;
}
/* We don't contradict the found floating substring. */
/* XXXX Why not check for STCLASS? */
s = t + 1;
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
goto set_useful;
}
/* Position contradicts check-string */
/* XXXX probably better to look for check-string
than for "\n", so one should lower the limit for t? */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
other_last = strpos = s = t + 1;
goto restart;
}
t++;
}
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
PL_colors[0],PL_colors[1]));
goto fail_finish;
}
else {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
PL_colors[0],PL_colors[1]));
}
s = t;
t = strpos;
goto find_anchor;
}
- DEBUG_r( if (ml_anch)
+ DEBUG_EXECUTE_r( if (ml_anch)
PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
(long)(strpos - i_strpos), PL_colors[0],PL_colors[1]);
);
)))
{
/* If flags & SOMETHING - do not do it many times on the same match */
- DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
if (do_utf8 ? prog->check_substr : prog->check_utf8)
SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
#ifdef DEBUGGING
- char *what = 0;
+ const char *what = 0;
#endif
if (endpos == strend) {
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"Could not match STCLASS...\n") );
goto fail;
}
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"This position contradicts STCLASS...\n") );
if ((prog->reganch & ROPT_ANCH) && !ml_anch)
goto fail;
/* Contradict one of substrings */
if (prog->anchored_substr || prog->anchored_utf8) {
if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
- DEBUG_r( what = "anchored" );
+ DEBUG_EXECUTE_r( what = "anchored" );
hop_and_restart:
s = HOP3c(t, 1, strend);
if (s + start_shift + end_shift > strend) {
/* XXXX Should be taken into account earlier? */
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"Could not match STCLASS...\n") );
goto fail;
}
if (!check)
goto giveup;
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"Looking for %s substr starting at offset %ld...\n",
what, (long)(s + start_shift - i_strpos)) );
goto restart;
s = check_at;
if (!check)
goto giveup;
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"Looking for anchored substr starting at offset %ld...\n",
(long)(other_last - i_strpos)) );
goto do_other_anchored;
s = t = t + 1;
if (!check)
goto giveup;
- DEBUG_r( PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"Looking for /%s^%s/m starting at offset %ld...\n",
PL_colors[0],PL_colors[1], (long)(t - i_strpos)) );
goto try_at_offset;
/* Check is floating subtring. */
retry_floating_check:
t = check_at - start_shift;
- DEBUG_r( what = "floating" );
+ DEBUG_EXECUTE_r( what = "floating" );
goto hop_and_restart;
}
if (t != s) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"By STCLASS: moving %ld --> %ld\n",
(long)(t - i_strpos), (long)(s - i_strpos))
);
}
else {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"Does not contradict STCLASS...\n");
);
}
}
giveup:
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
PL_colors[4], (check ? "Guessed" : "Giving up"),
PL_colors[5], (long)(s - i_strpos)) );
return s;
if (prog->check_substr || prog->check_utf8) /* could be removed already */
BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
fail:
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
PL_colors[4],PL_colors[5]));
return Nullch;
}
char *m;
STRLEN ln;
STRLEN lnc;
+ register STRLEN uskip;
unsigned int c1;
unsigned int c2;
char *e;
switch (OP(c)) {
case ANYOF:
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
!UTF8_IS_INVARIANT((U8)s[0]) ?
reginclass(c, (U8*)s, 0, do_utf8) :
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
if (UTF) {
STRLEN ulen1, ulen2;
U8 *sm = (U8 *) m;
- U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
- U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
+ U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
- c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN_UCLC,
+ c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN_UCLC,
+ c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
lnc = 0;
while (sm < ((U8 *) m + ln)) {
if (do_utf8) {
UV c, f;
- U8 tmpbuf [UTF8_MAXLEN+1];
- U8 foldbuf[UTF8_MAXLEN_FOLD+1];
+ U8 tmpbuf [UTF8_MAXBYTES+1];
+ U8 foldbuf[UTF8_MAXBYTES_CASE+1];
STRLEN len, foldlen;
if (c1 == c2) {
/* Upper and lower of 1st char are equal -
* probably not a "letter". */
while (s <= e) {
- c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len,
+ c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
if ( c == c1
}
else {
while (s <= e) {
- c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len,
+ c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
tmp = ((OP(c) == BOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
LOAD_UTF8_CHARCLASS(alnum,"a");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (tmp == !(OP(c) == BOUND ?
swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
isALNUM_LC_utf8((U8*)s)))
if ((norun || regtry(prog, s)))
goto got_it;
}
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
tmp = ((OP(c) == NBOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
LOAD_UTF8_CHARCLASS(alnum,"a");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (tmp == !(OP(c) == NBOUND ?
swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
isALNUM_LC_utf8((U8*)s)))
tmp = !tmp;
else if ((norun || regtry(prog, s)))
goto got_it;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case ALNUM:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case ALNUML:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (isALNUM_LC_utf8((U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NALNUM:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(alnum,"a");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NALNUML:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!isALNUM_LC_utf8((U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case SPACE:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case SPACEL:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NSPACE:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(space," ");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NSPACEL:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case DIGIT:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case DIGITL:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (isDIGIT_LC_utf8((U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NDIGIT:
if (do_utf8) {
LOAD_UTF8_CHARCLASS(digit,"0");
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
case NDIGITL:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
- while (s < strend) {
+ while (s + (uskip = UTF8SKIP(s)) <= strend) {
if (!isDIGIT_LC_utf8((U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
}
else
tmp = 1;
- s += UTF8SKIP(s);
+ s += uskip;
}
}
else {
char *scream_olds;
SV* oreplsv = GvSV(PL_replgv);
bool do_utf8 = DO_UTF8(sv);
+ I32 multiline = prog->reganch & PMf_MULTILINE;
#ifdef DEBUGGING
SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
#endif
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
RX_MATCH_UTF8_set(prog,do_utf8);
PL_regcc = 0;
minlen = prog->minlen;
if (strend - startpos < minlen) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"String too short [regexec_flags]...\n"));
goto phooey;
}
d.scream_pos = &scream_pos;
s = re_intuit_start(prog, sv, s, strend, flags, &d);
if (!s) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
goto phooey; /* not present */
}
}
- DEBUG_r({
+ DEBUG_EXECUTE_r({
char *s0 = UTF ?
pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
UNI_DISPLAY_REGEX) :
if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
if (s == startpos && regtry(prog, startpos))
goto got_it;
- else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+ else if (multiline || (prog->reganch & ROPT_IMPLICIT)
|| (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
{
char *end;
if (do_utf8) {
while (s < strend) {
if (*s == ch) {
- DEBUG_r( did_match = 1 );
+ DEBUG_EXECUTE_r( did_match = 1 );
if (regtry(prog, s)) goto got_it;
s += UTF8SKIP(s);
while (s < strend && *s == ch)
else {
while (s < strend) {
if (*s == ch) {
- DEBUG_r( did_match = 1 );
+ DEBUG_EXECUTE_r( did_match = 1 );
if (regtry(prog, s)) goto got_it;
s++;
while (s < strend && *s == ch)
s++;
}
}
- DEBUG_r(if (!did_match)
+ DEBUG_EXECUTE_r(if (!did_match)
PerlIO_printf(Perl_debug_log,
"Did not find anchored character...\n")
);
end_shift, &scream_pos, 0))
: (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
(unsigned char*)strend, must,
- PL_multiline ? FBMrf_MULTILINE : 0))) ) {
+ multiline ? FBMrf_MULTILINE : 0))) ) {
/* we may be pointing at the wrong string */
if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX(sv));
- DEBUG_r( did_match = 1 );
+ DEBUG_EXECUTE_r( did_match = 1 );
if (HOPc(s, -back_max) > last1) {
last1 = HOPc(s, -back_min);
s = HOPc(s, -back_max);
}
}
}
- DEBUG_r(if (!did_match)
+ DEBUG_EXECUTE_r(if (!did_match)
PerlIO_printf(Perl_debug_log,
"Did not find %s substr `%s%.*s%s'%s...\n",
((must == prog->anchored_substr || must == prog->anchored_utf8)
if (PL_regkind[op] != EXACT && op != CANY)
strend = HOPc(strend, -(minlen - 1));
}
- DEBUG_r({
+ DEBUG_EXECUTE_r({
SV *prop = sv_newmortal();
char *s0;
char *s1;
});
if (find_byclass(prog, c, s, strend, startpos, 0))
goto got_it;
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
}
else {
dontbother = 0;
if (SvTAIL(float_real)) {
if (memEQ(strend - len + 1, little, len - 1))
last = strend - len + 1;
- else if (!PL_multiline)
+ else if (!multiline)
last = memEQ(strend - len, little, len)
? strend - len : Nullch;
else
}
}
if (last == NULL) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ 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! */
return 1;
phooey:
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
PL_colors[4],PL_colors[5]));
if (PL_reg_eval_set)
restore_pos(aTHX_ 0);
register I32 *sp;
register I32 *ep;
CHECKPOINT lastcp;
+ GET_RE_DEBUG_FLAGS_DECL;
#ifdef DEBUGGING
PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
MAGIC *mg;
PL_reg_eval_set = RS_init;
- DEBUG_r(DEBUG_s(
+ DEBUG_EXECUTE_r(DEBUG_s(
PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
(IV)(PL_stack_sp - PL_stack_base));
));
prog->lastparen = 0;
prog->lastcloseparen = 0;
PL_regsize = 0;
- DEBUG_r(PL_reg_starttry = startpos);
+ DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
if (PL_reg_start_tmpl <= prog->nparens) {
PL_reg_start_tmpl = prog->nparens*3/2 + 3;
if(PL_reg_start_tmp)
#define sayNO_SILENT goto do_no
#define saySAME(x) if (x) goto yes; else goto no
-#define REPORT_CODE_OFF 24
+/* 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.
+*/
+#define REPORT_CODE_OFF 29
+
+
+/* Make sure there is a test for this +1 options in re_tests */
+#define TRIE_INITAL_ACCEPT_BUFFLEN 4;
+
+#define TRIE_CHECK_STATE_IS_ACCEPTING STMT_START { \
+ if ( trie->states[ state ].wordnum ) { \
+ if ( !accepted ) { \
+ ENTER; \
+ SAVETMPS; \
+ bufflen = TRIE_INITAL_ACCEPT_BUFFLEN ; \
+ sv_accept_buff=NEWSV( 1234, \
+ bufflen * sizeof(reg_trie_accepted) - 1 ); \
+ SvCUR_set( sv_accept_buff, sizeof(reg_trie_accepted) ); \
+ SvPOK_on( sv_accept_buff ); \
+ sv_2mortal( sv_accept_buff ); \
+ accept_buff = (reg_trie_accepted*)SvPV_nolen( sv_accept_buff );\
+ } else { \
+ if ( accepted >= bufflen ) { \
+ bufflen *= 2; \
+ accept_buff =(reg_trie_accepted*)SvGROW( sv_accept_buff, \
+ bufflen * sizeof(reg_trie_accepted) ); \
+ } \
+ SvCUR_set( sv_accept_buff,SvCUR( sv_accept_buff ) \
+ + sizeof( reg_trie_accepted ) ); \
+ } \
+ accept_buff[ accepted ].wordnum = trie->states[ state ].wordnum; \
+ accept_buff[ accepted ].endpos = uc; \
+ ++accepted; \
+ } } STMT_END
+
+#define TRIE_HANDLE_CHAR STMT_START { \
+ if ( uvc < 256 ) { \
+ charid = trie->charmap[ uvc ]; \
+ } else { \
+ charid = 0; \
+ if( trie->widecharmap ) { \
+ SV** svpp = (SV**)NULL; \
+ svpp = hv_fetch( trie->widecharmap, (char*)&uvc, \
+ sizeof( UV ), 0 ); \
+ if ( svpp ) { \
+ charid = (U16)SvIV( *svpp ); \
+ } \
+ } \
+ } \
+ if ( charid && \
+ ( base + charid > trie->uniquecharcount ) && \
+ ( base + charid - 1 - trie->uniquecharcount < trie->lasttrans) && \
+ trie->trans[ base + charid - 1 - trie->uniquecharcount ].check == state ) \
+ { \
+ state = trie->trans[ base + charid - 1 - trie->uniquecharcount ].next; \
+ } else { \
+ state = 0; \
+ } \
+ uc += len; \
+ } STMT_END
/*
- regmatch - main matching routine
register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
int minmod = 0, sw = 0, logical = 0;
I32 unwind = 0;
+
+ /* used by the trie code */
+ SV *sv_accept_buff; /* accepting states we have traversed */
+ reg_trie_accepted *accept_buff; /* "" */
+ reg_trie_data *trie; /* what trie are we using right now */
+ U32 accepted = 0; /* how many accepting states we have seen*/
+
#if 0
I32 firstcp = PL_savestack_ix;
#endif
SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
+
+ SV *re_debug_flags;
#endif
+ GET_RE_DEBUG_FLAGS;
+
#ifdef DEBUGGING
PL_regindent++;
#endif
+
/* Note that nextchr is a byte even in UTF */
nextchr = UCHARAT(locinput);
scan = prog;
while (scan != NULL) {
- DEBUG_r( {
+ DEBUG_EXECUTE_r( {
SV *prop = sv_newmortal();
int docolor = *PL_colors[0];
int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
switch (OP(scan)) {
case BOL:
- if (locinput == PL_bostr || (PL_multiline &&
- (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
+ if (locinput == PL_bostr)
{
/* regtill = regbol; */
break;
break;
sayNO;
case EOL:
- if (PL_multiline)
- goto meol;
- else
goto seol;
case MEOL:
- meol:
if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
sayNO;
break;
else
nextchr = UCHARAT(++locinput);
break;
+
+
+
+ /*
+ traverse the TRIE keeping track of all accepting states
+ we transition through until we get to a failing node.
+
+ we use two slightly different pieces of code to handle
+ the traversal depending on whether its case sensitive or
+ not. we reuse the accept code however. (this should probably
+ be turned into a macro.)
+
+ */
+ case TRIEF:
+ case TRIEFL:
+ {
+
+ U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY;
+ U8 *uc = ( U8* )locinput;
+ U32 state = 1;
+ U16 charid = 0;
+ U32 base = 0;
+ UV uvc = 0;
+ STRLEN len = 0;
+ STRLEN foldlen = 0;
+ U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
+ U8 *uscan = (U8*)NULL;
+ STRLEN bufflen=0;
+ accepted = 0;
+
+ trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ];
+
+ while ( state && uc <= (U8*)PL_regeol ) {
+
+ TRIE_CHECK_STATE_IS_ACCEPTING;
+
+ base = trie->states[ state ].trans.base;
+
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "%*s %sState: %4x, Base: %4x Accepted: %4x ",
+ REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
+ state, base, accepted );
+ );
+
+ if ( base ) {
+
+ if ( do_utf8 || UTF ) {
+ if ( foldlen>0 ) {
+ uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
+ foldlen -= len;
+ uscan += len;
+ len=0;
+ } else {
+ uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
+ uvc = to_uni_fold( uvc, foldbuf, &foldlen );
+ foldlen -= UNISKIP( uvc );
+ uscan = foldbuf + UNISKIP( uvc );
+ }
+ } else {
+ uvc = (U32)*uc;
+ len = 1;
+ }
+
+ TRIE_HANDLE_CHAR;
+
+ } else {
+ state = 0;
+ }
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "Charid:%3x CV:%4x After State: %4x%s\n",
+ charid, uvc, state, PL_colors[5] );
+ );
+ }
+ if ( !accepted ) {
+ sayNO;
+ } else {
+ goto TrieAccept;
+ }
+ }
+ /* unreached codepoint: we jump into the middle of the next case
+ from previous if blocks */
+ case TRIE:
+ {
+ U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY;
+ U8 *uc = (U8*)locinput;
+ U32 state = 1;
+ U16 charid = 0;
+ U32 base = 0;
+ UV uvc = 0;
+ STRLEN len = 0;
+ STRLEN bufflen = 0;
+ accepted = 0;
+
+ trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ];
+
+ while ( state && uc <= (U8*)PL_regeol ) {
+
+ TRIE_CHECK_STATE_IS_ACCEPTING;
+
+ base = trie->states[ state ].trans.base;
+
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "%*s %sState: %4x, Base: %4x Accepted: %4x ",
+ REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
+ state, base, accepted );
+ );
+
+ if ( base ) {
+
+ if ( do_utf8 || UTF ) {
+ uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
+ } else {
+ uvc = (U32)*uc;
+ len = 1;
+ }
+
+ TRIE_HANDLE_CHAR;
+
+ } else {
+ state = 0;
+ }
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "Charid:%3x CV:%4x After State: %4x%s\n",
+ charid, uvc, state, PL_colors[5] );
+ );
+ }
+ if ( !accepted ) {
+ sayNO;
+ }
+ }
+
+
+ /*
+ There was at least one accepting state that we
+ transitioned through. Presumably the number of accepting
+ states is going to be low, typically one or two. So we
+ simply scan through to find the one with lowest wordnum.
+ Once we find it, we swap the last state into its place
+ and decrement the size. We then try to match the rest of
+ the pattern at the point where the word ends, if we
+ succeed then we end the loop, otherwise the loop
+ eventually terminates once all of the accepting states
+ have been tried.
+ */
+ TrieAccept:
+ {
+ int gotit = 0;
+
+ if ( accepted == 1 ) {
+ DEBUG_EXECUTE_r({
+ SV **tmp = av_fetch( trie->words, accept_buff[ 0 ].wordnum-1, 0 );
+ PerlIO_printf( Perl_debug_log,
+ "%*s %sonly one match : #%d <%s>%s\n",
+ REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],
+ accept_buff[ 0 ].wordnum,
+ tmp ? SvPV_nolen( *tmp ) : "not compiled under -Dr",
+ PL_colors[5] );
+ });
+ PL_reginput = (char *)accept_buff[ 0 ].endpos;
+ /* in this case we free tmps/leave before we call regmatch
+ as we wont be using accept_buff again. */
+ FREETMPS;
+ LEAVE;
+ gotit = regmatch( scan + NEXT_OFF( scan ) );
+ } else {
+ DEBUG_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,"%*s %sgot %d possible matches%s\n",
+ REPORT_CODE_OFF + PL_regindent * 2, "",PL_colors[4], accepted,
+ PL_colors[5] );
+ );
+ while ( !gotit && accepted-- ) {
+ U32 best = 0;
+ U32 cur;
+ for( cur = 1 ; cur <= accepted ; cur++ ) {
+ DEBUG_TRIE_EXECUTE_r(
+ PerlIO_printf( Perl_debug_log,
+ "%*s %sgot %d (%d) as best, looking at %d (%d)%s\n",
+ REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
+ best, accept_buff[ best ].wordnum, cur,
+ accept_buff[ cur ].wordnum, PL_colors[5] );
+ );
+
+ if ( accept_buff[ cur ].wordnum < accept_buff[ best ].wordnum )
+ best = cur;
+ }
+ DEBUG_EXECUTE_r({
+ SV **tmp = av_fetch( trie->words, accept_buff[ best ].wordnum - 1, 0 );
+ PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at 0x%p%s\n",
+ REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],
+ accept_buff[best].wordnum,
+ tmp ? SvPV_nolen( *tmp ) : "not compiled under -Dr",scan,
+ PL_colors[5] );
+ });
+ if ( best<accepted ) {
+ reg_trie_accepted tmp = accept_buff[ best ];
+ accept_buff[ best ] = accept_buff[ accepted ];
+ accept_buff[ accepted ] = tmp;
+ best = accepted;
+ }
+ PL_reginput = (char *)accept_buff[ best ].endpos;
+
+ /*
+ as far as I can tell we only need the SAVETMPS/FREETMPS
+ for re's with EVAL in them but I'm leaving them in for
+ all until I can be sure.
+ */
+ SAVETMPS;
+ gotit = regmatch( scan + NEXT_OFF( scan ) ) ;
+ FREETMPS;
+ }
+ FREETMPS;
+ LEAVE;
+ }
+
+ if ( gotit ) {
+ sayYES;
+ } else {
+ sayNO;
+ }
+ }
+ /* unreached codepoint */
case EXACT:
s = STRING(scan);
ln = STR_LEN(scan);
if (l >= PL_regeol)
sayNO;
if (NATIVE_TO_UNI(*(U8*)s) !=
- utf8n_to_uvuni((U8*)l, UTF8_MAXLEN, &ulen,
+ utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY))
sayNO;
if (l >= PL_regeol)
sayNO;
if (NATIVE_TO_UNI(*((U8*)l)) !=
- utf8n_to_uvuni((U8*)s, UTF8_MAXLEN, &ulen,
+ utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY))
sayNO;
*/
if (OP(scan) == REFF) {
STRLEN ulen1, ulen2;
- U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
- U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
+ U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
while (s < e) {
if (l >= PL_regeol)
sayNO;
n = ARG(scan);
PL_op = (OP_4tree*)PL_regdata->data[n];
- DEBUG_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
+ DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_regdata->data[n + 2]);
PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
PL_regsize = osize;
PL_regnpar = onpar;
}
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"Entering embedded `%s%.60s%s%s'\n",
PL_colors[0],
n = cc->cur + 1; /* how many we know we matched */
PL_reginput = locinput;
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %ld out of %ld..%ld cc=%"UVxf"\n",
REPORT_CODE_OFF+PL_regindent*2, "",
PL_regcc = cc->oldcc;
if (PL_regcc)
ln = PL_regcc->cur;
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s empty match detected, try continuation...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
PL_reg_poscache_size = size;
Newz(29, PL_reg_poscache, size, char);
}
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%sDetected a super-linear match, switching on caching%s...\n",
PL_colors[4], PL_colors[5])
b = o % 8;
o /= 8;
if (PL_reg_poscache[o] & (1<<b)) {
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s already tried at this position...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
sayNO;
}
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s trying longer...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
REGCP_UNWIND(lastcp);
regcppop(); /* Restore some previous $<digit>s? */
PL_reginput = locinput;
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s failed, try continuation...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
CHECKPOINT lastcp;
/* We suppose that the next guy does not need
- backtracking: in particular, it is of constant length,
+ backtracking: in particular, it is of constant non-zero length,
and has no parenths to influence future backrefs. */
ln = ARG1(scan); /* min to match */
n = ARG2(scan); /* max to match */
minmod = 0;
if (ln && regrepeat_hard(scan, ln, &l) < ln)
sayNO;
- /* if we matched something zero-length we don't need to
- backtrack - capturing parens are already defined, so
- the caveat in the maximal case doesn't apply
-
- XXXX if ln == 0, we can redo this check first time
- through the following loop
- */
- if (ln && l == 0)
- n = ln; /* don't backtrack */
locinput = PL_reginput;
if (HAS_TEXT(next) || JUMPABLE(next)) {
regnode *text_node = next;
c1 = c2 = -1000;
assume_ok_MM:
REGCP_SET(lastcp);
- /* This may be improved if l == 0. */
- while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
+ while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
/* If it could work, try it. */
if (c1 == -1000 ||
UCHARAT(PL_reginput) == c1 ||
}
else {
n = regrepeat_hard(scan, n, &l);
- /* if we matched something zero-length we don't need to
- backtrack, unless the minimum count is zero and we
- are capturing the result - in that case the capture
- being defined or not may affect later execution
- */
- if (n != 0 && l == 0 && !(paren && ln == 0))
- ln = n; /* don't backtrack */
locinput = PL_reginput;
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s matched %"IVdf" times, len=%"IVdf"...\n",
(int)(REPORT_CODE_OFF+PL_regindent*2), "",
UCHARAT(PL_reginput) == c1 ||
UCHARAT(PL_reginput) == c2)
{
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s trying tail with n=%"IVdf"...\n",
(int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
else { /* UTF */
if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
STRLEN ulen1, ulen2;
- U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
- U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
+ U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
- c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXLEN, 0,
+ c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
- c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXLEN, 0,
+ c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
}
else {
- c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXLEN, 0,
+ c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
}
* utf8_distance(old, locinput) */
while (locinput <= e &&
utf8n_to_uvchr((U8*)locinput,
- UTF8_MAXLEN, &len,
+ UTF8_MAXBYTES, &len,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY) != (UV)c1) {
locinput += len;
* utf8_distance(old, locinput) */
while (locinput <= e) {
UV c = utf8n_to_uvchr((U8*)locinput,
- UTF8_MAXLEN, &len,
+ UTF8_MAXBYTES, &len,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
if (c == (UV)c1 || c == (UV)c2)
if (c1 != -1000) {
if (do_utf8)
c = utf8n_to_uvchr((U8*)PL_reginput,
- UTF8_MAXLEN, 0,
+ UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
else
n = regrepeat(scan, n);
locinput = PL_reginput;
if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
- ((!PL_multiline && OP(next) != MEOL) ||
+ (OP(next) != MEOL ||
OP(next) == SEOL || OP(next) == EOS))
{
ln = n; /* why back off? */
if (c1 != -1000) {
if (do_utf8)
c = utf8n_to_uvchr((U8*)PL_reginput,
- UTF8_MAXLEN, 0,
+ UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
else
if (c1 != -1000) {
if (do_utf8)
c = utf8n_to_uvchr((U8*)PL_reginput,
- UTF8_MAXLEN, 0,
+ UTF8_MAXBYTES, 0,
ckWARN(WARN_UTF8) ?
0 : UTF8_ALLOW_ANY);
else
PL_reg_re = re;
cache_re(re);
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s continuation failed...\n",
REPORT_CODE_OFF+PL_regindent*2, "")
sayNO_SILENT;
}
if (locinput < PL_regtill) {
- DEBUG_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_EXECUTE_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),
sayNO;
yes_loud:
- DEBUG_r(
+ DEBUG_EXECUTE_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",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
PL_colors[4],PL_colors[5]));
yes:
#ifdef DEBUGGING
return 1;
no:
- DEBUG_r(
+ DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log,
"%*s %sfailed...%s\n",
REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
c = scan - PL_reginput;
PL_reginput = scan;
- DEBUG_r(
- {
+ DEBUG_r({
+ SV *re_debug_flags;
SV *prop = sv_newmortal();
-
+ GET_RE_DEBUG_FLAGS;
+ DEBUG_EXECUTE_r({
regprop(prop, p);
PerlIO_printf(Perl_debug_log,
"%*s %s can match %"IVdf" times out of %"IVdf"...\n",
REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
});
+ });
return(c);
}
/*
- regrepeat_hard - repeatedly match something, report total lenth and length
*
- * The repeater is supposed to have constant length.
+ * The repeater is supposed to have constant non-zero length.
*/
STATIC I32
STRLEN plen;
if (do_utf8 && !UTF8_IS_INVARIANT(c))
- c = utf8n_to_uvchr(p, UTF8_MAXLEN, &len,
+ c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
}
}
if (!match) {
- U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN tmplen;
to_utf8_fold(p, tmpbuf, &tmplen);
{
SV* sv;
if (prog->float_substr && !prog->float_utf8) {
- prog->float_utf8 = sv = NEWSV(117, 0);
- SvSetSV(sv, prog->float_substr);
+ prog->float_utf8 = sv = newSVsv(prog->float_substr);
sv_utf8_upgrade(sv);
if (SvTAIL(prog->float_substr))
SvTAIL_on(sv);
prog->check_utf8 = sv;
}
if (prog->anchored_substr && !prog->anchored_utf8) {
- prog->anchored_utf8 = sv = NEWSV(118, 0);
- SvSetSV(sv, prog->anchored_substr);
+ prog->anchored_utf8 = sv = newSVsv(prog->anchored_substr);
sv_utf8_upgrade(sv);
if (SvTAIL(prog->anchored_substr))
SvTAIL_on(sv);
{
SV* sv;
if (prog->float_utf8 && !prog->float_substr) {
- prog->float_substr = sv = NEWSV(117, 0);
- SvSetSV(sv, prog->float_utf8);
+ prog->float_substr = sv = newSVsv(prog->float_utf8);
if (sv_utf8_downgrade(sv, TRUE)) {
if (SvTAIL(prog->float_utf8))
SvTAIL_on(sv);
prog->check_substr = sv;
}
if (prog->anchored_utf8 && !prog->anchored_substr) {
- prog->anchored_substr = sv = NEWSV(118, 0);
- SvSetSV(sv, prog->anchored_utf8);
+ prog->anchored_substr = sv = newSVsv(prog->anchored_utf8);
if (sv_utf8_downgrade(sv, TRUE)) {
if (SvTAIL(prog->anchored_utf8))
SvTAIL_on(sv);
projects / p5sagit/p5-mst-13.2.git / blobdiff