**** Alterations to Henry's code are...
****
**** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
/* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
/* for use after a quantifier and before an EXACT-like node -- japhy */
-#define JUMPABLE(rn) ( \
- OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
+/* it would be nice to rework regcomp.sym to generate this stuff. sigh */
+#define JUMPABLE(rn) ( \
+ OP(rn) == OPEN || \
+ (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
+ OP(rn) == EVAL || \
OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
OP(rn) == PLUS || OP(rn) == MINMOD || \
+ OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
(PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
)
+#define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
-#define HAS_TEXT(rn) ( \
- PL_regkind[OP(rn)] == EXACT || PL_regkind[OP(rn)] == REF \
-)
+#define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
+
+#if 0
+/* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
+ we don't need this definition. */
+#define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
+#define IS_TEXTF(rn) ( OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
+#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
+
+#else
+/* ... so we use this as its faster. */
+#define IS_TEXT(rn) ( OP(rn)==EXACT )
+#define IS_TEXTF(rn) ( OP(rn)==EXACTF )
+#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
+
+#endif
/*
Search for mandatory following text node; for lookahead, the text must
SSPUSHINT(PL_regstartp[p]);
SSPUSHPTR(PL_reg_start_tmp[p]);
SSPUSHINT(p);
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
" saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
(UV)p, (IV)PL_regstartp[p],
(IV)(PL_reg_start_tmp[p] - PL_bostr),
tmps = SSPOPINT;
if (paren <= *PL_reglastparen)
PL_regendp[paren] = tmps;
- DEBUG_EXECUTE_r(
+ DEBUG_BUFFERS_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_EXECUTE_r(
+ DEBUG_BUFFERS_r(
if (*PL_reglastparen + 1 <= rex->nparens) {
PerlIO_printf(Perl_debug_log,
" restoring \\%"IVdf"..\\%"IVdf" to undef\n",
I32 ml_anch;
register char *other_last = NULL; /* other substr checked before this */
char *check_at = NULL; /* check substr found at this pos */
- const I32 multiline = prog->reganch & PMf_MULTILINE;
+ const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
+ RXi_GET_DECL(prog,progi);
#ifdef DEBUGGING
const char * const i_strpos = strpos;
#endif
RX_MATCH_UTF8_set(prog,do_utf8);
- if (prog->reganch & ROPT_UTF8) {
+ if (prog->extflags & RXf_UTF8) {
PL_reg_flags |= RF_utf8;
}
DEBUG_EXECUTE_r(
"Non-utf8 string cannot match utf8 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)
+ if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
+ ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
+ || ( (prog->extflags & RXf_ANCH_BOL)
&& !multiline ) ); /* Check after \n? */
if (!ml_anch) {
- if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
- | ROPT_IMPLICIT)) /* not a real BOL */
+ if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
+ && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
/* SvCUR is not set on references: SvRV and SvPVX_const overlap */
&& sv && !SvROK(sv)
&& (strpos != strbeg)) {
goto fail;
}
if (prog->check_offset_min == prog->check_offset_max &&
- !(prog->reganch & ROPT_CANY_SEEN)) {
+ !(prog->extflags & RXf_CANY_SEEN)) {
/* Substring at constant offset from beg-of-str... */
I32 slen;
/* end shift should be non negative here */
}
-#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
+#ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
(IV)end_shift, prog->precomp);
else {
U8* start_point;
U8* end_point;
- if (prog->reganch & ROPT_CANY_SEEN) {
+ if (prog->extflags & RXf_CANY_SEEN) {
start_point= (U8*)(s + srch_start_shift);
end_point= (U8*)(strend - srch_end_shift);
} else {
if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
&& (strpos != strbeg) && strpos[-1] != '\n'
/* May be due to an implicit anchor of m{.*foo} */
- && !(prog->reganch & ROPT_IMPLICIT))
+ && !(prog->intflags & PREGf_IMPLICIT))
{
t = strpos;
goto find_anchor;
}
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]);
+ (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
);
success_at_start:
- if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
+ if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
&& (do_utf8 ? (
prog->check_utf8 /* Could be deleted already */
&& --BmUSEFUL(prog->check_utf8) < 0
/* XXXX This is a remnant of the old implementation. It
looks wasteful, since now INTUIT can use many
other heuristics. */
- prog->reganch &= ~RE_USE_INTUIT;
+ prog->extflags &= ~RXf_USE_INTUIT;
}
else
s = strpos;
/* 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) {
+ if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
/* minlen == 0 is possible if regstclass is \b or \B,
and the fixed substr is ''$.
Since minlen is already taken into account, s+1 is before strend;
regstclass does not come from lookahead... */
/* If regstclass takes bytelength more than 1: If charlength==1, OK.
This leaves EXACTF only, which is dealt with in find_byclass(). */
- const U8* const str = (U8*)STRING(prog->regstclass);
- const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
- ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
+ const U8* const str = (U8*)STRING(progi->regstclass);
+ const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
+ ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
: 1);
char * endpos;
if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
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));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
+ (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
t = s;
- s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
+ s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
if (!s) {
#ifdef DEBUGGING
const char *what = NULL;
}
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
"This position contradicts STCLASS...\n") );
- if ((prog->reganch & ROPT_ANCH) && !ml_anch)
+ if ((prog->extflags & RXf_ANCH) && !ml_anch)
goto fail;
/* Contradict one of substrings */
if (prog->anchored_substr || prog->anchored_utf8) {
-#define REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len, uvc, charid, \
-foldlen, foldbuf, uniflags) STMT_START { \
+#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
+uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
switch (trie_type) { \
case trie_utf8_fold: \
if ( foldlen>0 ) { \
} \
else { \
charid = 0; \
- if (trie->widecharmap) { \
- SV** const svpp = hv_fetch(trie->widecharmap, \
+ if (widecharmap) { \
+ SV** const svpp = hv_fetch(widecharmap, \
(char*)&uvc, sizeof(UV), 0); \
if (svpp) \
charid = (U16)SvIV(*svpp); \
const char *strend, regmatch_info *reginfo)
{
dVAR;
- const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
+ const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
char *m;
STRLEN ln;
STRLEN lnc;
char *e;
register I32 tmp = 1; /* Scratch variable? */
register const bool do_utf8 = PL_reg_match_utf8;
-
+ RXi_GET_DECL(prog,progi);
+
/* We know what class it must start with. */
switch (OP(c)) {
case ANYOF:
: trie_plain;
/* what trie are we using right now */
reg_ac_data *aho
- = (reg_ac_data*)prog->data->data[ ARG( c ) ];
- reg_trie_data *trie=aho->trie;
+ = (reg_ac_data*)progi->data->data[ ARG( c ) ];
+ reg_trie_data *trie
+ = (reg_trie_data*)progi->data->data[ aho->trie ];
+ HV *widecharmap = (HV*) progi->data->data[ aho->trie + 1 ];
const char *last_start = strend - trie->minlen;
#ifdef DEBUGGING
}
points[pointpos++ % maxlen]= uc;
- REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
- uvc, charid, foldlen, foldbuf, uniflags);
+ REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
+ uscan, len, uvc, charid, foldlen,
+ foldbuf, uniflags);
DEBUG_TRIE_EXECUTE_r({
dump_exec_pos( (char *)uc, c, strend, real_start,
s, do_utf8 );
s = (char*)leftmost;
DEBUG_TRIE_EXECUTE_r({
PerlIO_printf(
- Perl_debug_log,"Matches word #%"UVxf" at position %d. Trying full pattern...\n",
- (UV)accepted_word, s - real_start
+ Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
+ (UV)accepted_word, (IV)(s - real_start)
);
});
if (!reginfo || regtry(reginfo, &s)) {
return s;
}
+static void
+S_swap_match_buff (pTHX_ regexp *prog) {
+ I32 *t;
+
+ if (!prog->swap) {
+ /* We have to be careful. If the previous successful match
+ was from this regex we don't want a subsequent paritally
+ successful match to clobber the old results.
+ So when we detect this possibility we add a swap buffer
+ to the re, and switch the buffer each match. If we fail
+ we switch it back, otherwise we leave it swapped.
+ */
+ Newxz(prog->swap, 1, regexp_paren_ofs);
+ /* no need to copy these */
+ Newxz(prog->swap->startp, 2 * (prog->nparens + 1), I32);
+ prog->swap->endp = prog->swap->startp + prog->nparens + 1;
+ }
+ t = prog->swap->startp;
+ prog->swap->startp = prog->startp;
+ prog->startp = t;
+ t = prog->swap->endp;
+ prog->swap->endp = prog->endp;
+ prog->endp = t;
+}
+
+
/*
- regexec_flags - match a regexp against a string
*/
/* strend: pointer to null at end of string */
/* strbeg: real beginning of string */
/* minend: end of match must be >=minend after stringarg. */
-/* data: May be used for some additional optimizations. */
+/* data: May be used for some additional optimizations.
+ Currently its only used, with a U32 cast, for transmitting
+ the ganch offset when doing a /g match. This will change */
/* nosave: For optimizations. */
{
dVAR;
SV* const oreplsv = GvSV(PL_replgv);
const bool do_utf8 = (bool)DO_UTF8(sv);
I32 multiline;
-
+ RXi_GET_DECL(prog,progi);
regmatch_info reginfo; /* create some info to pass to regtry etc */
+ bool swap_on_fail = 0;
GET_RE_DEBUG_FLAGS_DECL;
return 0;
}
- multiline = prog->reganch & PMf_MULTILINE;
+ multiline = prog->extflags & RXf_PMf_MULTILINE;
reginfo.prog = prog;
RX_MATCH_UTF8_set(prog, do_utf8);
/* Check validity of program. */
- if (UCHARAT(prog->program) != REG_MAGIC) {
+ if (UCHARAT(progi->program) != REG_MAGIC) {
Perl_croak(aTHX_ "corrupted regexp program");
}
PL_reg_eval_set = 0;
PL_reg_maxiter = 0;
- if (prog->reganch & ROPT_UTF8)
+ if (prog->extflags & RXf_UTF8)
PL_reg_flags |= RF_utf8;
/* Mark beginning of line for ^ and lookbehind. */
/* If there is a "must appear" string, look for it. */
s = startpos;
- if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
+ if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
MAGIC *mg;
if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
- reginfo.ganch = startpos;
+ reginfo.ganch = startpos + prog->gofs;
else if (sv && SvTYPE(sv) >= SVt_PVMG
&& SvMAGIC(sv)
&& (mg = mg_find(sv, PERL_MAGIC_regex_global))
&& mg->mg_len >= 0) {
reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
- if (prog->reganch & ROPT_ANCH_GPOS) {
+ if (prog->extflags & RXf_ANCH_GPOS) {
if (s > reginfo.ganch)
goto phooey;
- s = reginfo.ganch;
+ s = reginfo.ganch - prog->gofs;
}
}
- else /* pos() not defined */
+ else if (data) {
+ reginfo.ganch = strbeg + PTR2UV(data);
+ } else /* pos() not defined */
reginfo.ganch = strbeg;
}
if (PL_curpm && (PM_GETRE(PL_curpm) == prog)) {
- I32 *t;
- if (!prog->swap) {
- /* We have to be careful. If the previous successful match
- was from this regex we don't want a subsequent paritally
- successful match to clobber the old results.
- So when we detect this possibility we add a swap buffer
- to the re, and switch the buffer each match. If we fail
- we switch it back, otherwise we leave it swapped.
- */
- Newxz(prog->swap, 1, regexp_paren_ofs);
- /* no need to copy these */
- Newxz(prog->swap->startp, prog->nparens + 1, I32);
- Newxz(prog->swap->endp, prog->nparens + 1, I32);
- }
- t = prog->swap->startp;
- prog->swap->startp = prog->startp;
- prog->startp = t;
- t = prog->swap->endp;
- prog->swap->endp = prog->endp;
- prog->endp = t;
+ swap_on_fail = 1;
+ swap_match_buff(prog); /* do we need a save destructor here for
+ eval dies? */
}
if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
re_scream_pos_data d;
/* Simplest case: anchored match need be tried only once. */
/* [unless only anchor is BOL and multiline is set] */
- if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
+ if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
if (s == startpos && regtry(®info, &startpos))
goto got_it;
- else if (multiline || (prog->reganch & ROPT_IMPLICIT)
- || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
+ else if (multiline || (prog->intflags & PREGf_IMPLICIT)
+ || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
{
char *end;
after_try:
if (s >= end)
goto phooey;
- if (prog->reganch & RE_USE_INTUIT) {
+ if (prog->extflags & RXf_USE_INTUIT) {
s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
if (!s)
goto phooey;
}
}
goto phooey;
- } else if (ROPT_GPOS_CHECK == (prog->reganch & ROPT_GPOS_CHECK))
+ } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
{
/* the warning about reginfo.ganch being used without intialization
- is bogus -- we set it above, when prog->reganch & ROPT_GPOS_SEEN
+ is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
and we only enter this block when the same bit is set. */
- if (regtry(®info, ®info.ganch))
+ char *tmp_s = reginfo.ganch - prog->gofs;
+ if (regtry(®info, &tmp_s))
goto got_it;
goto phooey;
}
/* Messy cases: unanchored match. */
- if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
+ if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
/* we have /x+whatever/ */
/* it must be a one character string (XXXX Except UTF?) */
char ch;
});
goto phooey;
}
- else if ( (c = prog->regstclass) ) {
+ else if ( (c = progi->regstclass) ) {
if (minlen) {
- const OPCODE op = OP(prog->regstclass);
+ const OPCODE op = OP(progi->regstclass);
/* don't bother with what can't match */
if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
strend = HOPc(strend, -(minlen - 1));
SV * const prop = sv_newmortal();
regprop(prog, prop, c);
{
- RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
+ RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
s,strend-s,60);
PerlIO_printf(Perl_debug_log,
"Matching stclass %.*s against %s (%d chars)\n",
PL_colors[4], PL_colors[5]));
if (PL_reg_eval_set)
restore_pos(aTHX_ prog);
- if (prog->swap) {
+ if (swap_on_fail)
/* we failed :-( roll it back */
- I32 *t;
- t = prog->swap->startp;
- prog->swap->startp = prog->startp;
- prog->startp = t;
- t = prog->swap->endp;
- prog->swap->endp = prog->endp;
- prog->endp = t;
- }
+ swap_match_buff(prog);
+
return 0;
}
S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
{
dVAR;
- register I32 *sp;
- register I32 *ep;
CHECKPOINT lastcp;
regexp *prog = reginfo->prog;
+ RXi_GET_DECL(prog,progi);
GET_RE_DEBUG_FLAGS_DECL;
reginfo->cutpoint=NULL;
- if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
+ if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
MAGIC *mg;
PL_reg_eval_set = RS_init;
* on those tests seems to be returning null fields from matches.
* --jhi */
#if 1
- sp = PL_regstartp;
- ep = PL_regendp;
if (prog->nparens) {
+ I32 *sp = PL_regstartp;
+ I32 *ep = PL_regendp;
register I32 i;
for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
*++sp = -1;
}
#endif
REGCP_SET(lastcp);
- if (regmatch(reginfo, prog->program + 1)) {
+ if (regmatch(reginfo, progi->program + 1)) {
PL_regendp[0] = PL_reginput - PL_bostr;
return 1;
}
STATIC regmatch_state *
S_push_slab(pTHX)
{
-#if PERL_VERSION < 9
+#if PERL_VERSION < 9 && !defined(PERL_CORE)
dMY_CXT;
#endif
regmatch_slab *s = PL_regmatch_slab->next;
PerlIO_printf(Perl_debug_log, \
" %*s"pp" %s%s%s%s%s\n", \
depth*2, "", \
- reg_name[st->resume_state], \
+ PL_reg_name[st->resume_state], \
((st==yes_state||st==mark_state) ? "[" : ""), \
((st==yes_state) ? "Y" : ""), \
((st==mark_state) ? "M" : ""), \
S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
const char *start, const char *end, const char *blurb)
{
- const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
+ const bool utf8_pat= prog->extflags & RXf_UTF8 ? 1 : 0;
if (!PL_colorset)
reginitcolors();
{
STATIC I32
S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
I32 n;
- SV *sv_dat=(SV*)rex->data->data[ ARG( scan ) ];
+ RXi_GET_DECL(rex,rexi);
+ SV *sv_dat=(SV*)rexi->data->data[ ARG( scan ) ];
I32 *nums=(I32*)SvPVX(sv_dat);
for ( n=0; n<SvIVX(sv_dat); n++ ) {
if ((I32)*PL_reglastparen >= nums[n] &&
return 0;
}
+#define SETREX(Re1,Re2) \
+ if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
+ Re1 = (Re2)
+
STATIC I32 /* 0 failure, 1 success */
S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
{
-#if PERL_VERSION < 9
+#if PERL_VERSION < 9 && !defined(PERL_CORE)
dMY_CXT;
#endif
dVAR;
const U32 uniflags = UTF8_ALLOW_DEFAULT;
regexp *rex = reginfo->prog;
-
+ RXi_GET_DECL(rex,rexi);
+
regmatch_slab *orig_slab;
regmatch_state *orig_state;
bool result = 0; /* return value of S_regmatch */
int depth = 0; /* depth of backtrack stack */
- int nochange_depth = 0; /* depth of GOSUB recursion with nochange*/
+ U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
+ const U32 max_nochange_depth =
+ (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
+ 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
+
regmatch_state *yes_state = NULL; /* state to pop to on success of
subpattern */
/* mark_state piggy backs on the yes_state logic so that when we unwind
during a successfull match */
U32 lastopen = 0; /* last open we saw */
bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 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
GET_RE_DEBUG_FLAGS_DECL;
#endif
- DEBUG_STACK_r( {
+ DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
PerlIO_printf(Perl_debug_log,"regmatch start\n");
- });
+ }));
/* on first ever call to regmatch, allocate first slab */
if (!PL_regmatch_slab) {
Newx(PL_regmatch_slab, 1, regmatch_slab);
PerlIO_printf(Perl_debug_log,
"%3"IVdf":%*s%s(%"IVdf")\n",
- (IV)(scan - rex->program), depth*2, "",
+ (IV)(scan - rexi->program), depth*2, "",
SvPVX_const(prop),
(PL_regkind[OP(scan)] == END || !rnext) ?
- 0 : (IV)(rnext - rex->program));
+ 0 : (IV)(rnext - rexi->program));
});
next = scan + NEXT_OFF(scan);
if (locinput == reginfo->ganch)
break;
sayNO;
+
+ case KEEPS:
+ /* update the startpoint */
+ st->u.keeper.val = PL_regstartp[0];
+ PL_reginput = locinput;
+ PL_regstartp[0] = locinput - PL_bostr;
+ PUSH_STATE_GOTO(KEEPS_next, next);
+ /*NOT-REACHED*/
+ case KEEPS_next_fail:
+ /* rollback the start point change */
+ PL_regstartp[0] = st->u.keeper.val;
+ sayNO_SILENT;
+ /*NOT-REACHED*/
case EOL:
goto seol;
case MEOL:
/* what trie are we using right now */
reg_trie_data * const trie
- = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
+ = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
+ HV * widecharmap = (HV *)rexi->data->data[ ARG( scan ) + 1 ];
U32 state = trie->startstate;
if (trie->bitmap && trie_type != trie_utf8_fold &&
ST.B = next;
ST.jump = trie->jump;
ST.me = scan;
-
/*
traverse the TRIE keeping track of all accepting states
we transition through until we get to a failing node.
});
if ( base ) {
- REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
- uvc, charid, foldlen, foldbuf, uniflags);
+ REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
+ uscan, len, uvc, charid, foldlen,
+ foldbuf, uniflags);
if (charid &&
(base + charid > trie->uniquecharcount )
PL_colors[4], (IV)ST.accepted, PL_colors[5] );
);
}}
-
- /* FALL THROUGH */
+ goto trie_first_try; /* jump into the fail handler */
+ /* NOTREACHED */
case TRIE_next_fail: /* we failed - try next alterative */
+ if ( ST.jump) {
+ REGCP_UNWIND(ST.cp);
+ for (n = *PL_reglastparen; n > ST.lastparen; n--)
+ PL_regendp[n] = -1;
+ *PL_reglastparen = n;
+ }
+ trie_first_try:
if (do_cutgroup) {
do_cutgroup = 0;
no_final = 0;
}
+
+ if ( ST.jump) {
+ ST.lastparen = *PL_reglastparen;
+ REGCP_SET(ST.cp);
+ }
if ( ST.accepted == 1 ) {
/* only one choice left - just continue */
DEBUG_EXECUTE_r({
- reg_trie_data * const trie
- = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
- SV ** const tmp = av_fetch( trie->words,
+ AV *const trie_words
+ = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
+ SV ** const tmp = av_fetch( trie_words,
ST.accept_buff[ 0 ].wordnum-1, 0 );
SV *sv= tmp ? sv_newmortal() : NULL;
continue; /* execute rest of RE */
}
-
- if (!ST.accepted-- ) {
+
+ if ( !ST.accepted-- ) {
DEBUG_EXECUTE_r({
PerlIO_printf( Perl_debug_log,
"%*s %sTRIE failed...%s\n",
FREETMPS;
LEAVE;
sayNO_SILENT;
- }
+ /*NOTREACHED*/
+ }
/*
There are at least two accepting states left. Presumably
}
DEBUG_EXECUTE_r({
- reg_trie_data * const trie
- = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
- SV ** const tmp = av_fetch( trie->words,
+ AV *const trie_words
+ = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
+ SV ** const tmp = av_fetch( trie_words,
ST.accept_buff[ best ].wordnum - 1, 0 );
regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
ST.B :
{
SV *ret;
regexp *re;
+ regexp_internal *rei;
regnode *startpoint;
case GOSTART:
- case GOSUB: /* /(...(?1))/ */
- if (cur_eval && cur_eval->locinput==locinput) {
+ case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
+ if (cur_eval && cur_eval->locinput==locinput) {
if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
Perl_croak(aTHX_ "Infinite recursion in regex");
- if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
+ if ( ++nochange_depth > max_nochange_depth )
Perl_croak(aTHX_
"Pattern subroutine nesting without pos change"
" exceeded limit in regex");
nochange_depth = 0;
}
re = rex;
+ rei = rexi;
(void)ReREFCNT_inc(rex);
if (OP(scan)==GOSUB) {
startpoint = scan + ARG2L(scan);
ST.close_paren = ARG(scan);
} else {
- startpoint = re->program+1;
+ startpoint = rei->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 )
+ if ( ++nochange_depth > max_nochange_depth )
Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
} else {
nochange_depth = 0;
PAD *old_comppad;
n = ARG(scan);
- PL_op = (OP_4tree*)rex->data->data[n];
+ PL_op = (OP_4tree*)rexi->data->data[n];
DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
" re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
- PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
+ PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
+ if (sv_yes_mark) {
+ SV *sv_mrk = get_sv("REGMARK", 1);
+ sv_setsv(sv_mrk, sv_yes_mark);
+ }
+
CALLRUNOPS(aTHX); /* Scalar context. */
SPAGAIN;
if (SP == before)
}
if (mg) {
- re = (regexp *)mg->mg_obj;
- (void)ReREFCNT_inc(re);
+ re = reg_temp_copy((regexp *)mg->mg_obj); /*XXX:dmq*/
}
else {
STRLEN len;
PL_regsize = osize;
}
}
+ RX_MATCH_COPIED_off(re);
+ re->subbeg = rex->subbeg;
+ re->sublen = rex->sublen;
+ rei = RXi_GET(re);
DEBUG_EXECUTE_r(
debug_start_match(re, do_utf8, locinput, PL_regeol,
"Matching embedded");
);
- startpoint = re->program + 1;
+ startpoint = rei->program + 1;
ST.close_paren = 0; /* only used for GOSUB */
/* borrowed from regtry */
if (PL_reg_start_tmpl <= re->nparens) {
PL_reg_maxiter = 0;
ST.toggle_reg_flags = PL_reg_flags;
- if (re->reganch & ROPT_UTF8)
+ if (re->extflags & RXf_UTF8)
PL_reg_flags |= RF_utf8;
else
PL_reg_flags &= ~RF_utf8;
ST.prev_rex = rex;
ST.prev_curlyx = cur_curlyx;
- rex = re;
+ SETREX(rex,re);
+ rexi = rei;
cur_curlyx = NULL;
ST.B = next;
ST.prev_eval = cur_eval;
/* 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;
+ SETREX(rex,ST.prev_rex);
+ rexi = RXi_GET(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;
+ if ( nochange_depth )
+ nochange_depth--;
sayYES;
/* 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;
+ SETREX(rex,ST.prev_rex);
+ rexi = RXi_GET(rex);
PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
regcppop(rex);
cur_curlyx = ST.prev_curlyx;
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
+ if ( nochange_depth )
+ nochange_depth--;
sayNO_SILENT;
#undef ST
case CUTGROUP:
PL_reginput = locinput;
sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
- (SV*)rex->data->data[ ARG( scan ) ];
+ (SV*)rexi->data->data[ ARG( scan ) ];
PUSH_STATE_GOTO(CUTGROUP_next,next);
/* NOTREACHED */
case CUTGROUP_next_fail:
regnode *text_node = ST.B;
if (! HAS_TEXT(text_node))
FIND_NEXT_IMPT(text_node);
- if (HAS_TEXT(text_node)
- && PL_regkind[OP(text_node)] != REF)
+ /* this used to be
+
+ (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
+
+ But the former is redundant in light of the latter.
+
+ if this changes back then the macro for
+ IS_TEXT and friends need to change.
+ */
+ if (PL_regkind[OP(text_node)] == EXACT)
{
+
ST.c1 = (U8)*STRING(text_node);
ST.c2 =
- (OP(text_node) == EXACTF || OP(text_node) == REFF)
+ (IS_TEXTF(text_node))
? PL_fold[ST.c1]
- : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
+ : (IS_TEXTFL(text_node))
? PL_fold_locale[ST.c1]
: ST.c1;
}
&& UCHARAT(PL_reginput) != ST.c2)
{
/* simulate B failing */
+ DEBUG_OPTIMISE_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
+ (int)(REPORT_CODE_OFF+(depth*2)),"",
+ (IV)ST.c1,(IV)ST.c2
+ ));
state_num = CURLYM_B_fail;
goto reenter_switch;
}
if (! HAS_TEXT(text_node))
ST.c1 = ST.c2 = CHRTEST_VOID;
else {
- if (PL_regkind[OP(text_node)] == REF) {
+ if ( PL_regkind[OP(text_node)] != EXACT ) {
ST.c1 = ST.c2 = CHRTEST_VOID;
goto assume_ok_easy;
}
else
s = (U8*)STRING(text_node);
-
+
+ /* Currently we only get here when
+
+ PL_rekind[OP(text_node)] == EXACT
+
+ if this changes back then the macro for IS_TEXT and
+ friends need to change. */
if (!UTF) {
ST.c2 = ST.c1 = *s;
- if (OP(text_node) == EXACTF || OP(text_node) == REFF)
+ if (IS_TEXTF(text_node))
ST.c2 = PL_fold[ST.c1];
- else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
+ else if (IS_TEXTFL(text_node))
ST.c2 = PL_fold_locale[ST.c1];
}
else { /* UTF */
- if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
+ if (IS_TEXTF(text_node)) {
STRLEN ulen1, ulen2;
U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
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 */
+ SETREX(rex,cur_eval->u.eval.prev_rex);
+ rexi = RXi_GET(rex);
cur_curlyx = cur_eval->u.eval.prev_curlyx;
ReREFCNT_inc(rex);
st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
DEBUG_EXECUTE_r(
PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
- PUSH_YES_STATE_GOTO(EVAL_AB,
+ if ( nochange_depth )
+ nochange_depth--;
+
+ PUSH_YES_STATE_GOTO(EVAL_AB,
st->u.eval.prev_eval->u.eval.B); /* match B */
}
(long)(locinput - PL_reg_starttry),
(long)(reginfo->till - PL_reg_starttry),
PL_colors[5]));
+
sayNO_SILENT; /* Cannot match: too short. */
}
PL_reginput = locinput; /* put where regtry can find it */
case PRUNE:
PL_reginput = locinput;
if (!scan->flags)
- sv_yes_mark = sv_commit = (SV*)rex->data->data[ ARG( scan ) ];
+ sv_yes_mark = sv_commit = (SV*)rexi->data->data[ ARG( scan ) ];
PUSH_STATE_GOTO(COMMIT_next,next);
/* NOTREACHED */
case COMMIT_next_fail:
case MARKPOINT:
ST.prev_mark = mark_state;
ST.mark_name = sv_commit = sv_yes_mark
- = (SV*)rex->data->data[ ARG( scan ) ];
+ = (SV*)rexi->data->data[ ARG( scan ) ];
mark_state = st;
ST.mark_loc = PL_reginput = locinput;
PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
PerlIO_printf(Perl_debug_log,
"%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
REPORT_CODE_OFF+depth*2, "",
- PL_colors[4], sv_commit, PL_colors[5]);
+ PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
});
}
mark_state = ST.prev_mark;
case SKIP:
PL_reginput = locinput;
if (scan->flags) {
- /* (*CUT) : if we fail we cut here*/
+ /* (*SKIP) : if we fail we cut here*/
ST.mark_name = NULL;
ST.mark_loc = locinput;
PUSH_STATE_GOTO(SKIP_next,next);
} else {
- /* (*CUT:NAME) : if there is a (*MARK:NAME) fail where it was,
+ /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
otherwise do nothing. Meaning we need to scan
*/
regmatch_state *cur = mark_state;
- SV *find = (SV*)rex->data->data[ ARG( scan ) ];
+ SV *find = (SV*)rexi->data->data[ ARG( scan ) ];
while (cur) {
if ( sv_eq( cur->u.mark.mark_name,
cur = cur->u.mark.prev_mark;
}
}
- /* Didn't find our (*MARK:NAME) so ignore this (*CUT:NAME) */
+ /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
break;
case SKIP_next_fail:
if (ST.mark_name) {
}
PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
REPORT_CODE_OFF + 2 + depth * 2,"",
- curd, reg_name[cur->resume_state],
+ curd, PL_reg_name[cur->resume_state],
(curyes == cur) ? "yes" : ""
);
if (curyes == cur)
result = 0;
final_exit:
- if (rex->reganch & ROPT_VERBARG_SEEN) {
+ if (rex->intflags & PREGf_VERBARG_SEEN) {
SV *sv_err = get_sv("REGERROR", 1);
SV *sv_mrk = get_sv("REGMARK", 1);
if (result) {
register char *loceol = PL_regeol;
register I32 hardcount = 0;
register bool do_utf8 = PL_reg_match_utf8;
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(depth);
+#endif
scan = PL_reginput;
if (max == REG_INFTY)
SV *sw = NULL;
SV *si = NULL;
SV *alt = NULL;
- const struct reg_data * const data = prog ? prog->data : NULL;
+ RXi_GET_DECL(prog,progi);
+ const struct reg_data * const data = prog ? progi->data : NULL;
if (data && data->count) {
const U32 n = ARG(node);
STATIC void
S_to_utf8_substr(pTHX_ register regexp *prog)
{
- if (prog->float_substr && !prog->float_utf8) {
- SV* const sv = newSVsv(prog->float_substr);
- prog->float_utf8 = sv;
- sv_utf8_upgrade(sv);
- if (SvTAIL(prog->float_substr))
- SvTAIL_on(sv);
- if (prog->float_substr == prog->check_substr)
- prog->check_utf8 = sv;
- }
- if (prog->anchored_substr && !prog->anchored_utf8) {
- SV* const sv = newSVsv(prog->anchored_substr);
- prog->anchored_utf8 = sv;
- sv_utf8_upgrade(sv);
- if (SvTAIL(prog->anchored_substr))
- SvTAIL_on(sv);
- if (prog->anchored_substr == prog->check_substr)
- prog->check_utf8 = sv;
- }
+ int i = 1;
+ do {
+ if (prog->substrs->data[i].substr
+ && !prog->substrs->data[i].utf8_substr) {
+ SV* const sv = newSVsv(prog->substrs->data[i].substr);
+ prog->substrs->data[i].utf8_substr = sv;
+ sv_utf8_upgrade(sv);
+ if (SvVALID(prog->substrs->data[i].substr)) {
+ const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
+ if (flags & FBMcf_TAIL) {
+ /* Trim the trailing \n that fbm_compile added last
+ time. */
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ /* Whilst this makes the SV technically "invalid" (as its
+ buffer is no longer followed by "\0") when fbm_compile()
+ adds the "\n" back, a "\0" is restored. */
+ }
+ fbm_compile(sv, flags);
+ }
+ if (prog->substrs->data[i].substr == prog->check_substr)
+ prog->check_utf8 = sv;
+ }
+ } while (i--);
}
STATIC void
S_to_byte_substr(pTHX_ register regexp *prog)
{
dVAR;
- if (prog->float_utf8 && !prog->float_substr) {
- SV* sv = newSVsv(prog->float_utf8);
- prog->float_substr = sv;
- if (sv_utf8_downgrade(sv, TRUE)) {
- if (SvTAIL(prog->float_utf8))
- SvTAIL_on(sv);
- } else {
- SvREFCNT_dec(sv);
- prog->float_substr = sv = &PL_sv_undef;
- }
- if (prog->float_utf8 == prog->check_utf8)
- prog->check_substr = sv;
- }
- if (prog->anchored_utf8 && !prog->anchored_substr) {
- SV* sv = newSVsv(prog->anchored_utf8);
- prog->anchored_substr = sv;
- if (sv_utf8_downgrade(sv, TRUE)) {
- if (SvTAIL(prog->anchored_utf8))
- SvTAIL_on(sv);
- } else {
- SvREFCNT_dec(sv);
- prog->anchored_substr = sv = &PL_sv_undef;
+ int i = 1;
+ do {
+ if (prog->substrs->data[i].utf8_substr
+ && !prog->substrs->data[i].substr) {
+ SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
+ if (sv_utf8_downgrade(sv, TRUE)) {
+ if (SvVALID(prog->substrs->data[i].utf8_substr)) {
+ const U8 flags
+ = BmFLAGS(prog->substrs->data[i].utf8_substr);
+ if (flags & FBMcf_TAIL) {
+ /* Trim the trailing \n that fbm_compile added last
+ time. */
+ SvCUR_set(sv, SvCUR(sv) - 1);
+ }
+ fbm_compile(sv, flags);
+ }
+ } else {
+ SvREFCNT_dec(sv);
+ sv = &PL_sv_undef;
+ }
+ prog->substrs->data[i].substr = sv;
+ if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
+ prog->check_substr = sv;
}
- if (prog->anchored_utf8 == prog->check_utf8)
- prog->check_substr = sv;
- }
+ } while (i--);
}
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff