#define STATIC static
#endif
-/* Valid for non-utf8 strings: avoids the reginclass
+/* Valid only for non-utf8 strings: avoids the reginclass
* call if there are no complications: i.e., if everything matchable is
* straight forward in the bitmap */
-#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0) \
+#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,c+1,0) \
: ANYOF_BITMAP_TEST(p,*(c)))
/*
#define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
+/* like HOP3, but limits the result to <= lim even for the non-utf8 case.
+ * off must be >=0; args should be vars rather than expressions */
+#define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \
+ ? reghop3((U8*)(pos), off, (U8*)(lim)) \
+ : (U8*)((pos + off) > lim ? lim : (pos + off)))
+
+#define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \
+ ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \
+ : (U8*)(pos + off))
+#define HOP4c(pos,off,llim, rlim) ((char*)HOP4(pos,off,llim, rlim))
#define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
#define NEXTCHR_IS_EOS (nextchr < 0)
SET_nextchr
-#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name) STMT_START { \
+#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) STMT_START { \
if (!swash_ptr) { \
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \
swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
- 1, 0, NULL, &flags); \
+ 1, 0, invlist, &flags); \
assert(swash_ptr); \
} \
} STMT_END
#ifdef DEBUGGING
# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
property_name, \
+ invlist, \
utf8_char_in_property) \
- LOAD_UTF8_CHARCLASS(swash_ptr, property_name); \
+ LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist); \
assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
#else
# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
property_name, \
+ invlist, \
utf8_char_in_property) \
- LOAD_UTF8_CHARCLASS(swash_ptr, property_name)
+ LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist)
#endif
#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \
PL_utf8_swash_ptrs[_CC_WORDCHAR], \
- swash_property_names[_CC_WORDCHAR], \
+ "", \
+ PL_XPosix_ptrs[_CC_WORDCHAR], \
LATIN_CAPITAL_LETTER_SHARP_S_UTF8);
#define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \
STMT_START { \
LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_regular_begin, \
"_X_regular_begin", \
+ NULL, \
LATIN_CAPITAL_LETTER_SHARP_S_UTF8); \
LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_extend, \
"_X_extend", \
+ NULL, \
COMBINING_GRAVE_ACCENT_UTF8); \
} STMT_END
* although it may be done at run time beause of the REF possibility - more
* investigation required. -- demerphq
*/
-#define JUMPABLE(rn) ( \
- OP(rn) == OPEN || \
+#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)] == CURLY && ARG1(rn) > 0) \
+ OP(rn) == EVAL || \
+ OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
+ OP(rn) == PLUS || OP(rn) == MINMOD || \
+ OP(rn) == KEEPS || \
+ (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
)
#define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
Search for mandatory following text node; for lookahead, the text must
follow but for lookbehind (rn->flags != 0) we skip to the next step.
*/
-#define FIND_NEXT_IMPT(rn) STMT_START { \
+#define FIND_NEXT_IMPT(rn) STMT_START { \
while (JUMPABLE(rn)) { \
const OPCODE type = OP(rn); \
if (type == SUSPEND || PL_regkind[type] == CURLY) \
/* Initialize the swash unless done already */
if (! PL_utf8_swash_ptrs[classnum]) {
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- PL_utf8_swash_ptrs[classnum] = _core_swash_init("utf8",
- swash_property_names[classnum], &PL_sv_undef, 1, 0, NULL, &flags);
+ PL_utf8_swash_ptrs[classnum] =
+ _core_swash_init("utf8",
+ "",
+ &PL_sv_undef, 1, 0,
+ PL_XPosix_ptrs[classnum], &flags);
}
return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
SSize_t start_shift = 0;
/* Should be nonnegative! */
SSize_t end_shift = 0;
- char *s;
+ /* current lowest pos in string where the regex can start matching */
+ char *rx_origin = strpos;
SV *check;
- char *t;
const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
- I32 ml_anch;
- char *other_last = NULL; /* other substr checked before this */
+ U8 other_ix = 1 - prog->substrs->check_ix;
+ bool ml_anch = 0;
+ char *other_last = strpos;/* latest pos 'other' substr already checked to */
char *check_at = NULL; /* check substr found at this pos */
char *checked_upto = NULL; /* how far into the string we have already checked using find_byclass*/
const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
RXi_GET_DECL(prog,progi);
regmatch_info reginfo_buf; /* create some info to pass to find_byclass */
regmatch_info *const reginfo = ®info_buf;
-#ifdef DEBUGGING
- const char * const i_strpos = strpos;
-#endif
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_RE_INTUIT_START;
PERL_UNUSED_ARG(flags);
PERL_UNUSED_ARG(data);
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ "Intuit: trying to determine minimum start position...\n"));
+
+ /* for now, assume that all substr offsets are positive. If at some point
+ * in the future someone wants to do clever things with look-behind and
+ * -ve offsets, they'll need to fix up any code in this function
+ * which uses these offsets. See the thread beginning
+ * <20140113145929.GF27210@iabyn.com>
+ */
+ assert(prog->substrs->data[0].min_offset >= 0);
+ assert(prog->substrs->data[0].max_offset >= 0);
+ assert(prog->substrs->data[1].min_offset >= 0);
+ assert(prog->substrs->data[1].max_offset >= 0);
+ assert(prog->substrs->data[2].min_offset >= 0);
+ assert(prog->substrs->data[2].max_offset >= 0);
+
+ /* for now, assume that if both present, that the floating substring
+ * follows the anchored substring, and that they don't overlap.
+ * If you break this assumption (e.g. doing better optimisations
+ * with lookahead/behind), then you'll need to audit the code in this
+ * function carefully first
+ */
+ assert(
+ ! ( (prog->anchored_utf8 || prog->anchored_substr)
+ && (prog->float_utf8 || prog->float_substr))
+ || (prog->float_min_offset >= prog->anchored_offset));
+
/* CHR_DIST() would be more correct here but it makes things slow. */
if (prog->minlen > strend - strpos) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "String too short... [re_intuit_start]\n"));
+ " String too short...\n"));
goto fail;
}
}
check = prog->check_substr;
}
- if (prog->extflags & RXf_ANCH) { /* Match at \G, beg-of-str or after \n */
- ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
- || ( (prog->extflags & RXf_ANCH_BOL)
- && !multiline ) ); /* Check after \n? */
+
+ /* dump the various substring data */
+ DEBUG_OPTIMISE_MORE_r({
+ int i;
+ for (i=0; i<=2; i++) {
+ SV *sv = (utf8_target ? prog->substrs->data[i].utf8_substr
+ : prog->substrs->data[i].substr);
+ if (!sv)
+ continue;
+
+ PerlIO_printf(Perl_debug_log,
+ " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf
+ " useful=%"IVdf" utf8=%d [%s]\n",
+ i,
+ (IV)prog->substrs->data[i].min_offset,
+ (IV)prog->substrs->data[i].max_offset,
+ (IV)prog->substrs->data[i].end_shift,
+ BmUSEFUL(sv),
+ utf8_target ? 1 : 0,
+ SvPEEK(sv));
+ }
+ });
+
+ if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */
+ /* Check after \n? */
+ ml_anch = ( (prog->intflags & PREGf_ANCH_MBOL)
+ || ((prog->intflags & PREGf_ANCH_BOL) && multiline));
if (!ml_anch) {
- /* we are only allowed to match at BOS or \G */
+ /* we are only allowed to match at BOS or \G */
- if (prog->extflags & RXf_ANCH_GPOS) {
- /* in this case, we hope(!) that the caller has already
+ /* trivially reject if there's a BOS anchor and we're not at BOS.
+ * In the case of \G, we hope(!) that the caller has already
* set strpos to pos()-gofs, and will already have checked
- * that this anchor position is legal
+ * that this anchor position is legal. So we can skip it here.
*/
- ;
- }
- else if (!(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
+ if ( !(prog->intflags & PREGf_ANCH_GPOS)
+ && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
&& (strpos != strbeg))
- {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
- goto fail;
- }
- if (prog->check_offset_min == prog->check_offset_max
- && !(prog->extflags & RXf_CANY_SEEN)
- && ! multiline) /* /m can cause \n's to match that aren't
- accounted for in the string max length.
- See [perl #115242] */
- {
- /* Substring at constant offset from beg-of-str... */
- SSize_t slen;
-
- s = HOP3c(strpos, prog->check_offset_min, strend);
+ {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " Not at start...\n"));
+ goto fail;
+ }
+
+ /* in the presence of an anchor, the anchored (relative to the
+ * start of the regex) substr must also be anchored relative
+ * to strpos. So quickly reject if substr isn't found there */
+
+ if (prog->check_offset_min == prog->check_offset_max
+ && !(prog->intflags & PREGf_CANY_SEEN)
+ && ! multiline) /* /m can cause \n's to match that aren't
+ accounted for in the string max length.
+ See [perl #115242] */
+ {
+ /* Substring at constant offset from beg-of-str... */
+ SSize_t slen = SvCUR(check);
+ char *s;
+
+ s = HOP3c(strpos, prog->check_offset_min, strend);
- if (SvTAIL(check)) {
- slen = SvCUR(check); /* >= 1 */
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " Looking for check substr at fixed offset %"IVdf"...\n",
+ (IV)prog->check_offset_min));
+
+ if (SvTAIL(check)) {
+ /* In this case, the regex is anchored at the end too,
+ * so the lengths must match exactly, give or take a \n.
+ * NB: slen >= 1 since the last char of check is \n */
+ if ( strend - s > slen || strend - s < slen - 1
+ || (strend - s == slen && strend[-1] != '\n'))
+ {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " String too long...\n"));
+ goto fail_finish;
+ }
+ /* Now should match s[0..slen-2] */
+ slen--;
+ }
+ if (slen && (*SvPVX_const(check) != *s
+ || (slen > 1 && memNE(SvPVX_const(check), s, slen))))
+ {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " String not equal...\n"));
+ goto fail_finish;
+ }
- if ( strend - s > slen || strend - s < slen - 1
- || (strend - s == slen && strend[-1] != '\n')) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
- goto fail_finish;
- }
- /* Now should match s[0..slen-2] */
- slen--;
- if (slen && (*SvPVX_const(check) != *s
- || (slen > 1
- && memNE(SvPVX_const(check), s, slen)))) {
- report_neq:
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
- goto fail_finish;
- }
+ check_at = s;
+ goto success_at_start;
}
- else if (*SvPVX_const(check) != *s
- || ((slen = SvCUR(check)) > 1
- && memNE(SvPVX_const(check), s, slen)))
- goto report_neq;
- check_at = s;
- 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 */
- end_shift = prog->check_end_shift;
-
- if (!ml_anch) {
- const SSize_t end = prog->check_offset_max + CHR_SVLEN(check)
- - (SvTAIL(check) != 0);
- const SSize_t eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
-
- if (end_shift < eshift)
- end_shift = eshift;
- }
- }
- else { /* Can match at random position */
- ml_anch = 0;
- s = strpos;
- start_shift = prog->check_offset_min; /* okay to underestimate on CC */
- end_shift = prog->check_end_shift;
-
- /* end shift should be non negative here */
}
+ start_shift = prog->check_offset_min; /* okay to underestimate on CC */
+ end_shift = prog->check_end_shift;
+
#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
#endif
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 a candidate regex origin in the region rx_origin..strend
+ * by looking for the "check" substring in that region, corrected by
+ * start/end_shift.
+ */
{
- SSize_t srch_start_shift = start_shift;
- SSize_t srch_end_shift = end_shift;
U8* start_point;
U8* end_point;
- if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
- srch_end_shift -= ((strbeg - s) - srch_start_shift);
- srch_start_shift = strbeg - s;
- }
- DEBUG_OPTIMISE_MORE_r({
- PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
- (IV)prog->check_offset_min,
- (IV)srch_start_shift,
- (IV)srch_end_shift,
- (IV)prog->check_end_shift);
- });
+
+ DEBUG_OPTIMISE_MORE_r({
+ PerlIO_printf(Perl_debug_log,
+ " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf
+ " Start shift: %"IVdf" End shift %"IVdf
+ " Real end Shift: %"IVdf"\n",
+ (IV)(rx_origin - strpos),
+ (IV)prog->check_offset_min,
+ (IV)start_shift,
+ (IV)end_shift,
+ (IV)prog->check_end_shift);
+ });
- if (prog->extflags & RXf_CANY_SEEN) {
- start_point= (U8*)(s + srch_start_shift);
- end_point= (U8*)(strend - srch_end_shift);
+ if (prog->intflags & PREGf_CANY_SEEN) {
+ start_point= (U8*)(rx_origin + start_shift);
+ end_point= (U8*)(strend - end_shift);
} else {
- start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
- end_point= HOP3(strend, -srch_end_shift, strbeg);
+ start_point= HOP3(rx_origin, start_shift, strend);
+ end_point= HOP3(strend, -end_shift, strbeg);
}
+
+ /* if the regex is absolutely anchored to the start of the string,
+ * then check_offset_max represents an upper bound on the string
+ * where the substr could start */
+ if (!ml_anch
+ && prog->intflags & PREGf_ANCH
+ && prog->check_offset_max != SSize_t_MAX
+ && start_shift < prog->check_offset_max)
+ {
+ SSize_t len = SvCUR(check) - !!SvTAIL(check);
+ end_point = HOP3lim(start_point,
+ prog->check_offset_max - start_shift,
+ end_point -len)
+ + len;
+ }
+
DEBUG_OPTIMISE_MORE_r({
- PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
+ PerlIO_printf(Perl_debug_log, " fbm_instr len=%d str=<%.*s>\n",
(int)(end_point - start_point),
(int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
start_point);
});
- s = fbm_instr( start_point, end_point,
+ check_at = fbm_instr( start_point, end_point,
check, multiline ? FBMrf_MULTILINE : 0);
}
+
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
DEBUG_EXECUTE_r({
RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
- PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
- (s ? "Found" : "Did not find"),
+ PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s",
+ (check_at ? "Found" : "Did not find"),
(check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
? "anchored" : "floating"),
quoted,
RE_SV_TAIL(check),
- (s ? " at offset " : "...\n") );
+ (check_at ? " at offset " : "...\n") );
});
- if (!s)
+ if (!check_at)
goto fail_finish;
/* Finish the diagnostic message */
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(check_at - strpos)) );
+
+ /* set rx_origin to the minimum position where the regex could start
+ * matching, given the constraint of the just-matched check substring.
+ * But don't set it lower than previously.
+ */
+
+ if (check_at - rx_origin > prog->check_offset_max)
+ rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
+
/* XXX dmq: first branch is for positive lookbehind...
Our check string is offset from the beginning of the pattern.
point. I think. :-(
*/
-
-
- check_at=s;
-
-
/* Got a candidate. Check MBOL anchoring, and the *other* substr.
Start with the other substr.
XXXX no SCREAM optimization yet - and a very coarse implementation
Probably it is right to do no SCREAM here...
*/
- if (utf8_target ? (prog->float_utf8 && prog->anchored_utf8)
- : (prog->float_substr && prog->anchored_substr))
+ if (utf8_target ? prog->substrs->data[other_ix].utf8_substr
+ : prog->substrs->data[other_ix].substr)
{
/* Take into account the "other" substring. */
- /* XXXX May be hopelessly wrong for UTF... */
- if (!other_last)
- other_last = strpos;
- if (check == (utf8_target ? prog->float_utf8 : prog->float_substr)) {
- do_other_anchored:
- {
- char * const last = HOP3c(s, -start_shift, strbeg);
- char *last1, *last2;
- char * const saved_s = s;
- SV* must;
-
- t = s - prog->check_offset_max;
- if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
- && (!utf8_target
- || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
- && t > strpos)))
- NOOP;
- else
- t = strpos;
- t = HOP3c(t, prog->anchored_offset, strend);
- if (t < other_last) /* These positions already checked */
- t = other_last;
- last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
- if (last < last1)
- last1 = last;
- /* XXXX It is not documented what units *_offsets are in.
- We assume bytes, but this is clearly wrong.
- Meaning this code needs to be carefully reviewed for errors.
- dmq.
- */
-
- /* On end-of-str: see comment below. */
- must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
- if (must == &PL_sv_undef) {
- s = (char*)NULL;
- DEBUG_r(must = prog->anchored_utf8); /* for debug */
- }
- else
- s = fbm_instr(
- (unsigned char*)t,
- HOP3(HOP3(last1, prog->anchored_offset, strend)
- + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
- must,
- multiline ? FBMrf_MULTILINE : 0
- );
- DEBUG_EXECUTE_r({
- RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
- SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
- PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
- (s ? "Found" : "Contradicts"),
- quoted, RE_SV_TAIL(must));
- });
-
-
- if (!s) {
- if (last1 >= last2) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- ", giving up...\n"));
- goto fail_finish;
- }
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- ", trying floating at offset %ld...\n",
- (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
- other_last = HOP3c(last1, prog->anchored_offset+1, strend);
- s = HOP3c(last, 1, strend);
- goto restart;
- }
- else {
- 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);
- s = saved_s;
- if (t == strpos)
- goto try_at_start;
- goto try_at_offset;
- }
- }
- }
- else { /* Take into account the floating substring. */
- char *last, *last1;
- char * const saved_s = s;
- SV* must;
-
- t = HOP3c(s, -start_shift, strbeg);
- last1 = last =
- HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
- if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
- last = HOP3c(t, prog->float_max_offset, strend);
- s = HOP3c(t, prog->float_min_offset, strend);
- if (s < other_last)
- s = other_last;
- /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
- must = utf8_target ? prog->float_utf8 : prog->float_substr;
- /* fbm_instr() takes into account exact value of end-of-str
- if the check is SvTAIL(ed). Since false positives are OK,
- 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 */
- }
- else
- s = fbm_instr((unsigned char*)s,
- (unsigned char*)last + SvCUR(must)
- - (SvTAIL(must)!=0),
- must, multiline ? FBMrf_MULTILINE : 0);
- DEBUG_EXECUTE_r({
- RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
- SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
- PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
- (s ? "Found" : "Contradicts"),
- quoted, RE_SV_TAIL(must));
- });
- if (!s) {
- if (last1 == last) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- ", giving up...\n"));
- goto fail_finish;
- }
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- ", trying anchored starting at offset %ld...\n",
- (long)(saved_s + 1 - i_strpos)));
- other_last = last;
- s = HOP3c(t, 1, strend);
- goto restart;
- }
- else {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
- (long)(s - i_strpos)));
- other_last = s; /* Fix this later. --Hugo */
- s = saved_s;
- if (t == strpos)
- goto try_at_start;
- goto try_at_offset;
- }
- }
+ char *last, *last1;
+ char *s;
+ SV* must;
+ struct reg_substr_datum *other;
+
+ do_other_substr:
+ other = &prog->substrs->data[other_ix];
+
+ /* if "other" is anchored:
+ * we've previously found a floating substr starting at check_at.
+ * This means that the regex origin must lie somewhere
+ * between min (rx_origin): HOP3(check_at, -check_offset_max)
+ * and max: HOP3(check_at, -check_offset_min)
+ * (except that min will be >= strpos)
+ * So the fixed substr must lie somewhere between
+ * HOP3(min, anchored_offset)
+ * HOP3(max, anchored_offset) + SvCUR(substr)
+ */
+
+ /* if "other" is floating
+ * Calculate last1, the absolute latest point where the
+ * floating substr could start in the string, ignoring any
+ * constraints from the earlier fixed match. It is calculated
+ * as follows:
+ *
+ * strend - prog->minlen (in chars) is the absolute latest
+ * position within the string where the origin of the regex
+ * could appear. The latest start point for the floating
+ * substr is float_min_offset(*) on from the start of the
+ * regex. last1 simply combines thee two offsets.
+ *
+ * (*) You might think the latest start point should be
+ * float_max_offset from the regex origin, and technically
+ * you'd be correct. However, consider
+ * /a\d{2,4}bcd\w/
+ * Here, float min, max are 3,5 and minlen is 7.
+ * This can match either
+ * /a\d\dbcd\w/
+ * /a\d\d\dbcd\w/
+ * /a\d\d\d\dbcd\w/
+ * In the first case, the regex matches minlen chars; in the
+ * second, minlen+1, in the third, minlen+2.
+ * In the first case, the floating offset is 3 (which equals
+ * float_min), in the second, 4, and in the third, 5 (which
+ * equals float_max). In all cases, the floating string bcd
+ * can never start more than 4 chars from the end of the
+ * string, which equals minlen - float_min. As the substring
+ * starts to match more than float_min from the start of the
+ * regex, it makes the regex match more than minlen chars,
+ * and the two cancel each other out. So we can always use
+ * float_min - minlen, rather than float_max - minlen for the
+ * latest position in the string.
+ *
+ * Note that -minlen + float_min_offset is equivalent (AFAIKT)
+ * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift
+ */
+
+ assert(prog->minlen >= other->min_offset);
+ last1 = HOP3c(strend,
+ other->min_offset - prog->minlen, strbeg);
+
+ if (other_ix) {/* i.e. if (other-is-float) */
+ /* last is the latest point where the floating substr could
+ * start, *given* any constraints from the earlier fixed
+ * match. This constraint is that the floating string starts
+ * <= float_max_offset chars from the regex origin (rx_origin).
+ * If this value is less than last1, use it instead.
+ */
+ assert(rx_origin <= last1);
+ last =
+ /* this condition handles the offset==infinity case, and
+ * is a short-cut otherwise. Although it's comparing a
+ * byte offset to a char length, it does so in a safe way,
+ * since 1 char always occupies 1 or more bytes,
+ * so if a string range is (last1 - rx_origin) bytes,
+ * it will be less than or equal to (last1 - rx_origin)
+ * chars; meaning it errs towards doing the accurate HOP3
+ * rather than just using last1 as a short-cut */
+ (last1 - rx_origin) < other->max_offset
+ ? last1
+ : (char*)HOP3lim(rx_origin, other->max_offset, last1);
+ }
+ else {
+ assert(strpos + start_shift <= check_at);
+ last = HOP4c(check_at, other->min_offset - start_shift,
+ strbeg, strend);
+ }
+
+ s = HOP3c(rx_origin, other->min_offset, strend);
+ if (s < other_last) /* These positions already checked */
+ s = other_last;
+
+ must = utf8_target ? other->utf8_substr : other->substr;
+ assert(SvPOK(must));
+ s = fbm_instr(
+ (unsigned char*)s,
+ (unsigned char*)last + SvCUR(must) - (SvTAIL(must)!=0),
+ must,
+ multiline ? FBMrf_MULTILINE : 0
+ );
+ DEBUG_EXECUTE_r({
+ RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
+ SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
+ PerlIO_printf(Perl_debug_log, " %s %s substr %s%s",
+ s ? "Found" : "Contradicts",
+ other_ix ? "floating" : "anchored",
+ quoted, RE_SV_TAIL(must));
+ });
+
+
+ if (!s) {
+ /* last1 is latest possible substr location. If we didn't
+ * find it before there, we never will */
+ if (last >= last1) {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ ", giving up...\n"));
+ goto fail_finish;
+ }
+
+ /* try to find the check substr again at a later
+ * position. Maybe next time we'll find the "other" substr
+ * in range too */
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ ", trying %s at offset %ld...\n",
+ (other_ix ? "floating" : "anchored"),
+ (long)(HOP3c(check_at, 1, strend) - strpos)));
+
+ other_last = HOP3c(last, 1, strend) /* highest failure */;
+ rx_origin =
+ other_ix /* i.e. if other-is-float */
+ ? HOP3c(rx_origin, 1, strend)
+ : HOP4c(last, 1 - other->min_offset, strbeg, strend);
+ goto restart;
+ }
+ else {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
+ (long)(s - strpos)));
+
+ if (other_ix) { /* if (other-is-float) */
+ /* other_last is set to s, not s+1, since its possible for
+ * a floating substr to fail first time, then succeed
+ * second time at the same floating position; e.g.:
+ * "-AB--AABZ" =~ /\wAB\d*Z/
+ * The first time round, anchored and float match at
+ * "-(AB)--AAB(Z)" then fail on the initial \w character
+ * class. Second time round, they match at "-AB--A(AB)(Z)".
+ */
+ other_last = s;
+ }
+ else {
+ rx_origin = HOP3c(s, -other->min_offset, strbeg);
+ other_last = HOP3c(s, 1, strend);
+ }
+ }
+ }
+ else {
+ DEBUG_OPTIMISE_MORE_r(
+ PerlIO_printf(Perl_debug_log,
+ " Check-only match: offset min:%"IVdf" max:%"IVdf
+ " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf
+ " strend-strpos:%"IVdf"\n",
+ (IV)prog->check_offset_min,
+ (IV)prog->check_offset_max,
+ (IV)(check_at-strpos),
+ (IV)(rx_origin-strpos),
+ (IV)(rx_origin-check_at),
+ (IV)(strend-strpos)
+ )
+ );
}
-
- t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
-
- DEBUG_OPTIMISE_MORE_r(
- PerlIO_printf(Perl_debug_log,
- "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
- (IV)prog->check_offset_min,
- (IV)prog->check_offset_max,
- (IV)(s-strpos),
- (IV)(t-strpos),
- (IV)(t-s),
- (IV)(strend-strpos)
- )
- );
+ postprocess_substr_matches:
+
+ /* handle the extra constraint of /^/m */
- if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
- && (!utf8_target
- || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
- && t > strpos)))
+ if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n'
+ /* May be due to an implicit anchor of m{.*foo} */
+ && !(prog->intflags & PREGf_IMPLICIT))
{
+ char *s;
+
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " looking for /^/m anchor"));
+
+ /* we have failed the constraint of a \n before rx_origin.
+ * Find the next \n, if any, even if it's beyond the current
+ * anchored and/or floating substrings. Whether we should be
+ * scanning ahead for the next \n or the next substr is debatable.
+ * On the one hand you'd expect rare substrings to appear less
+ * often than \n's. On the other hand, searching for \n means
+ * we're effectively flipping been check_substr and "\n" on each
+ * iteration as the current "rarest" string candidate, which
+ * means for example that we'll quickly reject the whole string if
+ * hasn't got a \n, rather than trying every substr position
+ * first
+ */
+
+ s = HOP3c(strend, - prog->minlen, strpos);
+ if (s <= rx_origin ||
+ ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
+ {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " Did not find /%s^%s/m...\n",
+ PL_colors[0], PL_colors[1]));
+ goto fail_finish;
+ }
+
+ /* earliest possible origin is 1 char after the \n.
+ * (since *rx_origin == '\n', it's safe to ++ here rather than
+ * HOP(rx_origin, 1)) */
+ rx_origin++;
+
+ if (prog->substrs->check_ix == 0 /* check is anchored */
+ || rx_origin >= HOP3c(check_at, - prog->check_offset_min, strpos))
+ {
+ /* Position contradicts check-string; either because
+ * check was anchored (and thus has no wiggle room),
+ * or check was float and rx_origin is above the float range */
+ 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)(rx_origin - strpos)));
+ goto restart;
+ }
+
+ /* if we get here, the check substr must have been float,
+ * is in range, and we may or may not have had an anchored
+ * "other" substr which still contradicts */
+ assert(prog->substrs->check_ix); /* check is float */
+
+ if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
+ /* whoops, the anchored "other" substr exists, so we still
+ * contradict. On the other hand, the float "check" substr
+ * didn't contradict, so just retry the anchored "other"
+ * substr */
+ 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)(rx_origin - strpos),
+ (long)(rx_origin - strpos + prog->anchored_offset)));
+ goto do_other_substr;
+ }
+
+ /* success: we don't contradict the found floating substring
+ * (and there's no anchored substr). */
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " Found /%s^%s/m at offset %ld...\n",
+ PL_colors[0], PL_colors[1], (long)(rx_origin - strpos)));
+ }
+ else {
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " Starting position does not contradict /%s^%s/m...\n",
+ PL_colors[0], PL_colors[1]));
+ }
+
+
+ /* Decide whether using the substrings helped */
+
+ if (rx_origin != strpos) {
/* Fixed substring is found far enough so that the match
cannot start at strpos. */
- try_at_offset:
- if (ml_anch && t[-1] != '\n') {
- /* Eventually fbm_*() should handle this, but often
- anchored_offset is not 0, so this check will not be wasted. */
- /* XXXX In the code below we prefer to look for "^" even in
- presence of anchored substrings. And we search even
- beyond the found float position. These pessimizations
- are historical artefacts only. */
- find_anchor:
- while (t < strend - prog->minlen) {
- if (*t == '\n') {
- if (t < check_at - prog->check_offset_min) {
- if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
- /* 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
- is float. Redo checking for "other"=="fixed".
- */
- strpos = t + 1;
- 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_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_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_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_EXECUTE_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:
+
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n"));
++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
}
else {
- no optimization of calling REx engine can be performed,
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 && (strpos != strbeg) && strpos[-1] != '\n'
- /* May be due to an implicit anchor of m{.*foo} */
- && !(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]);
- );
success_at_start:
if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
&& (utf8_target ? (
)))
{
/* If flags & SOMETHING - do not do it many times on the same match */
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n"));
/* XXX Does the destruction order has to change with utf8_target? */
SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
prog->check_substr = prog->check_utf8 = NULL; /* disable */
prog->float_substr = prog->float_utf8 = NULL; /* clear */
check = NULL; /* abort */
- s = strpos;
/* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag
see http://bugs.activestate.com/show_bug.cgi?id=87173 */
- if (prog->intflags & PREGf_IMPLICIT)
- prog->extflags &= ~RXf_ANCH_MBOL;
+ if (prog->intflags & PREGf_IMPLICIT) {
+ prog->intflags &= ~PREGf_ANCH_MBOL;
+ /* maybe we have no anchors left after this... */
+ if (!(prog->intflags & PREGf_ANCH))
+ prog->extflags &= ~RXf_IS_ANCHORED;
+ }
/* XXXX This is a remnant of the old implementation. It
looks wasteful, since now INTUIT can use many
other heuristics. */
prog->extflags &= ~RXf_USE_INTUIT;
/* XXXX What other flags might need to be cleared in this branch? */
}
- else
- s = strpos;
}
/* Last resort... */
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;
- accidentally, minlen >= 1 guaranties no false positives at s + 1
+ Since minlen is already taken into account, rx_origin+1 is before strend;
+ accidentally, minlen >= 1 guaranties no false positives at rx_origin + 1
even for \b or \B. But (minlen? 1 : 0) below assumes that
regstclass does not come from lookahead... */
/* If regstclass takes bytelength more than 1: If charlength==1, OK.
This leaves EXACTF-ish only, which are dealt with in find_byclass(). */
const U8* const str = (U8*)STRING(progi->regstclass);
+ char *t;
+
/* XXX this value could be pre-computed */
const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
? (reginfo->is_utf8_pat
: STR_LEN(progi->regstclass))
: 1);
char * endpos;
+ char *s = rx_origin;
if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
else if (prog->float_substr || prog->float_utf8)
if (checked_upto < s)
checked_upto = s;
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
- (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ " looking for class: start_shift: %"IVdf" check_at: %"IVdf
+ " s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
+ (IV)start_shift, (IV)(check_at - strbeg),
+ (IV)(s - strbeg), (IV)(endpos - strbeg),
+ (IV)(checked_upto- strbeg)));
t = s;
s = find_byclass(prog, progi->regstclass, checked_upto, endpos,
#endif
if (endpos == strend) {
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
- "Could not match STCLASS...\n") );
+ " Could not match STCLASS...\n") );
goto fail;
}
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
- "This position contradicts STCLASS...\n") );
- if ((prog->extflags & RXf_ANCH) && !ml_anch)
+ " This position contradicts STCLASS...\n") );
+ if ((prog->intflags & PREGf_ANCH) && !ml_anch)
goto fail;
checked_upto = HOPBACKc(endpos, start_shift);
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
(IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
/* Contradict one of substrings */
if (prog->anchored_substr || prog->anchored_utf8) {
if (s + start_shift + end_shift > strend) {
/* XXXX Should be taken into account earlier? */
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
- "Could not match STCLASS...\n") );
+ " Could not match STCLASS...\n") );
goto fail;
}
+ rx_origin = s;
if (!check)
goto giveup;
DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
- "Looking for %s substr starting at offset %ld...\n",
- what, (long)(s + start_shift - i_strpos)) );
+ " Looking for %s substr starting at offset %ld...\n",
+ what, (long)(rx_origin + start_shift - strpos)) );
goto restart;
}
/* Have both, check_string is floating */
if (t + start_shift >= check_at) /* Contradicts floating=check */
goto retry_floating_check;
/* Recheck anchored substring, but not floating... */
- s = check_at;
- if (!check)
+ if (!check) {
+ rx_origin = NULL;
goto giveup;
+ }
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;
+ " Looking for anchored substr starting at offset %ld...\n",
+ (long)(other_last - strpos)) );
+ assert(prog->substrs->check_ix); /* other is float */
+ goto do_other_substr;
}
/* Another way we could have checked stclass at the
current position only: */
if (ml_anch) {
- s = t = t + 1;
+ s = rx_origin = t + 1;
if (!check)
goto giveup;
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;
+ " Looking for /%s^%s/m starting at offset %ld...\n",
+ PL_colors[0], PL_colors[1],
+ (long)(rx_origin - strpos)) );
+ /* XXX DAPM I don't yet know why this is true, but the code
+ * assumed it when it used to do goto try_at_offset */
+ assert(rx_origin != strpos);
+ goto postprocess_substr_matches;
}
if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
goto fail;
}
if (t != s) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "By STCLASS: moving %ld --> %ld\n",
- (long)(t - i_strpos), (long)(s - i_strpos))
+ " By STCLASS: moving %ld --> %ld\n",
+ (long)(t - strpos), (long)(s - strpos))
);
}
else {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
- "Does not contradict STCLASS...\n");
+ " Does not contradict STCLASS...\n");
);
}
}
giveup:
- 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;
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Intuit: %s%s:%s match at offset %ld\n",
+ PL_colors[4], (check ? "Successfully guessed" : "Giving up"),
+ PL_colors[5], (long)(rx_origin - strpos)) );
+ return rx_origin;
fail_finish: /* Substring not found */
if (prog->check_substr || prog->check_utf8) /* could be removed already */
: (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold))
#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
-STMT_START { \
+STMT_START { \
STRLEN skiplen; \
- U8 flags = FOLD_FLAGS_FULL; \
+ U8 flags = FOLD_FLAGS_FULL; \
switch (trie_type) { \
- case trie_utf8_exactfa_fold: \
- flags |= FOLD_FLAGS_NOMIX_ASCII; \
- /* FALL THROUGH */ \
+ case trie_utf8_exactfa_fold: \
+ flags |= FOLD_FLAGS_NOMIX_ASCII; \
+ /* FALL THROUGH */ \
case trie_utf8_fold: \
if ( foldlen>0 ) { \
uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
uscan += len; \
len=0; \
} else { \
- uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags, NULL); \
+ uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags); \
len = UTF8SKIP(uc); \
skiplen = UNISKIP( uvc ); \
foldlen -= skiplen; \
uscan = foldbuf + skiplen; \
} \
break; \
- case trie_latin_utf8_exactfa_fold: \
- flags |= FOLD_FLAGS_NOMIX_ASCII; \
- /* FALL THROUGH */ \
+ case trie_latin_utf8_exactfa_fold: \
+ flags |= FOLD_FLAGS_NOMIX_ASCII; \
+ /* FALL THROUGH */ \
case trie_latin_utf8_fold: \
if ( foldlen>0 ) { \
uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
len=0; \
} else { \
len = 1; \
- uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags); \
+ uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags); \
skiplen = UNISKIP( uvc ); \
foldlen -= skiplen; \
uscan = foldbuf + skiplen; \
tmp = 1; \
)
-#define REXEC_FBC_TRYIT \
+#define REXEC_FBC_TRYIT \
if ((reginfo->intuit || regtry(reginfo, &s))) \
goto got_it
#define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \
- if (utf8_target) { \
+ if (utf8_target) { \
REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
} \
else { \
REXEC_FBC_CLASS_SCAN(CoNd); \
}
-#define DUMP_EXEC_POS(li,s,doutf8) \
+#define DUMP_EXEC_POS(li,s,doutf8) \
dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
startpos, doutf8)
-#define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
+#define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
tmp = TEST_NON_UTF8(tmp); \
REXEC_FBC_UTF8_SCAN( \
- if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
+ if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
tmp = !tmp; \
IF_SUCCESS; \
} \
} \
); \
-#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
+#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
if (s == reginfo->strbeg) { \
tmp = '\n'; \
} \
else { \
U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \
- tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT); \
+ tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \
+ 0, UTF8_ALLOW_DEFAULT); \
} \
tmp = TeSt1_UtF8; \
- LOAD_UTF8_CHARCLASS_ALNUM(); \
+ LOAD_UTF8_CHARCLASS_ALNUM(); \
REXEC_FBC_UTF8_SCAN( \
- if (tmp == ! (TeSt2_UtF8)) { \
+ if (tmp == ! (TeSt2_UtF8)) { \
tmp = !tmp; \
IF_SUCCESS; \
} \
* one, and compare it with the wordness of this one. If they differ, we have
* a boundary. At the beginning of the string, pretend that the previous
* character was a new-line */
-#define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
+#define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
if (utf8_target) { \
- UTF8_CODE \
+ UTF8_CODE \
} \
else { /* Not utf8 */ \
tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
} \
); \
} \
- if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s))) \
+ if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s))) \
goto got_it;
/* We know what class REx starts with. Try to find this position... */
/* We know what class it must start with. */
switch (OP(c)) {
+ case ANYOF_NON_UTF8_NON_ASCII_ALL:
+ if (! utf8_target && ! ANYOF_FLAGS(c)) {
+ REXEC_FBC_CLASS_SCAN(! isASCII((U8) *s)
+ || REGINCLASS(prog, c, (U8*)s));
+ break;
+ }
+
+ /* FALL THROUGH */
case ANYOF:
- case ANYOF_SYNTHETIC:
- case ANYOF_WARN_SUPER:
if (utf8_target) {
REXEC_FBC_UTF8_CLASS_SCAN(
- reginclass(prog, c, (U8*)s, utf8_target));
+ reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target));
}
else {
REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
goto do_exactf_non_utf8;
case EXACTFL:
- if (is_utf8_pat || utf8_target) {
- utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
+ if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) {
+ utf8_fold_flags = FOLDEQ_LOCALE;
goto do_exactf_utf8;
}
fold_array = PL_fold_locale;
if (! PL_utf8_swash_ptrs[classnum]) {
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
PL_utf8_swash_ptrs[classnum] =
- _core_swash_init("utf8", swash_property_names[classnum],
- &PL_sv_undef, 1, 0, NULL, &flags);
+ _core_swash_init("utf8",
+ "",
+ &PL_sv_undef, 1, 0,
+ PL_XPosix_ptrs[classnum], &flags);
}
/* This is a copy of the loop above for swash classes, though using the
startpos = stringarg;
- if (prog->extflags & RXf_GPOS_SEEN) {
+ if (prog->intflags & PREGf_GPOS_SEEN) {
MAGIC *mg;
/* set reginfo->ganch, the position where \G can match */
* to the start of the string, e.g. /w+\G/
*/
- if (prog->extflags & RXf_ANCH_GPOS) {
+ if (prog->intflags & PREGf_ANCH_GPOS) {
startpos = reginfo->ganch - prog->gofs;
if (startpos <
((flags & REXEC_FAIL_ON_UNDERFLOW) ? stringarg : strbeg))
else
startpos -= prog->gofs;
}
- else if (prog->extflags & RXf_GPOS_FLOAT)
+ else if (prog->intflags & PREGf_GPOS_FLOAT)
startpos = strbeg;
}
&& (s < stringarg))
{
/* this should only be possible under \G */
- assert(prog->extflags & RXf_GPOS_SEEN);
+ assert(prog->intflags & PREGf_GPOS_SEEN);
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
goto phooey;
Not newSVsv, either, as it does not COW.
*/
reginfo->sv = newSV(0);
- sv_setsv(reginfo->sv, sv);
+ SvSetSV_nosteal(reginfo->sv, sv);
SAVEFREESV(reginfo->sv);
}
/* Simplest case: anchored match need be tried only once. */
/* [unless only anchor is BOL and multiline is set] */
- if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
+ if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
if (s == startpos && regtry(reginfo, &s))
goto got_it;
- else if (multiline || (prog->intflags & PREGf_IMPLICIT)
- || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
+ else if (multiline || (prog->intflags & (PREGf_IMPLICIT | PREGf_ANCH_MBOL))) /* XXXX SBOL? */
{
char *end;
} /* end search for newline */
} /* end anchored/multiline check string search */
goto phooey;
- } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
+ } else if (prog->intflags & PREGf_ANCH_GPOS)
{
+ /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
+ assert(prog->intflags & PREGf_GPOS_SEEN);
/* For anchored \G, the only position it can match from is
* (ganch-gofs); we already set startpos to this above; if intuit
* moved us on from there, we can't possibly succeed */
dontbother = 0;
strend = HOPc(strend, -dontbother);
while ( (s <= last) &&
- (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
+ (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend),
(unsigned char*)strend, must,
multiline ? FBMrf_MULTILINE : 0)) ) {
DEBUG_EXECUTE_r( did_match = 1 );
&& (prog->offs[0].start < stringarg - strbeg))
{
/* this should only be possible under \G */
- assert(prog->extflags & RXf_GPOS_SEEN);
+ assert(prog->intflags & PREGf_GPOS_SEEN);
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
goto phooey;
/* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
* Do inc before dec, in case old and new rex are the same */
-#define SET_reg_curpm(Re2) \
+#define SET_reg_curpm(Re2) \
if (reginfo->info_aux_eval) { \
(void)ReREFCNT_inc(Re2); \
ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \
#define DEBUG_STATE_pp(pp) \
DEBUG_STATE_r({ \
- DUMP_EXEC_POS(locinput, scan, utf8_target); \
+ DUMP_EXEC_POS(locinput, scan, utf8_target); \
PerlIO_printf(Perl_debug_log, \
" %*s"pp" %s%s%s%s%s\n", \
depth*2, "", \
- PL_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" : ""), \
dVAR;
U8 *pat = (U8*)STRING(text_node);
+ U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
if (OP(text_node) == EXACT) {
c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
}
}
- else /* an EXACTFish node */
- if ((is_utf8_pat
- && is_MULTI_CHAR_FOLD_utf8_safe(pat,
- pat + STR_LEN(text_node)))
- || (!is_utf8_pat
- && is_MULTI_CHAR_FOLD_latin1_safe(pat,
- pat + STR_LEN(text_node))))
- {
- /* Multi-character folds require more context to sort out. Also
- * PL_utf8_foldclosures used below doesn't handle them, so have to be
- * handled outside this routine */
- use_chrtest_void = TRUE;
- }
- else { /* an EXACTFish node which doesn't begin with a multi-char fold */
- c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
- if (c1 > 256) {
- /* Load the folds hash, if not already done */
- SV** listp;
- if (! PL_utf8_foldclosures) {
- if (! PL_utf8_tofold) {
- U8 dummy[UTF8_MAXBYTES_CASE+1];
-
- /* Force loading this by folding an above-Latin1 char */
- to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
- assert(PL_utf8_tofold); /* Verify that worked */
+ else { /* an EXACTFish node */
+ U8 *pat_end = pat + STR_LEN(text_node);
+
+ /* An EXACTFL node has at least some characters unfolded, because what
+ * they match is not known until now. So, now is the time to fold
+ * the first few of them, as many as are needed to determine 'c1' and
+ * 'c2' later in the routine. If the pattern isn't UTF-8, we only need
+ * to fold if in a UTF-8 locale, and then only the Sharp S; everything
+ * else is 1-1 and isn't assumed to be folded. In a UTF-8 pattern, we
+ * need to fold as many characters as a single character can fold to,
+ * so that later we can check if the first ones are such a multi-char
+ * fold. But, in such a pattern only locale-problematic characters
+ * aren't folded, so we can skip this completely if the first character
+ * in the node isn't one of the tricky ones */
+ if (OP(text_node) == EXACTFL) {
+
+ if (! is_utf8_pat) {
+ if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S)
+ {
+ folded[0] = folded[1] = 's';
+ pat = folded;
+ pat_end = folded + 2;
}
- PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
}
+ else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) {
+ U8 *s = pat;
+ U8 *d = folded;
+ int i;
+
+ for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) {
+ if (isASCII(*s)) {
+ *(d++) = (U8) toFOLD_LC(*s);
+ s++;
+ }
+ else {
+ STRLEN len;
+ _to_utf8_fold_flags(s,
+ d,
+ &len,
+ FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE);
+ d += len;
+ s += UTF8SKIP(s);
+ }
+ }
- /* The fold closures data structure is a hash with the keys being
- * the UTF-8 of every character that is folded to, like 'k', and
- * the values each an array of all code points that fold to its
- * key. e.g. [ 'k', 'K', KELVIN_SIGN ]. Multi-character folds are
- * not included */
- if ((! (listp = hv_fetch(PL_utf8_foldclosures,
- (char *) pat,
- UTF8SKIP(pat),
- FALSE))))
- {
- /* Not found in the hash, therefore there are no folds
- * containing it, so there is only a single character that
- * could match */
- c2 = c1;
+ pat = folded;
+ pat_end = d;
}
- else { /* Does participate in folds */
- AV* list = (AV*) *listp;
- if (av_len(list) != 1) {
+ }
- /* If there aren't exactly two folds to this, it is outside
- * the scope of this function */
- use_chrtest_void = TRUE;
- }
- else { /* There are two. Get them */
- SV** c_p = av_fetch(list, 0, FALSE);
- if (c_p == NULL) {
- Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8(pat))
+ || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1(pat)))
+ {
+ /* Multi-character folds require more context to sort out. Also
+ * PL_utf8_foldclosures used below doesn't handle them, so have to
+ * be handled outside this routine */
+ use_chrtest_void = TRUE;
+ }
+ else { /* an EXACTFish node which doesn't begin with a multi-char fold */
+ c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
+ if (c1 > 256) {
+ /* Load the folds hash, if not already done */
+ SV** listp;
+ if (! PL_utf8_foldclosures) {
+ if (! PL_utf8_tofold) {
+ U8 dummy[UTF8_MAXBYTES_CASE+1];
+
+ /* Force loading this by folding an above-Latin1 char */
+ to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
+ assert(PL_utf8_tofold); /* Verify that worked */
}
- c1 = SvUV(*c_p);
+ PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
+ }
+
+ /* The fold closures data structure is a hash with the keys
+ * being the UTF-8 of every character that is folded to, like
+ * 'k', and the values each an array of all code points that
+ * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ].
+ * Multi-character folds are not included */
+ if ((! (listp = hv_fetch(PL_utf8_foldclosures,
+ (char *) pat,
+ UTF8SKIP(pat),
+ FALSE))))
+ {
+ /* Not found in the hash, therefore there are no folds
+ * containing it, so there is only a single character that
+ * could match */
+ c2 = c1;
+ }
+ else { /* Does participate in folds */
+ AV* list = (AV*) *listp;
+ if (av_len(list) != 1) {
- c_p = av_fetch(list, 1, FALSE);
- if (c_p == NULL) {
- Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ /* If there aren't exactly two folds to this, it is
+ * outside the scope of this function */
+ use_chrtest_void = TRUE;
}
- c2 = SvUV(*c_p);
-
- /* Folds that cross the 255/256 boundary are forbidden if
- * EXACTFL, or EXACTFA and one is ASCIII. Since the
- * pattern character is above 256, and its only other match
- * is below 256, the only legal match will be to itself.
- * We have thrown away the original, so have to compute
- * which is the one above 255 */
- if ((c1 < 256) != (c2 < 256)) {
- if (OP(text_node) == EXACTFL
- || ((OP(text_node) == EXACTFA
- || OP(text_node) == EXACTFA_NO_TRIE)
- && (isASCII(c1) || isASCII(c2))))
- {
- if (c1 < 256) {
- c1 = c2;
- }
- else {
- c2 = c1;
+ else { /* There are two. Get them */
+ SV** c_p = av_fetch(list, 0, FALSE);
+ if (c_p == NULL) {
+ Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ }
+ c1 = SvUV(*c_p);
+
+ c_p = av_fetch(list, 1, FALSE);
+ if (c_p == NULL) {
+ Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
+ }
+ c2 = SvUV(*c_p);
+
+ /* Folds that cross the 255/256 boundary are forbidden
+ * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
+ * one is ASCIII. Since the pattern character is above
+ * 256, and its only other match is below 256, the only
+ * legal match will be to itself. We have thrown away
+ * the original, so have to compute which is the one
+ * above 255 */
+ if ((c1 < 256) != (c2 < 256)) {
+ if ((OP(text_node) == EXACTFL
+ && ! IN_UTF8_CTYPE_LOCALE)
+ || ((OP(text_node) == EXACTFA
+ || OP(text_node) == EXACTFA_NO_TRIE)
+ && (isASCII(c1) || isASCII(c2))))
+ {
+ if (c1 < 256) {
+ c1 = c2;
+ }
+ else {
+ c2 = c1;
+ }
}
}
}
}
}
- }
- else /* Here, c1 is < 255 */
- if (utf8_target
- && HAS_NONLATIN1_FOLD_CLOSURE(c1)
- && OP(text_node) != EXACTFL
- && ((OP(text_node) != EXACTFA
- && OP(text_node) != EXACTFA_NO_TRIE)
- || ! isASCII(c1)))
- {
- /* Here, there could be something above Latin1 in the target which
- * folds to this character in the pattern. All such cases except
- * LATIN SMALL LETTER Y WITH DIAERESIS have more than two characters
- * involved in their folds, so are outside the scope of this
- * function */
- if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
- c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
- }
- else {
- use_chrtest_void = TRUE;
+ else /* Here, c1 is < 255 */
+ if (utf8_target
+ && HAS_NONLATIN1_FOLD_CLOSURE(c1)
+ && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
+ && ((OP(text_node) != EXACTFA
+ && OP(text_node) != EXACTFA_NO_TRIE)
+ || ! isASCII(c1)))
+ {
+ /* Here, there could be something above Latin1 in the target
+ * which folds to this character in the pattern. All such
+ * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more
+ * than two characters involved in their folds, so are outside
+ * the scope of this function */
+ if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
+ c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
+ }
+ else {
+ use_chrtest_void = TRUE;
+ }
}
- }
- else { /* Here nothing above Latin1 can fold to the pattern character */
- switch (OP(text_node)) {
+ else { /* Here nothing above Latin1 can fold to the pattern
+ character */
+ switch (OP(text_node)) {
- case EXACTFL: /* /l rules */
- c2 = PL_fold_locale[c1];
- break;
+ case EXACTFL: /* /l rules */
+ c2 = PL_fold_locale[c1];
+ break;
- case EXACTF: /* This node only generated for non-utf8
- patterns */
- assert(! is_utf8_pat);
- if (! utf8_target) { /* /d rules */
- c2 = PL_fold[c1];
+ case EXACTF: /* This node only generated for non-utf8
+ patterns */
+ assert(! is_utf8_pat);
+ if (! utf8_target) { /* /d rules */
+ c2 = PL_fold[c1];
+ break;
+ }
+ /* FALLTHROUGH */
+ /* /u rules for all these. This happens to work for
+ * EXACTFA as nothing in Latin1 folds to ASCII */
+ case EXACTFA_NO_TRIE: /* This node only generated for
+ non-utf8 patterns */
+ assert(! is_utf8_pat);
+ /* FALL THROUGH */
+ case EXACTFA:
+ case EXACTFU_SS:
+ case EXACTFU:
+ c2 = PL_fold_latin1[c1];
break;
- }
- /* FALLTHROUGH */
- /* /u rules for all these. This happens to work for
- * EXACTFA as nothing in Latin1 folds to ASCII */
- case EXACTFA_NO_TRIE: /* This node only generated for
- non-utf8 patterns */
- assert(! is_utf8_pat);
- /* FALL THROUGH */
- case EXACTFA:
- case EXACTFU_SS:
- case EXACTFU:
- c2 = PL_fold_latin1[c1];
- break;
- default:
- Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
- assert(0); /* NOTREACHED */
+ default:
+ Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
+ assert(0); /* NOTREACHED */
+ }
}
}
}
GET_RE_DEBUG_FLAGS_DECL;
#endif
+ /* protect against undef(*^R) */
+ SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv));
+
/* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
multicall_oldcatch = 0;
multicall_cv = NULL;
RX_MATCH_TAINTED_on(reginfo->prog);
folder = foldEQ_locale;
fold_array = PL_fold_locale;
- fold_utf8_flags = FOLDEQ_UTF8_LOCALE;
+ fold_utf8_flags = FOLDEQ_LOCALE;
goto do_exactf;
case EXACTFU_SS: /* /\x{df}/iu */
s = STRING(scan);
ln = STR_LEN(scan);
- if (utf8_target || is_utf8_pat || state_num == EXACTFU_SS) {
+ if (utf8_target
+ || is_utf8_pat
+ || state_num == EXACTFU_SS
+ || (state_num == EXACTFL && IN_UTF8_CTYPE_LOCALE))
+ {
/* Either target or the pattern are utf8, or has the issue where
* the fold lengths may differ. */
const char * const l = locinput;
const U8 * const r =
reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg));
- ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
+ ln = utf8n_to_uvchr(r, (U8*) reginfo->strend - r,
+ 0, uniflags);
}
if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
ln = isWORDCHAR_uni(ln);
sayNO;
break;
+ case ANYOF_NON_UTF8_NON_ASCII_ALL:
+ if (! NEXTCHR_IS_EOS && ! utf8_target && ! ANYOF_FLAGS(scan)) {
+ if ((isASCII((U8)(*locinput))
+ && ! REGINCLASS(rex, scan, (U8*)locinput)))
+ {
+ sayNO;
+ }
+ locinput++;
+ break;
+ }
+ /* FALLTHROUGH */
case ANYOF: /* /[abc]/ */
- case ANYOF_WARN_SUPER:
if (NEXTCHR_IS_EOS)
sayNO;
if (utf8_target) {
- if (!reginclass(rex, scan, (U8*)locinput, utf8_target))
+ if (!reginclass(rex, scan, (U8*)locinput, (U8*)reginfo->strend,
+ utf8_target))
sayNO;
locinput += UTF8SKIP(locinput);
}
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
PL_utf8_swash_ptrs[classnum]
= _core_swash_init("utf8",
- swash_property_names[classnum],
- &PL_sv_undef, 1, 0, NULL, &flags);
+ "",
+ &PL_sv_undef, 1, 0,
+ PL_XPosix_ptrs[classnum], &flags);
}
if (! (to_complement
^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
folder = foldEQ_locale;
fold_array = PL_fold_locale;
type = REFFL;
- utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
+ utf8_fold_flags = FOLDEQ_LOCALE;
goto do_nref;
case NREFFA: /* /\g{name}/iaa */
RX_MATCH_TAINTED_on(reginfo->prog);
folder = foldEQ_locale;
fold_array = PL_fold_locale;
- utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
+ utf8_fold_flags = FOLDEQ_LOCALE;
goto do_ref;
case REFFA: /* /\1/iaa */
s = reginfo->strbeg + ln;
if (type != REF /* REF can do byte comparison */
- && (utf8_target || type == REFFU))
- { /* XXX handle REFFL better */
+ && (utf8_target || type == REFFU || type == REFFL))
+ {
char * limit = reginfo->strend;
/* This call case insensitively compares the entire buffer
else { /* /(??{}) */
/* if its overloaded, let the regex compiler handle
* it; otherwise extract regex, or stringify */
+ if (SvGMAGICAL(ret))
+ ret = sv_mortalcopy(ret);
if (!SvAMAGIC(ret)) {
SV *sv = ret;
if (SvROK(sv))
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_REGEXP)
re_sv = (REGEXP*) sv;
- else if (SvSMAGICAL(sv)) {
- MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
+ else if (SvSMAGICAL(ret)) {
+ MAGIC *mg = mg_find(ret, PERL_MAGIC_qr);
if (mg)
re_sv = (REGEXP *) mg->mg_obj;
}
- /* force any magic, undef warnings here */
- if (!re_sv) {
+ /* force any undef warnings here */
+ if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) {
ret = sv_mortalcopy(ret);
(void) SvPV_force_nolen(ret);
}
pm_flags);
if (!(SvFLAGS(ret)
- & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
- | SVs_GMG))) {
+ & (SVs_TEMP | SVs_GMG | SVf_ROK))
+ && (!SvPADTMP(ret) || SvREADONLY(ret))) {
/* This isn't a first class regexp. Instead, it's
caching a regexp onto an existing, Perl visible
scalar. */
SET_reg_curpm(rex_sv);
rex = ReANY(rex_sv);
rexi = RXi_GET(rex);
- regcpblow(ST.cp);
+ {
+ /* preserve $^R across LEAVE's. See Bug 121070. */
+ SV *save_sv= GvSV(PL_replgv);
+ SvREFCNT_inc(save_sv);
+ regcpblow(ST.cp); /* LEAVE in disguise */
+ sv_setsv(GvSV(PL_replgv), save_sv);
+ SvREFCNT_dec(save_sv);
+ }
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
* When popping the save stack, all these locals would be undone;
* bypass this by setting the outermost saved $^R to the latest
* value */
+ /* I dont know if this is needed or works properly now.
+ * see code related to PL_replgv elsewhere in this file.
+ * Yves
+ */
if (oreplsv != GvSV(PL_replgv))
sv_setsv(oreplsv, GvSV(PL_replgv));
}
case EXACTFL:
RXp_MATCH_TAINTED_on(prog);
- utf8_flags = FOLDEQ_UTF8_LOCALE;
+ utf8_flags = FOLDEQ_LOCALE;
goto do_exactf;
case EXACTF: /* This node only generated for non-utf8 patterns */
}
break;
}
+ case ANYOF_NON_UTF8_NON_ASCII_ALL:
+ if (! utf8_target && ! ANYOF_FLAGS(p)) {
+ while (scan < loceol
+ && (! isASCII((U8) *scan)
+ || REGINCLASS(prog, p, (U8*)scan)))
+ {
+ scan++;
+ }
+ break;
+ }
+ /* FALLTHROUGH */
case ANYOF:
- case ANYOF_WARN_SUPER:
if (utf8_target) {
while (hardcount < max
&& scan < loceol
- && reginclass(prog, p, (U8*)scan, utf8_target))
+ && reginclass(prog, p, (U8*)scan, (U8*) loceol, utf8_target))
{
scan += UTF8SKIP(scan);
hardcount++;
if (! PL_utf8_swash_ptrs[classnum]) {
U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
PL_utf8_swash_ptrs[classnum] = _core_swash_init(
- "utf8", swash_property_names[classnum],
- &PL_sv_undef, 1, 0, NULL, &flags);
+ "utf8",
+ "",
+ &PL_sv_undef, 1, 0,
+ PL_XPosix_ptrs[classnum], &flags);
}
while (hardcount < max && scan < loceol
n is the ANYOF regnode
p is the target string
+ p_end points to one byte beyond the end of the target string
utf8_target tells whether p is in UTF-8.
Returns true if matched; false otherwise.
*/
STATIC bool
-S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const bool utf8_target)
+S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const U8* const p_end, const bool utf8_target)
{
dVAR;
const char flags = ANYOF_FLAGS(n);
* UTF8_IS_INVARIANT() works even if not in UTF-8 */
if (! UTF8_IS_INVARIANT(c) && utf8_target) {
STRLEN c_len = 0;
- c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
+ c = utf8n_to_uvchr(p, p_end - p, &c_len,
(UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
| UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
/* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
if (c < 256) {
if (ANYOF_BITMAP_TEST(n, c))
match = TRUE;
- else if (flags & ANYOF_NON_UTF8_LATIN1_ALL
+ else if (OP(n) == ANYOF_NON_UTF8_NON_ASCII_ALL
&& ! utf8_target
&& ! isASCII(c))
{
match = TRUE;
}
else if (flags & ANYOF_LOCALE) {
- RXp_MATCH_TAINTED_on(prog);
-
- if ((flags & ANYOF_LOC_FOLD)
- && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
- {
- match = TRUE;
- }
- else if (ANYOF_POSIXL_TEST_ANY_SET(n)) {
+ if (flags & ANYOF_LOC_FOLD) {
+ RXp_MATCH_TAINTED_on(prog);
+ if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) {
+ match = TRUE;
+ }
+ }
+ if (! match && ANYOF_POSIXL_TEST_ANY_SET(n)) {
/* The data structure is arranged so bits 0, 2, 4, ... are set
* if the class includes the Posix character class given by
int count = 0;
int to_complement = 0;
+
+ RXp_MATCH_TAINTED_on(prog);
while (count < ANYOF_MAX) {
if (ANYOF_POSIXL_TEST(n, count)
&& to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
}
}
+ /* For /li matching and the current locale is a UTF-8 one, look at the
+ * special list, valid for just these circumstances. */
+ if (! match
+ && (flags & ANYOF_LOC_FOLD)
+ && IN_UTF8_CTYPE_LOCALE
+ && ANYOF_UTF8_LOCALE_INVLIST(n))
+ {
+ match = _invlist_contains_cp(ANYOF_UTF8_LOCALE_INVLIST(n), c);
+ }
+
/* If the bitmap didn't (or couldn't) match, and something outside the
* bitmap could match, try that. Locale nodes specify completely the
* behavior of code points in the bit map (otherwise, a utf8 target would
* positive that will be resolved when the match is done again as not part
* of the synthetic start class */
if (!match) {
- if (utf8_target && (flags & ANYOF_ABOVE_LATIN1_ALL) && c >= 256) {
+ if (c >= 256 && (flags & ANYOF_ABOVE_LATIN1_ALL)) {
match = TRUE; /* Everything above 255 matches */
}
else if (ANYOF_NONBITMAP(n)
|| (utf8_target
&& (c >=256
|| (! (flags & ANYOF_LOCALE))
- || OP(n) == ANYOF_SYNTHETIC))))
+ || is_ANYOF_SYNTHETIC(n)))))
{
SV * const sw = core_regclass_swash(prog, n, TRUE, 0);
if (sw) {
}
if (UNICODE_IS_SUPER(c)
- && OP(n) == ANYOF_WARN_SUPER
+ && (flags & ANYOF_WARN_SUPER)
&& ckWARN_d(WARN_NON_UNICODE))
{
Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
- "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", c);
+ "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c);
}
}
+#if ANYOF_INVERT != 1
+ /* Depending on compiler optimization cBOOL takes time, so if don't have to
+ * use it, don't */
+# error ANYOF_INVERT needs to be set to 1, or guarded with cBOOL below,
+#endif
+
/* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
- return cBOOL(flags & ANYOF_INVERT) ^ match;
+ return (flags & ANYOF_INVERT) ^ match;
}
STATIC U8 *
return s;
}
-#ifdef XXX_dmq
-/* there are a bunch of places where we use two reghop3's that should
- be replaced with this routine. but since thats not done yet
- we ifdef it out - dmq
-*/
STATIC U8 *
S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim)
{
}
return s;
}
-#endif
STATIC U8 *
S_reghopmaybe3(U8* s, SSize_t off, const U8* lim)
https://perl5.git.perl.org / perl5.git / blobdiff