* with giant delta may be not rechecked).
*/
-/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
-
/* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
Otherwise, only SvCUR(sv) is used to get strbeg. */
-/* XXXX We assume that strpos is strbeg unless sv. */
-
/* XXXX Some places assume that there is a fixed substring.
An update may be needed if optimizer marks as "INTUITable"
RExen without fixed substrings. Similarly, it is assumed that
}
check = prog->check_substr;
}
- if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
- ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
+ if ((prog->extflags & RXf_ANCH) /* Match at beg-of-str or after \n */
+ && !(prog->extflags & RXf_ANCH_GPOS)) /* \G isn't a BOS or \n */
+ {
+ ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
|| ( (prog->extflags & RXf_ANCH_BOL)
&& !multiline ) ); /* Check after \n? */
if (!ml_anch) {
- if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
- && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
+ if ( !(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 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);
+ /* XXX this value could be pre-computed */
const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
- ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
+ ? (reginfo->is_utf8_pat
+ ? utf8_distance(str + STR_LEN(progi->regstclass), str)
+ : STR_LEN(progi->regstclass))
: 1);
char * endpos;
if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
/* set RX_SAVED_COPY, RX_SUBBEG etc.
* flags have same meanings as with regexec_flags() */
-void
-Perl_reg_set_capture_string(pTHX_ REGEXP * const rx,
+static void
+S_reg_set_capture_string(pTHX_ REGEXP * const rx,
char *strbeg,
char *strend,
SV *sv,
{
struct regexp *const prog = ReANY(rx);
- PERL_ARGS_ASSERT_REG_SET_CAPTURE_STRING;
-
if (flags & REXEC_COPY_STR) {
#ifdef PERL_ANY_COW
if (SvCANCOW(sv)) {
"Copy on write: regexp capture, type %d\n",
(int) SvTYPE(sv));
}
- RX_MATCH_COPY_FREE(rx);
- prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
- prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
- assert (SvPOKp(prog->saved_copy));
+ /* skip creating new COW SV if a valid one already exists */
+ if (! ( prog->saved_copy
+ && SvIsCOW(sv)
+ && SvPOKp(sv)
+ && SvIsCOW(prog->saved_copy)
+ && SvPOKp(prog->saved_copy)
+ && SvPVX(sv) == SvPVX(prog->saved_copy)))
+ {
+ RX_MATCH_COPY_FREE(rx);
+ prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
+ prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
+ assert (SvPOKp(prog->saved_copy));
+ }
prog->sublen = strend - strbeg;
prog->suboffset = 0;
prog->subcoffset = 0;
I32 sublen;
if ( (flags & REXEC_COPY_SKIP_POST)
- && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+ && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
&& !(PL_sawampersand & SAWAMPERSAND_RIGHT)
) { /* don't copy $' part of string */
U32 n = 0;
}
if ( (flags & REXEC_COPY_SKIP_PRE)
- && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
+ && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
&& !(PL_sawampersand & SAWAMPERSAND_LEFT)
) { /* don't copy $` part of string */
U32 n = 0;
/* sv: SV being matched: only used for utf8 flag, pos() etc; string
* itself is accessed via the pointers above */
/* data: May be used for some additional optimizations.
- Currently its only used, with a U32 cast, for transmitting
- the ganch offset when doing a /g match. This will change */
+ Currently unused. */
/* nosave: For optimizations. */
{
struct regexp *const prog = ReANY(rx);
char *s;
regnode *c;
- char *startpos = stringarg;
+ char *startpos;
I32 minlen; /* must match at least this many chars */
I32 dontbother = 0; /* how many characters not to try at end */
I32 end_shift = 0; /* Same for the end. */ /* CC */
- I32 scream_pos = -1; /* Internal iterator of scream. */
- char *scream_olds = NULL;
const bool utf8_target = cBOOL(DO_UTF8(sv));
I32 multiline;
RXi_GET_DECL(prog,progi);
PERL_UNUSED_ARG(data);
/* Be paranoid... */
- if (prog == NULL || startpos == NULL) {
+ if (prog == NULL || stringarg == NULL) {
Perl_croak(aTHX_ "NULL regexp parameter");
return 0;
}
DEBUG_EXECUTE_r(
- debug_start_match(rx, utf8_target, startpos, strend,
+ debug_start_match(rx, utf8_target, stringarg, strend,
"Matching");
);
+ startpos = stringarg;
+
+ if (prog->extflags & RXf_GPOS_SEEN) {
+ MAGIC *mg;
+
+ /* in the presence of \G, we may need to start looking earlier in
+ * the string than the suggested start point of stringarg:
+ * if gofs->prog is set, then that's a known, fixed minimum
+ * offset, such as
+ * /..\G/: gofs = 2
+ * /ab|c\G/: gofs = 1
+ * or if the minimum offset isn't known, then we have to go back
+ * to the start of the string, e.g. /w+\G/
+ */
+ if (prog->gofs) {
+ if (startpos - prog->gofs < strbeg)
+ startpos = strbeg;
+ else
+ startpos -= prog->gofs;
+ }
+ else if (prog->extflags & RXf_GPOS_FLOAT)
+ startpos = strbeg;
+
+ /* set reginfo->ganch, the position where \G can match */
+
+ reginfo->ganch =
+ (flags & REXEC_IGNOREPOS)
+ ? stringarg /* use start pos rather than pos() */
+ : (sv && (mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
+ ? strbeg + mg->mg_len /* Defined pos() */
+ : strbeg; /* pos() not defined; use start of string */
+
+ DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
+ "GPOS ganch set to strbeg[%"IVdf"]\n", reginfo->ganch - strbeg));
+ }
+
+ minlen = prog->minlen;
+ if ((startpos + minlen) > strend || startpos < strbeg) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ "Regex match can't succeed, so not even tried\n"));
+ return 0;
+ }
+
+ s = startpos;
+
+ if ((prog->extflags & RXf_USE_INTUIT)
+ && !(flags & REXEC_CHECKED))
+ {
+ s = re_intuit_start(rx, sv, strbeg, startpos, strend,
+ flags, NULL);
+ if (!s)
+ return 0;
+
+ if (prog->extflags & RXf_CHECK_ALL) {
+ /* we can match based purely on the result of INTUIT.
+ * Set up captures etc just for $& and $-[0]
+ * (an intuit-only match wont have $1,$2,..) */
+ assert(!prog->nparens);
+
+ /* s/// doesn't like it if $& is earlier than where we asked it to
+ * start searching (which can happen on something like /.\G/) */
+ if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
+ && (s < stringarg))
+ {
+ /* this should only be possible under \G */
+ assert(prog->extflags & RXf_GPOS_SEEN);
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
+ goto phooey;
+ }
+
+ /* match via INTUIT shouldn't have any captures.
+ * Let @-, @+, $^N know */
+ prog->lastparen = prog->lastcloseparen = 0;
+ RX_MATCH_UTF8_set(rx, utf8_target);
+ if ( !(flags & REXEC_NOT_FIRST) )
+ S_reg_set_capture_string(aTHX_ rx,
+ strbeg, strend,
+ sv, flags, utf8_target);
+
+ prog->offs[0].start = s - strbeg;
+ prog->offs[0].end = utf8_target
+ ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg
+ : s - strbeg + prog->minlenret;
+ return 1;
+ }
+ }
+
/* at the end of this function, we'll do a LEAVE_SCOPE(oldsave),
* which will call destuctors to reset PL_regmatch_state, free higher
oldsave = PL_savestack_ix;
multiline = prog->extflags & RXf_PMf_MULTILINE;
- minlen = prog->minlen;
- if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
+ if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
"String too short [regexec_flags]...\n"));
goto phooey;
reginfo->poscache_maxiter = 0; /* not yet started a countdown */
reginfo->strend = strend;
/* see how far we have to get to not match where we matched before */
- reginfo->till = startpos+minend;
+ reginfo->till = stringarg + minend;
if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv) && !IS_PADGV(sv)) {
/* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
}
/* If there is a "must appear" string, look for it. */
- s = startpos;
- if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
- MAGIC *mg;
- if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
- reginfo->ganch = startpos + prog->gofs;
- DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
- "GPOS IGNOREPOS: reginfo->ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
- } else if (sv && (mg = mg_find_mglob(sv))
- && mg->mg_len >= 0) {
- reginfo->ganch = strbeg + mg->mg_len; /* Defined pos() */
- DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
- "GPOS MAGIC: reginfo->ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
-
- if (prog->extflags & RXf_ANCH_GPOS) {
- if (s > reginfo->ganch)
- goto phooey;
- s = reginfo->ganch - prog->gofs;
- DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
- "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
- if (s < strbeg)
- goto phooey;
- }
- }
- else if (data) {
- reginfo->ganch = strbeg + PTR2UV(data);
- DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
- "GPOS DATA: reginfo->ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
-
- } else { /* pos() not defined */
- reginfo->ganch = strbeg;
- DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
- "GPOS: reginfo->ganch = strbeg\n"));
- }
- }
if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
/* We have to be careful. If the previous successful match
was from this regex we don't want a subsequent partially
PTR2UV(prog->offs)
));
}
- if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
- re_scream_pos_data d;
-
- d.scream_olds = &scream_olds;
- d.scream_pos = &scream_pos;
- s = re_intuit_start(rx, sv, strbeg, s, strend, flags, &d);
- if (!s) {
- DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
- goto phooey; /* not present */
- }
- }
-
-
/* 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 (s == startpos && regtry(reginfo, &startpos))
+ if (s == startpos && regtry(reginfo, &s))
goto got_it;
else if (multiline || (prog->intflags & PREGf_IMPLICIT)
|| (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
and we only enter this block when the same bit is set. */
char *tmp_s = reginfo->ganch - prog->gofs;
- if (tmp_s >= strbeg && regtry(reginfo, &tmp_s))
+ if (s <= tmp_s && regtry(reginfo, &tmp_s))
goto got_it;
goto phooey;
}
/* XXXX check_substr already used to find "s", can optimize if
check_substr==must. */
- scream_pos = -1;
dontbother = end_shift;
strend = HOPc(strend, -dontbother);
while ( (s <= last) &&
goto phooey;
got_it:
+ /* s/// doesn't like it if $& is earlier than where we asked it to
+ * start searching (which can happen on something like /.\G/) */
+ if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
+ && (prog->offs[0].start < stringarg - strbeg))
+ {
+ /* this should only be possible under \G */
+ assert(prog->extflags & RXf_GPOS_SEEN);
+ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+ "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
+ goto phooey;
+ }
+
DEBUG_BUFFERS_r(
if (swap)
PerlIO_printf(Perl_debug_log,
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) )
- Perl_reg_set_capture_string(aTHX_ rx,
+ S_reg_set_capture_string(aTHX_ rx,
strbeg, reginfo->strend,
sv, flags, utf8_target);
https://perl5.git.perl.org / perl5.git / blobdiff