static void restore_pos(pTHX_ void *arg);
-#define REGCP_PAREN_ELEMS 4
-#define REGCP_OTHER_ELEMS 4
+#define REGCP_PAREN_ELEMS 3
+#define REGCP_OTHER_ELEMS 3
#define REGCP_FRAME_ELEMS 1
/* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
* are needed for the regexp context stack bookkeeping. */
const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
- int p;
+ I32 p;
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGCPPUSH;
SSGROW(total_elems + REGCP_FRAME_ELEMS);
- for (p = PL_regsize; p > parenfloor; p--) {
+ DEBUG_BUFFERS_r(
+ if ((int)PL_regsize > (int)parenfloor)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs)
+ );
+ );
+ for (p = parenfloor+1; p <= (I32)PL_regsize; p++) {
/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
SSPUSHINT(rex->offs[p].end);
SSPUSHINT(rex->offs[p].start);
SSPUSHINT(rex->offs[p].start_tmp);
- SSPUSHINT(p);
DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
- " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
- (UV)p,
- (IV)rex->offs[p].start,
- (IV)rex->offs[p].start_tmp,
- (IV)rex->offs[p].end
+ " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
+ (UV)p,
+ (IV)rex->offs[p].start,
+ (IV)rex->offs[p].start_tmp,
+ (IV)rex->offs[p].end
));
}
/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
SSPUSHINT(PL_regsize);
SSPUSHINT(rex->lastparen);
SSPUSHINT(rex->lastcloseparen);
- SSPUSHPTR(PL_reginput);
SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
return retval;
(IV)(cp), (IV)PL_savestack_ix)); \
regcpblow(cp)
-STATIC char *
+STATIC void
S_regcppop(pTHX_ regexp *rex)
{
dVAR;
UV i;
- char *input;
+ U32 paren;
GET_RE_DEBUG_FLAGS_DECL;
PERL_ARGS_ASSERT_REGCPPOP;
i = SSPOPUV;
assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
- input = (char *) SSPOPPTR;
rex->lastcloseparen = SSPOPINT;
rex->lastparen = SSPOPINT;
PL_regsize = SSPOPINT;
i -= REGCP_OTHER_ELEMS;
/* Now restore the parentheses context. */
+ DEBUG_BUFFERS_r(
+ if (i || rex->lastparen + 1 <= rex->nparens)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs)
+ );
+ );
+ paren = PL_regsize;
for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
I32 tmps;
- U32 paren = (U32)SSPOPINT;
rex->offs[paren].start_tmp = SSPOPINT;
rex->offs[paren].start = SSPOPINT;
tmps = SSPOPINT;
if (paren <= rex->lastparen)
rex->offs[paren].end = tmps;
- DEBUG_BUFFERS_r(
- PerlIO_printf(Perl_debug_log,
- " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
- (UV)paren,
- (IV)rex->offs[paren].start,
- (IV)rex->offs[paren].start_tmp,
- (IV)rex->offs[paren].end,
- (paren > rex->lastparen ? "(no)" : ""));
+ DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
+ " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
+ (UV)paren,
+ (IV)rex->offs[paren].start,
+ (IV)rex->offs[paren].start_tmp,
+ (IV)rex->offs[paren].end,
+ (paren > rex->lastparen ? "(skipped)" : ""));
);
+ paren--;
}
- DEBUG_BUFFERS_r(
- if (rex->lastparen + 1 <= rex->nparens) {
- PerlIO_printf(Perl_debug_log,
- " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
- (IV)(rex->lastparen + 1), (IV)rex->nparens);
- }
- );
#if 1
/* It would seem that the similar code in regtry()
* already takes care of this, and in fact it is in
if (i > PL_regsize)
rex->offs[i].start = -1;
rex->offs[i].end = -1;
+ DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
+ " \\%"UVuf": %s ..-1 undeffing\n",
+ (UV)i,
+ (i > PL_regsize) ? "-1" : " "
+ ));
}
#endif
- return input;
+}
+
+/* restore the parens and associated vars at savestack position ix,
+ * but without popping the stack */
+
+STATIC void
+S_regcp_restore(pTHX_ regexp *rex, I32 ix)
+{
+ I32 tmpix = PL_savestack_ix;
+ PL_savestack_ix = ix;
+ regcppop(rex);
+ PL_savestack_ix = tmpix;
}
#define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
swap = prog->offs;
/* do we need a save destructor here for eval dies? */
Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(swap),
+ PTR2UV(prog->offs)
+ ));
}
if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
re_scream_pos_data d;
goto phooey;
got_it:
+ DEBUG_BUFFERS_r(
+ if (swap)
+ PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(swap)
+ );
+ );
Safefree(swap);
RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
restore_pos(aTHX_ prog);
if (swap) {
/* we failed :-( roll it back */
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
+ PTR2UV(prog),
+ PTR2UV(prog->offs),
+ PTR2UV(swap)
+ ));
Safefree(prog->offs);
prog->offs = swap;
}
}
+/* Set which rex is pointed to by PL_reg_state, handling ref counting.
+ * Do inc before dec, in case old and new rex are the same */
+#define SET_reg_curpm(Re2) \
+ if (PL_reg_state.re_state_eval_setup_done) { \
+ (void)ReREFCNT_inc(Re2); \
+ ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \
+ PM_SETRE((PL_reg_curpm), (Re2)); \
+ }
+
+
/*
- regtry - try match at specific point
*/
}
#endif
}
-#ifdef USE_ITHREADS
- /* It seems that non-ithreads works both with and without this code.
- So for efficiency reasons it seems best not to have the code
- compiled when it is not needed. */
- /* This is safe against NULLs: */
- ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
- /* PM_reg_curpm owns a reference to this regexp. */
- (void)ReREFCNT_inc(rx);
-#endif
- PM_SETRE(PL_reg_curpm, rx);
+ SET_reg_curpm(rx);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RXp_MATCH_COPIED(prog)) {
prog->subbeg = PL_bostr;
prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
}
- DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
+#ifdef DEBUGGING
+ PL_reg_starttry = *startpos;
+#endif
prog->offs[0].start = *startpos - PL_bostr;
PL_reginput = *startpos;
prog->lastparen = 0;
}
-#define SETREX(Re1,Re2) \
- if (PL_reg_state.re_state_eval_setup_done) \
- PM_SETRE((PL_reg_curpm), (Re2)); \
- Re1 = (Re2)
-
STATIC I32 /* 0 failure, 1 success */
S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
{
I32 gimme = G_SCALAR;
CV *caller_cv = NULL; /* who called us */
CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
+ CHECKPOINT runops_cp; /* savestack position before executing EVAL */
#ifdef DEBUGGING
GET_RE_DEBUG_FLAGS_DECL;
U32 charcount = 0; /* how many input chars we have matched */
U32 accepted = 0; /* have we seen any accepting states? */
- ST.B = next;
ST.jump = trie->jump;
ST.me = scan;
ST.firstpos = NULL;
for (n = rex->lastparen; n > ST.lastparen; n--)
rex->offs[n].end = -1;
rex->lastparen = n;
+ rex->lastcloseparen = ST.lastcloseparen;
}
if (!--ST.accepted) {
DEBUG_EXECUTE_r({
if ( ST.jump) {
ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
REGCP_SET(ST.cp);
}
PL_reginput = (char *)uc;
}
- scan = (ST.jump && ST.jump[ST.nextword])
- ? ST.me + ST.jump[ST.nextword]
- : ST.B;
+ scan = ST.me + ((ST.jump && ST.jump[ST.nextword])
+ ? ST.jump[ST.nextword]
+ : NEXT_OFF(ST.me));
DEBUG_EXECUTE_r({
PerlIO_printf( Perl_debug_log,
re_sv = rex_sv;
re = rex;
rei = rexi;
- (void)ReREFCNT_inc(rex_sv);
if (OP(scan)==GOSUB) {
startpoint = scan + ARG2L(scan);
ST.close_paren = ARG(scan);
struct re_save_state saved_state;
CV *newcv;
+ /* save *all* paren positions */
+ regcppush(rex, 0);
+ REGCP_SET(runops_cp);
+
/* To not corrupt the existing regex state while executing the
* eval we would normally put it on the save stack, like with
* save_re_context. However, re-evals have a weird scoping so we
PL_regeol = saved_regeol;
if (!logical) {
/* /(?{...})/ */
+ /* restore all paren positions. Note that where the
+ * return value is used, we must delay this as the
+ * returned string to be compiled may be $1 for
+ * example */
+ S_regcp_restore(aTHX_ rex, runops_cp);
sv_setsv(save_scalar(PL_replgv), ret);
break;
}
rx = (REGEXP*) sv;
} else if (SvSMAGICAL(sv)) {
mg = mg_find(sv, PERL_MAGIC_qr);
- assert(mg);
}
} else if (SvTYPE(ret) == SVt_REGEXP) {
rx = (REGEXP*) ret;
} else if (SvSMAGICAL(ret)) {
- if (SvGMAGICAL(ret)) {
- /* I don't believe that there is ever qr magic
- here. */
- assert(!mg_find(ret, PERL_MAGIC_qr));
- sv_unmagic(ret, PERL_MAGIC_qr);
- }
- else {
- mg = mg_find(ret, PERL_MAGIC_qr);
- /* testing suggests mg only ends up non-NULL for
- scalars who were upgraded and compiled in the
- else block below. In turn, this is only
- triggered in the "postponed utf8 string" tests
- in t/op/pat.t */
- }
+ mg = mg_find(ret, PERL_MAGIC_qr);
}
if (mg) {
const char *const p = SvPV(ret, len);
ret = newSVpvn_flags(p, len, SVs_TEMP);
}
- rx = CALLREGCOMP(ret, pm_flags);
+ if (rex->intflags & PREGf_USE_RE_EVAL)
+ pm_flags |= PMf_USE_RE_EVAL;
+
+ /* if we got here, it should be an engine which
+ * supports compiling code blocks and stuff */
+ assert(rex->engine && rex->engine->op_comp);
+ rx = rex->engine->op_comp(aTHX_ &ret, 1, NULL,
+ rex->engine, NULL, NULL, 0, pm_flags);
+
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY
| SVs_GMG))) {
sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
}
PL_regsize = osize;
+ /* safe to do now that any $1 etc has been
+ * interpolated into the new pattern string and
+ * compiled */
+ S_regcp_restore(aTHX_ rex, runops_cp);
}
re_sv = rx;
re = (struct regexp *)SvANY(rx);
ST.cp = regcppush(rex, 0); /* Save *all* the positions. */
REGCP_SET(ST.lastcp);
- /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
re->lastparen = 0;
re->lastcloseparen = 0;
ST.prev_rex = rex_sv;
ST.prev_curlyx = cur_curlyx;
- SETREX(rex_sv,re_sv);
+ rex_sv = re_sv;
+ SET_reg_curpm(rex_sv);
rex = re;
rexi = rei;
cur_curlyx = NULL;
}
/* logical is 1, /(?(?{...})X|Y)/ */
sw = cBOOL(SvTRUE(ret));
+ S_regcp_restore(aTHX_ rex, runops_cp);
logical = 0;
break;
}
case EVAL_AB: /* cleanup after a successful (??{A})B */
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex_sv);
- SETREX(rex_sv,ST.prev_rex);
+ rex_sv = ST.prev_rex;
+ SET_reg_curpm(rex_sv);
rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
regcpblow(ST.cp);
case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex_sv);
- SETREX(rex_sv,ST.prev_rex);
+ rex_sv = ST.prev_rex;
+ SET_reg_curpm(rex_sv);
rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
rex->offs[n].start_tmp = locinput - PL_bostr;
if (n > PL_regsize)
PL_regsize = n;
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
+ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; regsize=%"UVuf"\n",
+ PTR2UV(rex),
+ PTR2UV(rex->offs),
+ (UV)n,
+ (IV)rex->offs[n].start_tmp,
+ (UV)PL_regsize
+ ));
lastopen = n;
break;
+
+/* XXX really need to log other places start/end are set too */
+#define CLOSE_CAPTURE \
+ rex->offs[n].start = rex->offs[n].start_tmp; \
+ rex->offs[n].end = locinput - PL_bostr; \
+ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \
+ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
+ PTR2UV(rex), \
+ PTR2UV(rex->offs), \
+ (UV)n, \
+ (IV)rex->offs[n].start, \
+ (IV)rex->offs[n].end \
+ ))
+
case CLOSE:
n = ARG(scan); /* which paren pair */
- rex->offs[n].start = rex->offs[n].start_tmp;
- rex->offs[n].end = locinput - PL_bostr;
+ CLOSE_CAPTURE;
/*if (n > PL_regsize)
PL_regsize = n;*/
if (n > rex->lastparen)
if ( OP(cursor)==CLOSE ){
n = ARG(cursor);
if ( n <= lastopen ) {
- rex->offs[n].start
- = rex->offs[n].start_tmp;
- rex->offs[n].end = locinput - PL_bostr;
+ CLOSE_CAPTURE;
/*if (n > PL_regsize)
PL_regsize = n;*/
if (n > rex->lastparen)
case BRANCH: /* /(...|A|...)/ */
scan = NEXTOPER(scan); /* scan now points to inner node */
ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
ST.next_branch = next;
REGCP_SET(ST.cp);
PL_reginput = locinput;
for (n = rex->lastparen; n > ST.lastparen; n--)
rex->offs[n].end = -1;
rex->lastparen = n;
- /*dmq: rex->lastcloseparen = n; */
+ rex->lastcloseparen = ST.lastcloseparen;
scan = ST.next_branch;
/* no more branches? */
if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
ST.me = scan;
scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
+
/* if paren positive, emulate an OPEN/CLOSE around A */
if (ST.me->flags) {
U32 paren = ST.me->flags;
if (paren > PL_regsize)
PL_regsize = paren;
- if (paren > rex->lastparen)
- rex->lastparen = paren;
scan += NEXT_OFF(scan); /* Skip former OPEN. */
}
ST.A = scan;
}
if (ST.me->flags) {
- /* mark current A as captured */
+ /* emulate CLOSE: mark current A as captured */
I32 paren = ST.me->flags;
if (ST.count) {
rex->offs[paren].start
= HOPc(PL_reginput, -ST.alen) - PL_bostr;
rex->offs[paren].end = PL_reginput - PL_bostr;
- /*dmq: rex->lastcloseparen = paren; */
+ if ((U32)paren > rex->lastparen)
+ rex->lastparen = paren;
+ rex->lastcloseparen = paren;
}
else
rex->offs[paren].end = -1;
case CURLYM_B_fail: /* just failed to match a B */
REGCP_UNWIND(ST.cp);
+ rex->lastparen = ST.lastparen;
+ rex->lastcloseparen = ST.lastcloseparen;
if (ST.minmod) {
I32 max = ARG2(ST.me);
if (max != REG_INFTY && ST.count == max)
if (success) { \
rex->offs[paren].start = HOPc(locinput, -1) - PL_bostr; \
rex->offs[paren].end = locinput - PL_bostr; \
+ if (paren > rex->lastparen) \
+ rex->lastparen = paren; \
rex->lastcloseparen = paren; \
} \
- else \
+ else { \
rex->offs[paren].end = -1; \
+ rex->lastparen = ST.lastparen; \
+ rex->lastcloseparen = ST.lastcloseparen; \
+ } \
}
case STAR: /* /A*B/ where A is width 1 */
goto repeat;
case CURLYN: /* /(A){m,n}B/ where A is width 1 */
ST.paren = scan->flags; /* Which paren to set */
+ ST.lastparen = rex->lastparen;
+ ST.lastcloseparen = rex->lastcloseparen;
if (ST.paren > PL_regsize)
PL_regsize = ST.paren;
- if (ST.paren > rex->lastparen)
- rex->lastparen = ST.paren;
ST.min = ARG1(scan); /* min to match */
ST.max = ARG2(scan); /* max to match */
if (cur_eval && cur_eval->u.eval.close_paren &&
case CURLY_B_min_known_fail:
/* failed to find B in a non-greedy match where c1,c2 valid */
- if (ST.paren && ST.count)
- rex->offs[ST.paren].end = -1;
PL_reginput = locinput; /* Could be reset... */
REGCP_UNWIND(ST.cp);
case CURLY_B_min_fail:
/* failed to find B in a non-greedy match where c1,c2 invalid */
- if (ST.paren && ST.count)
- rex->offs[ST.paren].end = -1;
REGCP_UNWIND(ST.cp);
/* failed -- move forward one */
/* FALL THROUGH */
case CURLY_B_max_fail:
/* failed to find B in a greedy match */
- if (ST.paren && ST.count)
- rex->offs[ST.paren].end = -1;
REGCP_UNWIND(ST.cp);
/* back up. */
fake_end:
if (cur_eval) {
/* we've just finished A in /(??{A})B/; now continue with B */
- I32 tmpix;
st->u.eval.toggle_reg_flags
= cur_eval->u.eval.toggle_reg_flags;
PL_reg_flags ^= st->u.eval.toggle_reg_flags;
st->u.eval.prev_rex = rex_sv; /* inner */
st->u.eval.cp = regcppush(rex, 0); /* Save *all* the positions. */
- SETREX(rex_sv,cur_eval->u.eval.prev_rex);
+ rex_sv = cur_eval->u.eval.prev_rex;
+ SET_reg_curpm(rex_sv);
rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
cur_curlyx = cur_eval->u.eval.prev_curlyx;
- (void)ReREFCNT_inc(rex_sv);
REGCP_SET(st->u.eval.lastcp);
PL_reginput = locinput;
/* Restore parens of the outer rex without popping the
* savestack */
- tmpix = PL_savestack_ix;
- PL_savestack_ix = cur_eval->u.eval.lastcp;
- regcppop(rex);
- PL_savestack_ix = tmpix;
+ S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp);
st->u.eval.prev_eval = cur_eval;
cur_eval = cur_eval->u.eval.prev_eval;
https://perl5.git.perl.org / perl5.git / blobdiff