#define PERL_IN_REGEXEC_C
#include "perl.h"
-#ifdef PERL_IN_XSUB_RE
-# if defined(PERL_CAPI) || defined(PERL_OBJECT)
-# include "XSUB.h"
-# endif
-#endif
-
#include "regcomp.h"
#define RF_tainted 1 /* tainted information used? */
*/
#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
-#define CHR_DIST(a,b) (DO_UTF8(PL_reg_sv) ? utf8_distance(a,b) : a - b)
+#define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
#define reghop_c(pos,off) ((char*)reghop((U8*)pos, off))
#define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off))
-#define HOP(pos,off) (DO_UTF8(PL_reg_sv) ? reghop((U8*)pos, off) : (U8*)(pos + off))
-#define HOPMAYBE(pos,off) (DO_UTF8(PL_reg_sv) ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
+#define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off))
+#define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
#define HOPc(pos,off) ((char*)HOP(pos,off))
#define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
#define HOPBACK(pos, off) ( \
- (UTF && DO_UTF8(PL_reg_sv)) \
+ (UTF && PL_reg_match_utf8) \
? reghopmaybe((U8*)pos, -off) \
: (pos - off >= PL_bostr) \
? (U8*)(pos - off) \
#define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
-#define HOP3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
-#define HOPMAYBE3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
+#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
+#define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
#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)) (void)CAT2(is_utf8_, a)((U8*)b); } STMT_END
-static void restore_pos(pTHXo_ void *arg);
+/* for use after a quantifier and before an EXACT-like node -- japhy */
+#define JUMPABLE(rn) ( \
+ OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
+ OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
+ OP(rn) == PLUS || OP(rn) == MINMOD || \
+ (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
+)
+
+#define HAS_TEXT(rn) ( \
+ PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
+)
+
+#define FIND_NEXT_IMPT(rn) STMT_START { \
+ while (JUMPABLE(rn)) \
+ if (OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
+ PL_regkind[(U8)OP(rn)] == CURLY) \
+ rn = NEXTOPER(NEXTOPER(rn)); \
+ else if (OP(rn) == PLUS) \
+ rn = NEXTOPER(rn); \
+ else rn += NEXT_OFF(rn); \
+} STMT_END
+
+static void restore_pos(pTHX_ void *arg);
STATIC CHECKPOINT
S_regcppush(pTHX_ I32 parenfloor)
if (paren_elems_to_push < 0)
Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
-#define REGCP_OTHER_ELEMS 5
+#define REGCP_OTHER_ELEMS 6
SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS);
for (p = PL_regsize; p > parenfloor; p--) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
SSPUSHINT(PL_regsize);
SSPUSHINT(*PL_reglastparen);
+ SSPUSHINT(*PL_reglastcloseparen);
SSPUSHPTR(PL_reginput);
#define REGCP_FRAME_ELEMS 2
/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
i = SSPOPINT; /* Parentheses elements to pop. */
input = (char *) SSPOPPTR;
+ *PL_reglastcloseparen = SSPOPINT;
*PL_reglastparen = SSPOPINT;
PL_regsize = SSPOPINT;
Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
char *strend, U32 flags, re_scream_pos_data *data)
{
- register I32 start_shift;
+ register I32 start_shift = 0;
/* Should be nonnegative! */
- register I32 end_shift;
+ register I32 end_shift = 0;
register char *s;
register SV *check;
char *strbeg;
char *t;
I32 ml_anch;
- char *tmp;
register char *other_last = Nullch; /* other substr checked before this */
- char *check_at; /* check substr found at this pos */
+ char *check_at = Nullch; /* check substr found at this pos */
#ifdef DEBUGGING
char *i_strpos = strpos;
+ SV *dsv = PERL_DEBUG_PAD_ZERO(0);
#endif
- DEBUG_r( if (!PL_colorset) reginitcolors() );
- DEBUG_r(PerlIO_printf(Perl_debug_log,
- "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- prog->precomp,
- PL_colors[1],
- (strlen(prog->precomp) > 60 ? "..." : ""),
- PL_colors[0],
- (int)(strend - strpos > 60 ? 60 : strend - strpos),
- strpos, PL_colors[1],
- (strend - strpos > 60 ? "..." : ""))
- );
+ DEBUG_r({
+ char*s = UTF ? sv_uni_display(dsv, sv, 60, 0) : strpos;
+ int len = UTF ? strlen(s) : strend - strpos;
+ if (!PL_colorset)
+ reginitcolors();
+ PerlIO_printf(Perl_debug_log,
+ "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
+ PL_colors[4],PL_colors[5],PL_colors[0],
+ prog->precomp,
+ PL_colors[1],
+ (strlen(prog->precomp) > 60 ? "..." : ""),
+ PL_colors[0],
+ (int)(len > 60 ? 60 : len),
+ s, PL_colors[1],
+ (len > 60 ? "..." : "")
+ );
+ });
if (prog->reganch & ROPT_UTF8)
PL_reg_flags |= RF_utf8;
if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "String too short... [re_intuit_start]\n"));
goto fail;
}
strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
goto fail;
}
if (prog->check_offset_min == prog->check_offset_max &&
- !(prog->reganch & ROPT_SANY_SEEN)) {
+ !(prog->reganch & ROPT_CANY_SEEN)) {
/* Substring at constant offset from beg-of-str... */
I32 slen;
if (data)
*data->scream_olds = s;
}
- else if (prog->reganch & ROPT_SANY_SEEN)
+ else if (prog->reganch & ROPT_CANY_SEEN)
s = fbm_instr((U8*)(s + start_shift),
(U8*)(strend - end_shift),
check, PL_multiline ? FBMrf_MULTILINE : 0);
PL_regdata = prog->data;
PL_bostr = startpos;
}
- s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
+ s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
#ifdef DEBUGGING
- char *what;
+ char *what = 0;
#endif
if (endpos == strend) {
DEBUG_r( PerlIO_printf(Perl_debug_log,
DEBUG_r( what = "floating" );
goto hop_and_restart;
}
- DEBUG_r( if (t != s)
- PerlIO_printf(Perl_debug_log,
+ if (t != s) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
"By STCLASS: moving %ld --> %ld\n",
- (long)(t - i_strpos), (long)(s - i_strpos));
- else
- PerlIO_printf(Perl_debug_log,
- "Does not contradict STCLASS...\n") );
+ (long)(t - i_strpos), (long)(s - i_strpos))
+ );
+ }
+ else {
+ DEBUG_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",
unsigned int c2;
char *e;
register I32 tmp = 1; /* Scratch variable? */
- register bool do_utf8 = DO_UTF8(PL_reg_sv);
+ register bool do_utf8 = PL_reg_match_utf8;
/* We know what class it must start with. */
switch (OP(c)) {
s += do_utf8 ? UTF8SKIP(s) : 1;
}
break;
+ case CANY:
+ while (s < strend) {
+ if (tmp && (norun || regtry(prog, s)))
+ goto got_it;
+ else
+ tmp = doevery;
+ s++;
+ }
+ break;
case EXACTF:
m = STRING(c);
ln = STR_LEN(c);
if (UTF) {
- c1 = to_utf8_lower((U8*)m);
- c2 = to_utf8_upper((U8*)m);
+ STRLEN ulen1, ulen2;
+ U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
+
+ to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
+ to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
+
+ c1 = utf8_to_uvuni(tmpbuf1, 0);
+ c2 = utf8_to_uvuni(tmpbuf2, 0);
}
else {
c1 = *(U8*)m;
if (do_utf8) {
STRLEN len;
+ /* The ibcmp_utf8() uses to_uni_fold() which is more
+ * correct folding for Unicode than using lowercase.
+ * However, it doesn't work quite fully since the folding
+ * is a one-to-many mapping and the regex optimizer is
+ * unaware of this, so it may throw out good matches.
+ * Fortunately, not getting this right is allowed
+ * for Unicode Regular Expression Support level 1,
+ * only one-to-one matching is required. --jhi */
if (c1 == c2)
while (s <= e) {
if ( utf8_to_uvchr((U8*)s, &len) == c1
- && regtry(prog, s) )
+ && (ln == 1 ||
+ ibcmp_utf8(s, do_utf8, strend - s,
+ m, UTF, ln)) )
goto got_it;
s += len;
}
else
while (s <= e) {
UV c = utf8_to_uvchr((U8*)s, &len);
- if ( (c == c1 || c == c2) && regtry(prog, s) )
+ if ( (c == c1 || c == c2)
+ && (ln == 1 ||
+ ibcmp_utf8(s, do_utf8, strend - s,
+ m, UTF, ln)) )
goto got_it;
s += len;
}
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
- tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
+ if (s > (char*)r)
+ tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == BOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
else {
U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
- tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
+ if (s > (char*)r)
+ tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0);
}
tmp = ((OP(c) == NBOUND ?
isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
char *scream_olds;
SV* oreplsv = GvSV(PL_replgv);
bool do_utf8 = DO_UTF8(sv);
+#ifdef DEBUGGING
+ SV *dsv = PERL_DEBUG_PAD_ZERO(0);
+#endif
PL_regcc = 0;
}
minlen = prog->minlen;
- if (do_utf8) {
- if (!(prog->reganch & ROPT_SANY_SEEN))
- if (utf8_distance((U8*)strend, (U8*)startpos) < minlen) goto phooey;
- }
- else {
- if (strend - startpos < minlen) goto phooey;
+ if (strend - startpos < minlen) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "String too short [regexec_flags]...\n"));
+ goto phooey;
}
/* Check validity of program. */
&& mg->mg_len >= 0) {
PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
if (prog->reganch & ROPT_ANCH_GPOS) {
- if (s > PL_reg_ganch)
+ if (s > PL_reg_ganch)
goto phooey;
s = PL_reg_ganch;
}
d.scream_olds = &scream_olds;
d.scream_pos = &scream_pos;
s = re_intuit_start(prog, sv, s, strend, flags, &d);
- if (!s)
+ if (!s) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
goto phooey; /* not present */
+ }
}
- DEBUG_r( if (!PL_colorset) reginitcolors() );
- DEBUG_r(PerlIO_printf(Perl_debug_log,
- "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- prog->precomp,
- PL_colors[1],
- (strlen(prog->precomp) > 60 ? "..." : ""),
- PL_colors[0],
- (int)(strend - startpos > 60 ? 60 : strend - startpos),
- startpos, PL_colors[1],
- (strend - startpos > 60 ? "..." : ""))
- );
+ DEBUG_r({
+ char *s = do_utf8 ? sv_uni_display(dsv, sv, 60, 0) : startpos;
+ int len = do_utf8 ? strlen(s) : strend - startpos;
+ if (!PL_colorset)
+ reginitcolors();
+ PerlIO_printf(Perl_debug_log,
+ "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
+ PL_colors[4],PL_colors[5],PL_colors[0],
+ prog->precomp,
+ PL_colors[1],
+ (strlen(prog->precomp) > 60 ? "..." : ""),
+ PL_colors[0],
+ (int)(len > 60 ? 60 : len),
+ s, PL_colors[1],
+ (len > 60 ? "..." : "")
+ );
+ });
/* Simplest case: anchored match need be tried only once. */
/* [unless only anchor is BOL and multiline is set] */
s++;
}
}
- DEBUG_r(did_match ||
+ DEBUG_r(if (!did_match)
PerlIO_printf(Perl_debug_log,
- "Did not find anchored character...\n"));
+ "Did not find anchored character...\n")
+ );
}
/*SUPPRESS 560*/
else if (do_utf8 == (UTF!=0) &&
}
}
}
- DEBUG_r(did_match ||
- PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n",
+ DEBUG_r(if (!did_match)
+ PerlIO_printf(Perl_debug_log,
+ "Did not find %s substr `%s%.*s%s'%s...\n",
((must == prog->anchored_substr)
? "anchored" : "floating"),
PL_colors[0],
(int)(SvCUR(must) - (SvTAIL(must)!=0)),
SvPVX(must),
- PL_colors[1], (SvTAIL(must) ? "$" : "")));
+ PL_colors[1], (SvTAIL(must) ? "$" : ""))
+ );
goto phooey;
}
else if ((c = prog->regstclass)) {
DEBUG_r({
SV *prop = sv_newmortal();
regprop(prop, c);
- PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), s);
+ PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), UTF ? sv_uni_display(dsv, sv, 60, 0) : s);
});
if (find_byclass(prog, c, s, strend, startpos, 0))
goto got_it;
sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
restored, the value remains
the same. */
- restore_pos(aTHXo_ 0);
+ restore_pos(aTHX_ 0);
}
/* make sure $`, $&, $', and $digit will work later */
DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
PL_colors[4],PL_colors[5]));
if (PL_reg_eval_set)
- restore_pos(aTHXo_ 0);
+ restore_pos(aTHX_ 0);
return 0;
}
if (PL_reg_sv) {
/* Make $_ available to executed code. */
if (PL_reg_sv != DEFSV) {
- /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+ /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
SAVESPTR(DEFSV);
DEFSV = PL_reg_sv;
}
PL_reg_oldpos = mg->mg_len;
SAVEDESTRUCTOR_X(restore_pos, 0);
}
- if (!PL_reg_curpm)
+ if (!PL_reg_curpm) {
Newz(22,PL_reg_curpm, 1, PMOP);
- PL_reg_curpm->op_pmregexp = prog;
+#ifdef USE_ITHREADS
+ {
+ SV* repointer = newSViv(0);
+ /* so we know which PL_regex_padav element is PL_reg_curpm */
+ SvFLAGS(repointer) |= SVf_BREAK;
+ av_push(PL_regex_padav,repointer);
+ PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
+ PL_regex_pad = AvARRAY(PL_regex_padav);
+ }
+#endif
+ }
+ PM_SETRE(PL_reg_curpm, prog);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RX_MATCH_COPIED(prog)) {
PL_regstartp = prog->startp;
PL_regendp = prog->endp;
PL_reglastparen = &prog->lastparen;
+ PL_reglastcloseparen = &prog->lastcloseparen;
prog->lastparen = 0;
PL_regsize = 0;
DEBUG_r(PL_reg_starttry = startpos);
New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
}
+#ifdef DEBUGGING
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0);
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
+#endif
+
/* XXXX What this code is doing here?!!! There should be no need
to do this again and again, PL_reglastparen should take care of
this! --ilya*/
re_unwind_branch_t branch;
} re_unwind_t;
+#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
+
/*
- regmatch - main matching routine
*
register I32 nextchr; /* renamed nextchr - nextchar colides with
function of same name */
register I32 n; /* no or next */
- register I32 ln; /* len or last */
- register char *s; /* operand or save */
+ register I32 ln = 0; /* len or last */
+ register char *s = Nullch; /* operand or save */
register char *locinput = PL_reginput;
- register I32 c1, c2, paren; /* case fold search, parenth */
+ register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
int minmod = 0, sw = 0, logical = 0;
I32 unwind = 0;
+#if 0
I32 firstcp = PL_savestack_ix;
- register bool do_utf8 = DO_UTF8(PL_reg_sv);
+#endif
+ register bool do_utf8 = PL_reg_match_utf8;
+#ifdef DEBUGGING
+ SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
+ SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
+ SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
+#endif
#ifdef DEBUGGING
PL_regindent++;
nextchr = UCHARAT(locinput);
scan = prog;
while (scan != NULL) {
-#define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO)
-#if 1
-# 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( {
+
+ DEBUG_r( {
SV *prop = sv_newmortal();
int docolor = *PL_colors[0];
int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
? (5 + taill) - l : locinput - PL_bostr;
int pref0_len;
- while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
+ while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
pref_len++;
pref0_len = pref_len - (locinput - PL_reg_starttry);
if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
l = ( PL_regeol - locinput > (5 + taill) - pref_len
? (5 + taill) - pref_len : PL_regeol - locinput);
- while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
+ while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
l--;
if (pref0_len < 0)
pref0_len = 0;
if (pref0_len > pref_len)
pref0_len = pref_len;
regprop(prop, scan);
- PerlIO_printf(Perl_debug_log,
- "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
- (IV)(locinput - PL_bostr),
- PL_colors[4], pref0_len,
- locinput - pref_len, PL_colors[5],
- PL_colors[2], pref_len - pref0_len,
- locinput - pref_len + pref0_len, PL_colors[3],
- (docolor ? "" : "> <"),
- PL_colors[0], l, locinput, PL_colors[1],
- 15 - l - pref_len + 1,
- "",
- (IV)(scan - PL_regprogram), PL_regindent*2, "",
- SvPVX(prop));
- } );
+ {
+ char *s0 =
+ do_utf8 ?
+ pv_uni_display(dsv0, (U8*)(locinput - pref_len),
+ pref0_len, 60, 0) :
+ locinput - pref_len;
+ int len0 = do_utf8 ? strlen(s0) : pref0_len;
+ char *s1 = do_utf8 ?
+ pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
+ pref_len - pref0_len, 60, 0) :
+ locinput - pref_len + pref0_len;
+ int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
+ char *s2 = do_utf8 ?
+ pv_uni_display(dsv2, (U8*)locinput,
+ PL_regeol - locinput, 60, 0) :
+ locinput;
+ int len2 = do_utf8 ? strlen(s2) : l;
+ PerlIO_printf(Perl_debug_log,
+ "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
+ (IV)(locinput - PL_bostr),
+ PL_colors[4],
+ len0, s0,
+ PL_colors[5],
+ PL_colors[2],
+ len1, s1,
+ PL_colors[3],
+ (docolor ? "" : "> <"),
+ PL_colors[0],
+ len2, s2,
+ PL_colors[1],
+ 15 - l - pref_len + 1,
+ "",
+ (IV)(scan - PL_regprogram), PL_regindent*2, "",
+ SvPVX(prop));
+ }
+ });
next = scan + NEXT_OFF(scan);
if (next == scan)
case SANY:
if (!nextchr && locinput >= PL_regeol)
sayNO;
+ if (do_utf8) {
+ locinput += PL_utf8skip[nextchr];
+ if (locinput > PL_regeol)
+ sayNO;
+ nextchr = UCHARAT(locinput);
+ }
+ else
+ nextchr = UCHARAT(++locinput);
+ break;
+ case CANY:
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
nextchr = UCHARAT(++locinput);
break;
case REG_ANY:
s = STRING(scan);
ln = STR_LEN(scan);
if (do_utf8 != (UTF!=0)) {
+ /* The target and the pattern have differing "utf8ness". */
char *l = locinput;
char *e = s + ln;
STRLEN len;
- if (do_utf8)
+
+ if (do_utf8) {
+ /* The target is utf8, the pattern is not utf8. */
while (s < e) {
if (l >= PL_regeol)
- sayNO;
- if (*((U8*)s) != utf8_to_uvchr((U8*)l, &len))
- sayNO;
- s++;
+ sayNO;
+ if (NATIVE_TO_UNI(*(U8*)s) !=
+ utf8_to_uvchr((U8*)l, &len))
+ sayNO;
l += len;
+ s ++;
}
- else
+ }
+ else {
+ /* The target is not utf8, the pattern is utf8. */
while (s < e) {
if (l >= PL_regeol)
sayNO;
- if (*((U8*)l) != utf8_to_uvchr((U8*)s, &len))
+ if (NATIVE_TO_UNI(*((U8*)l)) !=
+ utf8_to_uvchr((U8*)s, &len))
sayNO;
s += len;
- l++;
+ l ++;
}
+ }
locinput = l;
nextchr = UCHARAT(locinput);
break;
}
+ /* The target and the pattern have the same "utf8ness". */
/* Inline the first character, for speed. */
if (UCHARAT(s) != nextchr)
sayNO;
if (do_utf8) {
char *l = locinput;
char *e;
+ STRLEN ulen;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
e = s + ln;
- c1 = OP(scan) == EXACTF;
while (s < e) {
- if (l >= PL_regeol) {
+ if (l >= PL_regeol)
sayNO;
- }
- if ((UTF ? utf8n_to_uvchr((U8*)s, e - s, 0, 0) : *((U8*)s)) !=
- (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l)))
- sayNO;
- s += UTF ? UTF8SKIP(s) : 1;
- l += UTF8SKIP(l);
+ toLOWER_utf8((U8*)l, tmpbuf, &ulen);
+ if (memNE(s, (char*)tmpbuf, ulen))
+ sayNO;
+ s += UTF8SKIP(s);
+ l += ulen;
}
locinput = l;
nextchr = UCHARAT(locinput);
if (!nextchr)
sayNO;
if (do_utf8) {
+ LOAD_UTF8_CHARCLASS(alnum,"a");
if (!(OP(scan) == ALNUM
? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
: isALNUM_LC_utf8((U8*)locinput)))
* have to map both upper and title case to lower case.
*/
if (OP(scan) == REFF) {
+ STRLEN ulen1, ulen2;
+ U8 tmpbuf1[UTF8_MAXLEN_UCLC+1];
+ U8 tmpbuf2[UTF8_MAXLEN_UCLC+1];
while (s < e) {
if (l >= PL_regeol)
sayNO;
- if (toLOWER_utf8((U8*)s) != toLOWER_utf8((U8*)l))
- sayNO;
- s += UTF8SKIP(s);
- l += UTF8SKIP(l);
- }
- }
- else {
- while (s < e) {
- if (l >= PL_regeol)
- sayNO;
- if (toLOWER_LC_utf8((U8*)s) != toLOWER_LC_utf8((U8*)l))
+ toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
+ toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
+ if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
sayNO;
- s += UTF8SKIP(s);
- l += UTF8SKIP(l);
+ s += ulen1;
+ l += ulen2;
}
}
locinput = l;
PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
- CALLRUNOPS(aTHX); /* Scalar context. */
- SPAGAIN;
- ret = POPs;
- PUTBACK;
-
+ {
+ SV **before = SP;
+ CALLRUNOPS(aTHX); /* Scalar context. */
+ SPAGAIN;
+ if (SP == before)
+ ret = Nullsv; /* protect against empty (?{}) blocks. */
+ else {
+ ret = POPs;
+ PUTBACK;
+ }
+ }
+
PL_op = oop;
PL_curpad = ocurpad;
PL_curcop = ocurcop;
cache_re(re);
state.ss = PL_savestack_ix;
*PL_reglastparen = 0;
+ *PL_reglastcloseparen = 0;
PL_reg_call_cc = &state;
PL_reginput = locinput;
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
+ logical = 0;
sayNO;
}
sw = SvTRUE(ret);
PL_regendp[n] = locinput - PL_bostr;
if (n > *PL_reglastparen)
*PL_reglastparen = n;
+ *PL_reglastcloseparen = n;
break;
case GROUPP:
n = ARG(scan); /* which paren pair */
inner = NEXTOPER(scan);
do_branch:
{
- CHECKPOINT lastcp;
c1 = OP(scan);
if (OP(next) != c1) /* No choice. */
next = inner; /* Avoid recursion. */
minmod = 0;
if (ln && regrepeat_hard(scan, ln, &l) < ln)
sayNO;
- if (ln && l == 0 && n >= ln
- /* In fact, this is tricky. If paren, then the
- fact that we did/didnot match may influence
- future execution. */
- && !(paren && ln == 0))
- ln = n;
+ /* 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 (PL_regkind[(U8)OP(next)] == EXACT) {
- c1 = (U8)*STRING(next);
- if (OP(next) == EXACTF)
- c2 = PL_fold[c1];
- else if (OP(next) == EXACTFL)
- c2 = PL_fold_locale[c1];
- else
- c2 = c1;
+ if (HAS_TEXT(next) || JUMPABLE(next)) {
+ regnode *text_node = next;
+
+ if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
+
+ if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
+ else {
+ if (PL_regkind[(U8)OP(text_node)] == REF) {
+ I32 n, ln;
+ n = ARG(text_node); /* which paren pair */
+ ln = PL_regstartp[n];
+ /* assume yes if we haven't seen CLOSEn */
+ if (
+ *PL_reglastparen < n ||
+ ln == -1 ||
+ ln == PL_regendp[n]
+ ) {
+ c1 = c2 = -1000;
+ goto assume_ok_MM;
+ }
+ c1 = *(PL_bostr + ln);
+ }
+ else { c1 = (U8)*STRING(text_node); }
+ if (OP(text_node) == EXACTF || OP(text_node) == REFF)
+ c2 = PL_fold[c1];
+ else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
+ c2 = PL_fold_locale[c1];
+ else
+ c2 = c1;
+ }
}
else
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 ? */
UCHARAT(PL_reginput) == c2)
{
if (paren) {
- if (n) {
+ if (ln) {
PL_regstartp[paren] =
HOPc(PL_reginput, -l) - PL_bostr;
PL_regendp[paren] = PL_reginput - PL_bostr;
}
else {
n = regrepeat_hard(scan, n, &l);
- if (n != 0 && l == 0
- /* In fact, this is tricky. If paren, then the
- fact that we did/didnot match may influence
- future execution. */
- && !(paren && ln == 0))
- ln = n;
+ /* 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(
PerlIO_printf(Perl_debug_log,
(IV) n, (IV)l)
);
if (n >= ln) {
- if (PL_regkind[(U8)OP(next)] == EXACT) {
- c1 = (U8)*STRING(next);
- if (OP(next) == EXACTF)
- c2 = PL_fold[c1];
- else if (OP(next) == EXACTFL)
- c2 = PL_fold_locale[c1];
- else
- c2 = c1;
+ if (HAS_TEXT(next) || JUMPABLE(next)) {
+ regnode *text_node = next;
+
+ if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
+
+ if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
+ else {
+ if (PL_regkind[(U8)OP(text_node)] == REF) {
+ I32 n, ln;
+ n = ARG(text_node); /* which paren pair */
+ ln = PL_regstartp[n];
+ /* assume yes if we haven't seen CLOSEn */
+ if (
+ *PL_reglastparen < n ||
+ ln == -1 ||
+ ln == PL_regendp[n]
+ ) {
+ c1 = c2 = -1000;
+ goto assume_ok_REG;
+ }
+ c1 = *(PL_bostr + ln);
+ }
+ else { c1 = (U8)*STRING(text_node); }
+
+ if (OP(text_node) == EXACTF || OP(text_node) == REFF)
+ c2 = PL_fold[c1];
+ else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
+ c2 = PL_fold_locale[c1];
+ else
+ c2 = c1;
+ }
}
else
c1 = c2 = -1000;
}
+ assume_ok_REG:
REGCP_SET(lastcp);
while (n >= ln) {
/* If it could work, try it. */
* Lookahead to avoid useless match attempts
* when we know what character comes next.
*/
- if (PL_regkind[(U8)OP(next)] == EXACT) {
- U8 *s = (U8*)STRING(next);
- if (!UTF) {
- c2 = c1 = *s;
- if (OP(next) == EXACTF)
- c2 = PL_fold[c1];
- else if (OP(next) == EXACTFL)
- c2 = PL_fold_locale[c1];
- }
- else { /* UTF */
- if (OP(next) == EXACTF) {
- c1 = to_utf8_lower(s);
- c2 = to_utf8_upper(s);
+
+ /*
+ * Used to only do .*x and .*?x, but now it allows
+ * for )'s, ('s and (?{ ... })'s to be in the way
+ * of the quantifier and the EXACT-like node. -- japhy
+ */
+
+ if (HAS_TEXT(next) || JUMPABLE(next)) {
+ U8 *s;
+ regnode *text_node = next;
+
+ if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
+
+ if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
+ else {
+ if (PL_regkind[(U8)OP(text_node)] == REF) {
+ I32 n, ln;
+ n = ARG(text_node); /* which paren pair */
+ ln = PL_regstartp[n];
+ /* assume yes if we haven't seen CLOSEn */
+ if (
+ *PL_reglastparen < n ||
+ ln == -1 ||
+ ln == PL_regendp[n]
+ ) {
+ c1 = c2 = -1000;
+ goto assume_ok_easy;
+ }
+ s = (U8*)PL_bostr + ln;
}
- else {
- c2 = c1 = utf8_to_uvchr(s, NULL);
+ else { s = (U8*)STRING(text_node); }
+
+ if (!UTF) {
+ c2 = c1 = *s;
+ if (OP(text_node) == EXACTF || OP(text_node) == REFF)
+ c2 = PL_fold[c1];
+ else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
+ c2 = PL_fold_locale[c1];
+ }
+ 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];
+
+ to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
+ to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
+
+ c1 = utf8_to_uvuni(tmpbuf1, 0);
+ c2 = utf8_to_uvuni(tmpbuf2, 0);
+ }
+ else {
+ c2 = c1 = utf8_to_uvchr(s, NULL);
+ }
}
}
}
else
c1 = c2 = -1000;
+ assume_ok_easy:
PL_reginput = locinput;
if (minmod) {
CHECKPOINT lastcp;
/* Find place 'next' could work */
if (!do_utf8) {
if (c1 == c2) {
- while (locinput <= e && *locinput != c1)
+ while (locinput <= e &&
+ UCHARAT(locinput) != c1)
locinput++;
} else {
while (locinput <= e
- && *locinput != c1
- && *locinput != c2)
+ && UCHARAT(locinput) != c1
+ && UCHARAT(locinput) != c2)
locinput++;
}
count = locinput - old;
}
REGCP_SET(lastcp);
if (paren) {
- UV c;
+ UV c = 0;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
}
}
else {
- UV c;
+ UV c = 0;
while (n >= ln) {
if (c1 != -1000) {
if (do_utf8)
register I32 c;
register char *loceol = PL_regeol;
register I32 hardcount = 0;
- register bool do_utf8 = DO_UTF8(PL_reg_sv);
+ register bool do_utf8 = PL_reg_match_utf8;
scan = PL_reginput;
if (max != REG_INFTY && max < loceol - scan)
case SANY:
scan = loceol;
break;
+ case CANY:
+ scan = loceol;
+ break;
case EXACT: /* length of string is 1 */
c = (U8)*STRING(p);
while (scan < loceol && UCHARAT(scan) == c)
STATIC I32
S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
{
- register char *scan;
+ register char *scan = Nullch;
register char *start;
register char *loceol = PL_regeol;
I32 l = 0;
return 0;
start = PL_reginput;
- if (DO_UTF8(PL_reg_sv)) {
+ if (PL_reg_match_utf8) {
while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
if (!count++) {
l = 0;
if (swash_fetch(sw, p, do_utf8))
match = TRUE;
else if (flags & ANYOF_FOLD) {
- U8 tmpbuf[UTF8_MAXLEN+1];
-
- if (flags & ANYOF_LOCALE) {
- PL_reg_flags |= RF_tainted;
- uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
- }
- else
- uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
+ STRLEN ulen;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+
+ toLOWER_utf8(p, tmpbuf, &ulen);
if (swash_fetch(sw, tmpbuf, do_utf8))
match = TRUE;
}
return s;
}
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
static void
-restore_pos(pTHXo_ void *arg)
+restore_pos(pTHX_ void *arg)
{
if (PL_reg_eval_set) {
if (PL_reg_oldsaved) {
projects / p5sagit/p5-mst-13.2.git / blobdiff