*
**** Alterations to Henry's code are...
****
- **** Copyright (c) 1991-1999, Larry Wall
+ **** Copyright (c) 1991-2000, Larry Wall
****
**** You may distribute under the terms of either the GNU General Public
**** License or the Artistic License, as specified in the README file.
#define regcpblow(cp) LEAVE_SCOPE(cp)
+#define TRYPAREN(paren, n, input) { \
+ if (paren) { \
+ if (n) { \
+ PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \
+ PL_regendp[paren] = input - PL_bostr; \
+ } \
+ else \
+ PL_regendp[paren] = -1; \
+ } \
+ if (regmatch(next)) \
+ sayYES; \
+ if (paren && n) \
+ PL_regendp[paren] = -1; \
+}
+
+
/*
* pregexec and friends
*/
DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
goto fail;
}
+ check = prog->check_substr;
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)
I32 slen;
if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
- && (sv && (strpos + SvCUR(sv) != strend)) ) {
+ /* SvCUR is not set on references: SvRV and SvPVX overlap */
+ && sv && !SvROK(sv)
+ && (strpos + SvCUR(sv) != strend)) {
DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
goto fail;
}
PL_regeol = strend; /* Used in HOP() */
s = HOPc(strpos, prog->check_offset_min);
- if (SvTAIL(prog->check_substr)) {
- slen = SvCUR(prog->check_substr); /* >= 1 */
+ if (SvTAIL(check)) {
+ slen = SvCUR(check); /* >= 1 */
if ( strend - s > slen || strend - s < slen - 1
|| (strend - s == slen && strend[-1] != '\n')) {
}
/* Now should match s[0..slen-2] */
slen--;
- if (slen && (*SvPVX(prog->check_substr) != *s
+ if (slen && (*SvPVX(check) != *s
|| (slen > 1
- && memNE(SvPVX(prog->check_substr), s, slen)))) {
+ && memNE(SvPVX(check), s, slen)))) {
report_neq:
DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
goto fail_finish;
}
}
- else if (*SvPVX(prog->check_substr) != *s
- || ((slen = SvCUR(prog->check_substr)) > 1
- && memNE(SvPVX(prog->check_substr), s, slen)))
+ else if (*SvPVX(check) != *s
+ || ((slen = SvCUR(check)) > 1
+ && memNE(SvPVX(check), s, slen)))
goto report_neq;
goto success_at_start;
}
/* Match is anchored, but substr is not anchored wrt beg-of-str. */
s = strpos;
start_shift = prog->check_offset_min; /* okay to underestimate on CC */
- /* Should be nonnegative! */
end_shift = prog->minlen - start_shift -
- CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
+ CHR_SVLEN(check) + (SvTAIL(check) != 0);
if (!ml_anch) {
- I32 end = prog->check_offset_max + CHR_SVLEN(prog->check_substr)
- - (SvTAIL(prog->check_substr) != 0);
+ I32 end = prog->check_offset_max + CHR_SVLEN(check)
+ - (SvTAIL(check) != 0);
I32 eshift = strend - s - end;
if (end_shift < eshift)
start_shift = prog->check_offset_min; /* okay to underestimate on CC */
/* Should be nonnegative! */
end_shift = prog->minlen - start_shift -
- CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
+ CHR_SVLEN(check) + (SvTAIL(check) != 0);
}
#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
Perl_croak(aTHX_ "panic: end_shift");
#endif
- check = prog->check_substr;
restart:
/* Find a possible match in the region s..strend by looking for
the "check" substring in the region corrected by start/end_shift. */
find_anchor:
while (t < strend - prog->minlen) {
if (*t == '\n') {
- if (t < s - prog->check_offset_min) {
+ if (t < check_at - prog->check_offset_min) {
if (prog->anchored_substr) {
- /* We definitely contradict the found anchored
+ /* Since we moved from the found position,
+ we definitely contradict the found anchored
substr. Due to the above check we do not
contradict "check" substr.
Thus we can arrive here only if check substr
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",
PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
goto set_useful;
}
- DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n",
+ /* 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",
PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
- strpos = s = t + 1;
+ other_last = strpos = s = t + 1;
goto restart;
}
t++;
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",
+ PL_colors[0],PL_colors[1]));
+ }
s = t;
set_useful:
++BmUSEFUL(prog->check_substr); /* hooray/5 */
}
else {
PL_bostr = tmp;
- /* The found string does not prohibit matching at beg-of-str
+ /* The found string does not prohibit matching at strpos,
- no optimization of calling REx engine can be performed,
- unless it was an MBOL and we are not after MBOL. */
+ unless it was an MBOL and we are not after MBOL,
+ or a future STCLASS check will fail this. */
try_at_start:
/* Even in this situation we may use MBOL flag if strpos is offset
wrt the start of the string. */
- if (ml_anch && sv
- && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n') {
+ if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
+ && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n'
+ /* May be due to an implicit anchor of m{.*foo} */
+ && !(prog->reganch & ROPT_IMPLICIT))
+ {
t = strpos;
goto find_anchor;
}
DEBUG_r( if (ml_anch)
- PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n",
- PL_colors[0],PL_colors[1]);
+ 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]);
);
success_at_start:
if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
&& prog->check_substr == prog->float_substr)
{
/* If flags & SOMETHING - do not do it many times on the same match */
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
SvREFCNT_dec(prog->check_substr);
prog->check_substr = Nullsv; /* disable */
prog->float_substr = Nullsv; /* clear */
+ check = Nullsv; /* abort */
s = strpos;
/* XXXX This is a remnant of the old implementation. It
looks wasteful, since now INTUIT can use many
? s + (prog->minlen? cl_l : 0)
: (prog->float_substr ? check_at - start_shift + cl_l
: strend) ;
- char *startpos = sv ? strend - SvCUR(sv) : s;
+ char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s;
t = s;
+ if (prog->reganch & ROPT_UTF8) {
+ PL_regdata = prog->data; /* Used by REGINCLASS UTF logic */
+ PL_bostr = startpos;
+ }
s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
#ifdef DEBUGGING
}
DEBUG_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) {
if (prog->anchored_substr == check) {
"Could not match STCLASS...\n") );
goto fail;
}
+ if (!check)
+ goto giveup;
DEBUG_r( PerlIO_printf(Perl_debug_log,
- "Trying %s substr starting at offset %ld...\n",
+ "Looking for %s substr starting at offset %ld...\n",
what, (long)(s + start_shift - i_strpos)) );
goto restart;
}
goto retry_floating_check;
/* Recheck anchored substring, but not floating... */
s = check_at;
+ if (!check)
+ goto giveup;
DEBUG_r( PerlIO_printf(Perl_debug_log,
- "Trying anchored substr starting at offset %ld...\n",
+ "Looking for anchored substr starting at offset %ld...\n",
(long)(other_last - i_strpos)) );
goto do_other_anchored;
}
- if (!prog->float_substr) { /* Could have been deleted */
- if (ml_anch) {
- s = t = t + 1;
- goto try_at_offset;
- }
- goto fail;
+ /* Another way we could have checked stclass at the
+ current position only: */
+ if (ml_anch) {
+ s = t = t + 1;
+ if (!check)
+ goto giveup;
+ DEBUG_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;
}
+ if (!prog->float_substr) /* Could have been deleted */
+ goto fail;
/* Check is floating subtring. */
retry_floating_check:
t = check_at - start_shift;
PerlIO_printf(Perl_debug_log,
"Does not contradict STCLASS...\n") );
}
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n",
- PL_colors[4], PL_colors[5], (long)(s - i_strpos)) );
+ giveup:
+ DEBUG_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;
fail_finish: /* Substring not found */
{
I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
char *m;
- int ln;
- int c1;
- int c2;
+ STRLEN ln;
+ unsigned int c1;
+ unsigned int c2;
char *e;
register I32 tmp = 1; /* Scratch variable? */
break;
case ANYOF:
while (s < strend) {
- if (REGINCLASS(c, *s)) {
+ if (REGINCLASS(c, *(U8*)s)) {
if (tmp && (norun || regtry(prog, s)))
goto got_it;
else
case EXACTF:
m = STRING(c);
ln = STR_LEN(c);
- c1 = *m;
+ c1 = *(U8*)m;
c2 = PL_fold[c1];
goto do_exactf;
case EXACTFL:
m = STRING(c);
ln = STR_LEN(c);
- c1 = *m;
+ c1 = *(U8*)m;
c2 = PL_fold_locale[c1];
do_exactf:
e = strend - ln;
/* Here it is NOT UTF! */
if (c1 == c2) {
while (s <= e) {
- if ( *s == c1
+ if ( *(U8*)s == c1
&& (ln == 1 || !(OP(c) == EXACTF
? ibcmp(s, m, ln)
: ibcmp_locale(s, m, ln)))
}
} else {
while (s <= e) {
- if ( (*s == c1 || *s == c2)
+ if ( (*(U8*)s == c1 || *(U8*)s == c2)
&& (ln == 1 || !(OP(c) == EXACTF
? ibcmp(s, m, ln)
: ibcmp_locale(s, m, ln)))
/* FALL THROUGH */
case BOUNDUTF8:
tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n';
- tmp = ((OP(c) == BOUND ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
+ tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
while (s < strend) {
- if (tmp == !(OP(c) == BOUND ?
+ if (tmp == !(OP(c) == BOUNDUTF8 ?
swash_fetch(PL_utf8_alnum, (U8*)s) :
isALNUM_LC_utf8((U8*)s)))
{
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case NBOUNDUTF8:
- if (prog->minlen)
- strend = reghop_c(strend, -1);
tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n';
- tmp = ((OP(c) == NBOUND ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
+ tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
while (s < strend) {
- if (tmp == !(OP(c) == NBOUND ?
+ if (tmp == !(OP(c) == NBOUNDUTF8 ?
swash_fetch(PL_utf8_alnum, (U8*)s) :
isALNUM_LC_utf8((U8*)s)))
tmp = !tmp;
register char *s;
register regnode *c;
register char *startpos = stringarg;
- register I32 tmp;
I32 minlen; /* must match at least this many chars */
I32 dontbother = 0; /* how many characters not to try at end */
- I32 start_shift = 0; /* Offset of the start to find
+ /* I32 start_shift = 0; */ /* Offset of the start to find
constant substr. */ /* CC */
I32 end_shift = 0; /* Same for the end. */ /* CC */
I32 scream_pos = -1; /* Internal iterator of scream. */
/* we have /x+whatever/ */
/* it must be a one character string (XXXX Except UTF?) */
char ch = SvPVX(prog->anchored_substr)[0];
+#ifdef DEBUGGING
+ int did_match = 0;
+#endif
+
if (UTF) {
while (s < strend) {
if (*s == ch) {
+ DEBUG_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 );
if (regtry(prog, s)) goto got_it;
s++;
while (s < strend && *s == ch)
s++;
}
}
+ DEBUG_r(did_match ||
+ PerlIO_printf(Perl_debug_log,
+ "Did not find anchored character...\n"));
}
/*SUPPRESS 560*/
else if (prog->anchored_substr != Nullsv
prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
I32 back_min =
prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
- I32 delta = back_max - back_min;
char *last = HOPc(strend, /* Cannot start after this */
-(I32)(CHR_SVLEN(must)
- (SvTAIL(must) != 0) + back_min));
char *last1; /* Last position checked before */
+#ifdef DEBUGGING
+ int did_match = 0;
+#endif
if (s > PL_bostr)
last1 = HOPc(s, -1);
: (s = fbm_instr((unsigned char*)HOP(s, back_min),
(unsigned char*)strend, must,
PL_multiline ? FBMrf_MULTILINE : 0))) ) {
+ DEBUG_r( did_match = 1 );
if (HOPc(s, -back_max) > last1) {
last1 = HOPc(s, -back_min);
s = HOPc(s, -back_max);
}
}
}
+ DEBUG_r(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) ? "$" : "")));
goto phooey;
}
- else if (c = prog->regstclass) {
+ else if ((c = prog->regstclass)) {
if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT)
/* don't bother with what can't match */
strend = HOPc(strend, -(minlen - 1));
if (find_byclass(prog, c, s, strend, startpos, 0))
goto got_it;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
}
else {
dontbother = 0;
if (prog->float_substr != Nullsv) { /* Trim the end. */
char *last;
- I32 oldpos = scream_pos;
if (flags & REXEC_SCREAM) {
last = screaminstr(sv, prog->float_substr, s - strbeg,
last = strend; /* matching `$' */
}
}
- if (last == NULL) goto phooey; /* Should not happen! */
+ if (last == NULL) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "%sCan't trim the tail, match fails (should not happen)%s\n",
+ PL_colors[4],PL_colors[5]));
+ goto phooey; /* Should not happen! */
+ }
dontbother = strend - last + prog->float_min_offset;
}
if (minlen && (dontbother < minlen))
return 1;
phooey:
+ 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);
return 0;
PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
(IV)(PL_stack_sp - PL_stack_base));
));
- SAVEINT(cxstack[cxstack_ix].blk_oldsp);
+ SAVEI32(cxstack[cxstack_ix].blk_oldsp);
cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
/* Otherwise OP_NEXTSTATE will free whatever on stack now. */
SAVETMPS;
/* Apparently this is not needed, judging by wantarray. */
- /* SAVEINT(cxstack[cxstack_ix].blk_gimme);
+ /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
if (PL_reg_sv) {
SAVEDESTRUCTOR_X(restore_pos, 0);
}
if (!PL_reg_curpm)
- New(22,PL_reg_curpm, 1, PMOP);
+ Newz(22,PL_reg_curpm, 1, PMOP);
PL_reg_curpm->op_pmregexp = prog;
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
}
sayNO;
case SBOL:
- if (locinput == PL_regbol && PL_regprev == '\n')
+ if (locinput == PL_bostr)
break;
sayNO;
case GPOS:
nextchr = UCHARAT(locinput);
break;
}
- if (!nextchr && locinput >= PL_regeol || nextchr == '\n')
+ if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
sayNO;
nextchr = UCHARAT(++locinput);
break;
case REG_ANY:
- if (!nextchr && locinput >= PL_regeol || nextchr == '\n')
+ if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
sayNO;
nextchr = UCHARAT(++locinput);
break;
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case SPACE:
- if (!nextchr && locinput >= PL_regeol)
+ if (!nextchr)
sayNO;
if (!(OP(scan) == SPACE
? isSPACE(nextchr) : isSPACE_LC(nextchr)))
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case SPACEUTF8:
- if (!nextchr && locinput >= PL_regeol)
+ if (!nextchr)
sayNO;
if (nextchr & 0x80) {
if (!(OP(scan) == SPACEUTF8
- ? swash_fetch(PL_utf8_space,(U8*)locinput)
+ ? swash_fetch(PL_utf8_space, (U8*)locinput)
: isSPACE_LC_utf8((U8*)locinput)))
{
sayNO;
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case NSPACE:
- if (!nextchr)
+ if (!nextchr && locinput >= PL_regeol)
sayNO;
- if (OP(scan) == SPACE
+ if (OP(scan) == NSPACE
? isSPACE(nextchr) : isSPACE_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case NSPACEUTF8:
- if (!nextchr)
+ if (!nextchr && locinput >= PL_regeol)
sayNO;
if (nextchr & 0x80) {
if (OP(scan) == NSPACEUTF8
- ? swash_fetch(PL_utf8_space,(U8*)locinput)
+ ? swash_fetch(PL_utf8_space, (U8*)locinput)
: isSPACE_LC_utf8((U8*)locinput))
{
sayNO;
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case DIGIT:
- if (!nextchr && locinput >= PL_regeol)
+ if (!nextchr)
sayNO;
if (!(OP(scan) == DIGIT
? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
if (!nextchr)
sayNO;
if (nextchr & 0x80) {
- if (OP(scan) == NDIGITUTF8
- ? swash_fetch(PL_utf8_digit,(U8*)locinput)
- : isDIGIT_LC_utf8((U8*)locinput))
+ if (!(OP(scan) == DIGITUTF8
+ ? swash_fetch(PL_utf8_digit, (U8*)locinput)
+ : isDIGIT_LC_utf8((U8*)locinput)))
{
sayNO;
}
nextchr = UCHARAT(locinput);
break;
}
- if (!isDIGIT(nextchr))
+ if (!(OP(scan) == DIGITUTF8
+ ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
sayNO;
nextchr = UCHARAT(++locinput);
break;
PL_reg_flags |= RF_tainted;
/* FALL THROUGH */
case NDIGIT:
- if (!nextchr)
+ if (!nextchr && locinput >= PL_regeol)
sayNO;
- if (OP(scan) == DIGIT
+ if (OP(scan) == NDIGIT
? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
if (!nextchr && locinput >= PL_regeol)
sayNO;
if (nextchr & 0x80) {
- if (swash_fetch(PL_utf8_digit,(U8*)locinput))
+ if (OP(scan) == NDIGITUTF8
+ ? swash_fetch(PL_utf8_digit, (U8*)locinput)
+ : isDIGIT_LC_utf8((U8*)locinput))
+ {
sayNO;
+ }
locinput += PL_utf8skip[nextchr];
nextchr = UCHARAT(locinput);
break;
}
- if (isDIGIT(nextchr))
+ if (OP(scan) == NDIGITUTF8
+ ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
sayNO;
nextchr = UCHARAT(++locinput);
break;
I32 onpar = PL_regnpar;
pm.op_pmflags = 0;
+ pm.op_pmdynflags = (UTF||DO_UTF8(ret) ? PMdf_UTF8 : 0);
re = CALLREGCOMP(aTHX_ t, t + len, &pm);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
PL_regcc = cc;
if (n >= cc->max) { /* Maximum greed exceeded? */
- if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY
+ if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
&& !(PL_reg_flags & RF_warned)) {
PL_reg_flags |= RF_warned;
- Perl_warner(aTHX_ WARN_UNSAFE, "%s limit (%d) exceeded",
+ Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
"Complex regular subexpression recursion",
REG_INFTY - 1);
}
REPORT_CODE_OFF+PL_regindent*2, "")
);
}
- if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY
+ if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
&& !(PL_reg_flags & RF_warned)) {
PL_reg_flags |= RF_warned;
- Perl_warner(aTHX_ WARN_UNSAFE, "%s limit (%d) exceeded",
+ Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
"Complex regular subexpression recursion",
REG_INFTY - 1);
}
*PL_reglastparen = n;
scan = next;
/*SUPPRESS 560*/
- if (n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next)))
+ if ((n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next))))
next += n;
else
next = NULL;
sayNO;
}
/* PL_reginput == locinput now */
- if (paren) {
- if (ln) {
- PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr;
- PL_regendp[paren] = locinput - PL_bostr;
- }
- else
- PL_regendp[paren] = -1;
- }
- if (regmatch(next))
- sayYES;
+ TRYPAREN(paren, ln, locinput);
PL_reginput = locinput; /* Could be reset... */
REGCP_UNWIND;
/* Couldn't or didn't -- move forward. */
UCHARAT(PL_reginput) == c1 ||
UCHARAT(PL_reginput) == c2)
{
- if (paren) {
- if (n) {
- PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr;
- PL_regendp[paren] = PL_reginput - PL_bostr;
- }
- else
- PL_regendp[paren] = -1;
- }
- if (regmatch(next))
- sayYES;
+ TRYPAREN(paren, n, PL_reginput);
REGCP_UNWIND;
}
/* Couldn't or didn't -- move forward. */
n = regrepeat(scan, n);
locinput = PL_reginput;
if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
- (!PL_multiline || OP(next) == SEOL))
+ (!PL_multiline || OP(next) == SEOL || OP(next) == EOS)) {
ln = n; /* why back off? */
+ /* ...because $ and \Z can match before *and* after
+ newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
+ We should back off by one in this case. */
+ if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
+ ln--;
+ }
REGCP_SET;
if (paren) {
while (n >= ln) {
UCHARAT(PL_reginput) == c1 ||
UCHARAT(PL_reginput) == c2)
{
- if (paren && n) {
- if (n) {
- PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr;
- PL_regendp[paren] = PL_reginput - PL_bostr;
- }
- else
- PL_regendp[paren] = -1;
- }
- if (regmatch(next))
- sayYES;
+ TRYPAREN(paren, n, PL_reginput);
REGCP_UNWIND;
}
/* Couldn't or didn't -- back up. */
UCHARAT(PL_reginput) == c1 ||
UCHARAT(PL_reginput) == c2)
{
- if (regmatch(next))
- sayYES;
+ TRYPAREN(paren, n, PL_reginput);
REGCP_UNWIND;
}
/* Couldn't or didn't -- back up. */
if (swash_fetch(sv, p))
match = TRUE;
else if (flags & ANYOF_FOLD) {
- I32 cf;
- U8 tmpbuf[10];
+ U8 tmpbuf[UTF8_MAXLEN];
if (flags & ANYOF_LOCALE) {
PL_reg_flags |= RF_tainted;
uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
https://perl5.git.perl.org / perl5.git / blobdiff