I32 extralen;
I32 seen_zerolen;
I32 seen_evals;
+ regnode **parens; /* offsets of each paren */
I32 utf8;
- HV *charnames; /* cache of named sequences */
+ HV *charnames; /* cache of named sequences */
+ HV *paren_names; /* Paren names */
#if ADD_TO_REGEXEC
char *starttry; /* -Dr: where regtry was called. */
#define RExC_starttry (pRExC_state->starttry)
#define RExC_seen_evals (pRExC_state->seen_evals)
#define RExC_utf8 (pRExC_state->utf8)
#define RExC_charnames (pRExC_state->charnames)
+#define RExC_parens (pRExC_state->parens)
+#define RExC_paren_names (pRExC_state->paren_names)
#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
#endif
#define DEBUG_STUDYDATA(data,depth) \
-DEBUG_OPTIMISE_r(if(data){ \
+DEBUG_OPTIMISE_MORE_r(if(data){ \
PerlIO_printf(Perl_debug_log, \
"%*s"/* Len:%"IVdf"/%"IVdf" */" Pos:%"IVdf"/%"IVdf \
" Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \
char *str=NULL;
#ifdef DEBUGGING
-
- U32 mjd_offset;
- U32 mjd_nodelen;
+ regnode *optimize = NULL;
+ U32 mjd_offset = 0;
+ U32 mjd_nodelen = 0;
#endif
/*
This means we convert either the first branch or the first Exact,
convert = n;
} else {
NEXT_OFF(convert) = (U16)(tail - convert);
+ DEBUG_r(optimize= n);
}
}
}
+ if (!jumper)
+ jumper = last;
if ( trie->maxlen ) {
NEXT_OFF( convert ) = (U16)(tail - convert);
ARG_SET( convert, data_slot );
We use this when dumping a trie and during optimisation. */
if (trie->jump)
trie->jump[0] = (U16)(tail - nextbranch);
- if (!jumper)
- jumper = last;
+
/* XXXX */
if ( !trie->states[trie->startstate].wordnum && trie->bitmap &&
( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
/* store the type in the flags */
convert->flags = nodetype;
- /* XXX We really should free up the resource in trie now, as we wont use them */
+ DEBUG_r({
+ optimize = convert
+ + NODE_STEP_REGNODE
+ + regarglen[ OP( convert ) ];
+ });
+ /* XXX We really should free up the resource in trie now,
+ as we won't use them - (which resources?) dmq */
}
/* needed for dumping*/
- DEBUG_r({
- regnode *optimize = convert
- + NODE_STEP_REGNODE
- + regarglen[ OP( convert ) ];
+ DEBUG_r(if (optimize) {
regnode *opt = convert;
- while (++opt<optimize) {
+ while ( ++opt < optimize) {
Set_Node_Offset_Length(opt,0,0);
}
/*
}
flags &= ~SCF_DO_STCLASS;
}
+ else if (OP(scan)==RECURSE) {
+ ARG2L_SET( scan, RExC_parens[ARG(scan)-1] - scan );
+ }
else if (strchr((const char*)PL_varies,OP(scan))) {
I32 mincount, maxcount, minnext, deltanext, fl = 0;
I32 f = flags, pos_before = 0;
#else
#define CHECK_RESTUDY_GOTO
#endif
+
/*
- pregcomp - compile a regular expression into internal code
*
* Beware that the optimization-preparation code in here knows about some
* of the structure of the compiled regexp. [I'll say.]
*/
+#ifndef PERL_IN_XSUB_RE
+#define CORE_ONLY_BLOCK(c) {c}{
+#define RE_ENGINE_PTR &PL_core_reg_engine
+#else
+#define CORE_ONLY_BLOCK(c) {
+extern const struct regexp_engine my_reg_engine;
+#define RE_ENGINE_PTR &my_reg_engine
+#endif
+#define END_BLOCK }
+
regexp *
Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
{
dVAR;
+ GET_RE_DEBUG_FLAGS_DECL;
+ DEBUG_r(if (!PL_colorset) reginitcolors());
+ CORE_ONLY_BLOCK(
+ /* Dispatch a request to compile a regexp to correct
+ regexp engine. */
+ HV * const table = GvHV(PL_hintgv);
+ if (table) {
+ SV **ptr= hv_fetchs(table, "regcomp", FALSE);
+ if (ptr && SvIOK(*ptr)) {
+ const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
+ DEBUG_COMPILE_r({
+ PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
+ SvIV(*ptr));
+ });
+ return CALLREGCOMP_ENG(eng, exp, xend, pm);
+ }
+ })
register regexp *r;
regnode *scan;
regnode *first;
int restudied= 0;
RExC_state_t copyRExC_state;
#endif
-
- GET_RE_DEBUG_FLAGS_DECL;
-
if (exp == NULL)
FAIL("NULL regexp argument");
RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
RExC_precomp = exp;
- DEBUG_r(if (!PL_colorset) reginitcolors());
DEBUG_COMPILE_r({
SV *dsv= sv_newmortal();
RE_PV_QUOTED_DECL(s, RExC_utf8,
RExC_emit = &PL_regdummy;
RExC_whilem_seen = 0;
RExC_charnames = NULL;
-
+ RExC_parens = NULL;
+ RExC_paren_names = NULL;
+
#if 0 /* REGC() is (currently) a NOP at the first pass.
* Clever compilers notice this and complain. --jhi */
REGC((U8)REG_MAGIC, (char*)RExC_emit);
RExC_precomp = NULL;
return(NULL);
}
- DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Required "));
- DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" nodes ", (IV)RExC_size));
- DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nStarting second pass (creation)\n"));
DEBUG_PARSE_r({
+ PerlIO_printf(Perl_debug_log,
+ "Required size %"IVdf" nodes\n"
+ "Starting second pass (creation)\n",
+ (IV)RExC_size);
RExC_lastnum=0;
RExC_lastparse=NULL;
});
-
-
/* Small enough for pointer-storage convention?
If extralen==0, this means that we will not need long jumps. */
if (RExC_size >= 0x10000L && RExC_extralen)
if (RExC_whilem_seen > 15)
RExC_whilem_seen = 15;
- /* Allocate space and initialize. */
+ /* Allocate space and zero-initialize. Note, the two step process
+ of zeroing when in debug mode, thus anything assigned has to
+ happen after that */
Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
char, regexp);
if (r == NULL)
FAIL("Regexp out of space");
-
#ifdef DEBUGGING
/* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
#endif
+ /* initialization begins here */
+ r->engine= RE_ENGINE_PTR;
r->refcnt = 1;
r->prelen = xend - exp;
r->precomp = savepvn(RExC_precomp, r->prelen);
r->substrs = 0; /* Useful during FAIL. */
r->startp = 0; /* Useful during FAIL. */
- r->endp = 0; /* Useful during FAIL. */
+ r->endp = 0;
+ r->paren_names = 0;
+
+ if (RExC_seen & REG_SEEN_RECURSE) {
+ Newx(RExC_parens, RExC_npar,regnode *);
+ SAVEFREEPV(RExC_parens);
+ }
+ /* Useful during FAIL. */
Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
if (r->offsets) {
r->offsets[0] = RExC_size;
r->data = 0;
if (reg(pRExC_state, 0, &flags,1) == NULL)
return(NULL);
+
/* XXXX To minimize changes to RE engine we always allocate
3-units-long substrs field. */
Newx(r->substrs, 1, struct reg_substr_data);
/* testing for BRANCH here tells us whether there is "must appear"
data in the pattern. If there is then we can use it for optimisations */
- if (OP(scan) != BRANCH) { /* Only one top-level choice. */
+ if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
I32 fake;
STRLEN longest_float_length, longest_fixed_length;
struct regnode_charclass_class ch_class; /* pointed to by data */
/* Scan is after the zeroth branch, first is atomic matcher. */
#ifdef TRIE_STUDY_OPT
- DEBUG_COMPILE_r(
+ DEBUG_PARSE_r(
if (!restudied)
PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
(IV)(first - scan + 1))
);
#else
- DEBUG_COMPILE_r(
+ DEBUG_PARSE_r(
PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
(IV)(first - scan + 1))
);
r->reganch |= ROPT_EVAL_SEEN;
if (RExC_seen & REG_SEEN_CANY)
r->reganch |= ROPT_CANY_SEEN;
+ if (RExC_paren_names)
+ r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names);
+ else
+ r->paren_names = NULL;
+
Newxz(r->startp, RExC_npar, I32);
Newxz(r->endp, RExC_npar, I32);
- if (RExC_charnames)
- SvREFCNT_dec((SV*)(RExC_charnames));
-
+
DEBUG_r( RX_DEBUG_on(r) );
DEBUG_DUMP_r({
PerlIO_printf(Perl_debug_log,"Final program:\n");
PerlIO_printf(Perl_debug_log, "\n");
});
return(r);
+ END_BLOCK
}
+#undef CORE_ONLY_BLOCK
+#undef END_BLOCK
+#undef RE_ENGINE_PTR
+
+SV*
+Perl_reg_named_buff_sv(pTHX_ SV* namesv)
+{
+ I32 parno = 0; /* no match */
+ if (PL_curpm) {
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
+ if (rx && rx->paren_names) {
+ HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
+ if (he_str) {
+ IV i;
+ SV* sv_dat=HeVAL(he_str);
+ I32 *nums=(I32*)SvPVX(sv_dat);
+ for ( i=0; i<SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->startp[nums[i]] != -1 &&
+ rx->endp[nums[i]] != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ }
+ }
+ }
+ if ( !parno ) {
+ return 0;
+ } else {
+ GV *gv_paren;
+ SV *sv= sv_newmortal();
+ Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
+ gv_paren= Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
+ return GvSVn(gv_paren);
+ }
+}
+
+/* Scans the name of a named buffer from the pattern.
+ * If flags is true then returns an SV containing the name.
+ */
+STATIC SV*
+S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
+ char *name_start = RExC_parse;
+ if (UTF) {
+ STRLEN numlen;
+ while (isIDFIRST_uni(utf8n_to_uvchr((U8*)RExC_parse,
+ RExC_end - RExC_parse,
+ &numlen, UTF8_ALLOW_DEFAULT)))
+ RExC_parse += numlen;
+ }
+ else {
+ while (isIDFIRST(*RExC_parse))
+ RExC_parse++;
+ }
+ if (flags) {
+ SV* svname = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
+ (int)(RExC_parse - name_start)));
+ if (UTF)
+ SvUTF8_on(svname);
+ return svname;
+ }
+ else {
+ return NULL;
+ }
+}
#define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
int rem=(int)(RExC_end - RExC_parse); \
DEBUG_PARSE_MSG((funcname)); \
PerlIO_printf(Perl_debug_log,"%4s","\n"); \
})
+#define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
+ DEBUG_PARSE_MSG((funcname)); \
+ PerlIO_printf(Perl_debug_log,fmt "\n",args); \
+})
/*
- reg - regular expression, i.e. main body or parenthesized thing
*
paren = *RExC_parse++;
ret = NULL; /* For look-ahead/behind. */
switch (paren) {
+
case '<': /* (?<...) */
- RExC_seen |= REG_SEEN_LOOKBEHIND;
if (*RExC_parse == '!')
paren = ',';
- if (*RExC_parse != '=' && *RExC_parse != '!')
- goto unknown;
+ else if (*RExC_parse != '=') { /* (?<...>) */
+ char *name_start;
+ SV *svname;
+ paren= '>';
+ case '\'': /* (?'...') */
+ name_start= RExC_parse;
+ svname = reg_scan_name(pRExC_state,SIZE_ONLY);
+ if (RExC_parse == name_start)
+ goto unknown;
+ if (*RExC_parse != paren)
+ vFAIL2("Sequence (?%c... not terminated",
+ paren=='>' ? '<' : paren);
+ if (SIZE_ONLY) {
+ HE *he_str;
+ SV *sv_dat = NULL;
+ if (!svname) /* shouldnt happen */
+ Perl_croak(aTHX_
+ "panic: reg_scan_name returned NULL");
+ if (!RExC_paren_names) {
+ RExC_paren_names= newHV();
+ sv_2mortal((SV*)RExC_paren_names);
+ }
+ he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
+ if ( he_str )
+ sv_dat = HeVAL(he_str);
+ if ( ! sv_dat ) {
+ /* croak baby croak */
+ Perl_croak(aTHX_
+ "panic: paren_name hash element allocation failed");
+ } else if ( SvPOK(sv_dat) ) {
+ IV count=SvIV(sv_dat);
+ I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
+ SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
+ pv[count]=RExC_npar;
+ SvIVX(sv_dat)++;
+ } else {
+ (void)SvUPGRADE(sv_dat,SVt_PVNV);
+ sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
+ SvIOK_on(sv_dat);
+ SvIVX(sv_dat)= 1;
+ }
+
+ /*sv_dump(sv_dat);*/
+ }
+ nextchar(pRExC_state);
+ paren = 1;
+ goto capturing_parens;
+ }
+ RExC_seen |= REG_SEEN_LOOKBEHIND;
RExC_parse++;
case '=': /* (?=...) */
case '!': /* (?!...) */
nextchar(pRExC_state);
*flagp = TRYAGAIN;
return NULL;
+ case '0' : /* (?0) */
+ case 'R' : /* (?R) */
+ if (*RExC_parse != ')')
+ FAIL("Sequence (?R) not terminated");
+ reg_node(pRExC_state, SRECURSE);
+ break; /* (?PARNO) */
+ { /* named and numeric backreferences */
+ I32 num;
+ char * parse_start;
+ case '&': /* (?&NAME) */
+ parse_start = RExC_parse - 1;
+ {
+ char *name_start = RExC_parse;
+ SV *svname = reg_scan_name(pRExC_state, !SIZE_ONLY);
+ if (RExC_parse == name_start)
+ goto unknown;
+ if (*RExC_parse != ')')
+ vFAIL("Expecting close bracket");
+ if (!SIZE_ONLY) {
+ HE *he_str = NULL;
+ SV *sv_dat;
+ if (!svname) /* shouldn't happen*/
+ Perl_croak(aTHX_ "panic: reg_scan_name returned NULL");
+ if (RExC_paren_names)
+ he_str = hv_fetch_ent( RExC_paren_names, svname, 0, 0 );
+ if (he_str)
+ sv_dat = HeVAL(he_str);
+ else
+ vFAIL("Reference to nonexistent group");
+ num = *((I32 *)SvPVX(sv_dat));
+ } else {
+ num = 0;
+ }
+ }
+ goto gen_recurse_regop;
+ /* NOT REACHED */
+ case '1': case '2': case '3': case '4': /* (?1) */
+ case '5': case '6': case '7': case '8': case '9':
+ RExC_parse--;
+ num = atoi(RExC_parse);
+ parse_start = RExC_parse - 1; /* MJD */
+ while (isDIGIT(*RExC_parse))
+ RExC_parse++;
+ if (*RExC_parse!=')')
+ vFAIL("Expecting close bracket");
+
+ gen_recurse_regop:
+ ret = reganode(pRExC_state, RECURSE, num);
+ if (!SIZE_ONLY) {
+ if (num > (I32)RExC_rx->nparens) {
+ RExC_parse++;
+ vFAIL("Reference to nonexistent group");
+ }
+ ARG2L_SET( ret, 0);
+ RExC_emit++;
+ DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
+ "Recurse #%"UVuf" to %"IVdf"\n", ARG(ret), ARG2L(ret)));
+ } else {
+ RExC_size++;
+ RExC_seen|=REG_SEEN_RECURSE;
+ }
+ Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
+ Set_Node_Offset(ret, parse_start); /* MJD */
+
+ nextchar(pRExC_state);
+ return ret;
+ } /* named and numeric backreferences */
+ /* NOT REACHED */
+
case 'p': /* (?p...) */
if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
}
}
else { /* (...) */
+ capturing_parens:
parno = RExC_npar;
RExC_npar++;
ret = reganode(pRExC_state, OPEN, parno);
+ if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
+ DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
+ "Setting paren #%"IVdf" to %d\n", parno, REG_NODE_NUM(ret)));
+ RExC_parens[parno-1]= ret;
+
+ }
Set_Node_Length(ret, 1); /* MJD */
Set_Node_Offset(ret, RExC_parse); /* MJD */
is_open = 1;
return(NULL);
if (*RExC_parse == '|') {
if (!SIZE_ONLY && RExC_extralen) {
- reginsert(pRExC_state, BRANCHJ, br);
+ reginsert(pRExC_state, BRANCHJ, br, depth+1);
}
else { /* MJD */
- reginsert(pRExC_state, BRANCH, br);
+ reginsert(pRExC_state, BRANCH, br, depth+1);
Set_Node_Length(br, paren != 0);
Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
}
ender = reg_node(pRExC_state, END);
break;
}
- REGTAIL_STUDY(pRExC_state, lastbr, ender);
+ REGTAIL(pRExC_state, lastbr, ender);
if (have_branch && !SIZE_ONLY) {
+ if (depth==1)
+ RExC_seen |= REG_TOP_LEVEL_BRANCHES;
+
/* Hook the tails of the branches to the closing node. */
for (br = ret; br; br = regnext(br)) {
const U8 op = PL_regkind[OP(br)];
if (paren == '>')
node = SUSPEND, flag = 0;
- reginsert(pRExC_state, node,ret);
+ reginsert(pRExC_state, node,ret, depth+1);
Set_Node_Cur_Length(ret);
Set_Node_Offset(ret, parse_start + 1);
ret->flags = flag;
do_curly:
if ((flags&SIMPLE)) {
RExC_naughty += 2 + RExC_naughty / 2;
- reginsert(pRExC_state, CURLY, ret);
+ reginsert(pRExC_state, CURLY, ret, depth+1);
Set_Node_Offset(ret, parse_start+1); /* MJD */
Set_Node_Cur_Length(ret);
}
w->flags = 0;
REGTAIL(pRExC_state, ret, w);
if (!SIZE_ONLY && RExC_extralen) {
- reginsert(pRExC_state, LONGJMP,ret);
- reginsert(pRExC_state, NOTHING,ret);
+ reginsert(pRExC_state, LONGJMP,ret, depth+1);
+ reginsert(pRExC_state, NOTHING,ret, depth+1);
NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
}
- reginsert(pRExC_state, CURLYX,ret);
+ reginsert(pRExC_state, CURLYX,ret, depth+1);
/* MJD hk */
Set_Node_Offset(ret, parse_start+1);
Set_Node_Length(ret,
*flagp = flags;
return(ret);
}
+ /* else if (OP(ret)==RECURSE) {
+ RExC_parse++;
+ vFAIL("Illegal quantifier on recursion group");
+ } */
#if 0 /* Now runtime fix should be reliable. */
*flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
if (op == '*' && (flags&SIMPLE)) {
- reginsert(pRExC_state, STAR, ret);
+ reginsert(pRExC_state, STAR, ret, depth+1);
ret->flags = 0;
RExC_naughty += 4;
}
goto do_curly;
}
else if (op == '+' && (flags&SIMPLE)) {
- reginsert(pRExC_state, PLUS, ret);
+ reginsert(pRExC_state, PLUS, ret, depth+1);
ret->flags = 0;
RExC_naughty += 3;
}
if (*RExC_parse == '?') {
nextchar(pRExC_state);
- reginsert(pRExC_state, MINMOD, ret);
+ reginsert(pRExC_state, MINMOD, ret, depth+1);
REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
}
if (ISMULT2(RExC_parse)) {
| PERL_SCAN_DISALLOW_PREFIX
| (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
UV cp;
- len = endbrace - name - 2;
+ len = (STRLEN)(endbrace - name - 2);
cp = grok_hex(name + 2, &len, &fl, NULL);
- if ( len != endbrace - name - 2 ) {
+ if ( len != (STRLEN)(endbrace - name - 2) ) {
cp = 0xFFFD;
}
if (cp > 0xff)
if (!RExC_charnames) {
/* make sure our cache is allocated */
RExC_charnames = newHV();
+ sv_2mortal((SV*)RExC_charnames);
}
/* see if we have looked this one up before */
he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
if (len) {
STRLEN numlen = 1;
if ( SvUTF8(sv_str) ) {
- *valuep = utf8_to_uvchr(p, &numlen);
+ *valuep = utf8_to_uvchr((U8*)p, &numlen);
if (*valuep > 0x7F)
RExC_utf8 = 1;
/* XXXX
/* len is the length written, charlen is the size the char read */
for ( len = 0; p < pend; p += charlen ) {
if (UTF) {
- UV uvc = utf8_to_uvchr(p, &charlen);
+ UV uvc = utf8_to_uvchr((U8*)p, &charlen);
if (FOLD) {
STRLEN foldlen,numlen;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
++RExC_parse;
ret= reg_namedseq(pRExC_state, NULL);
break;
+ case 'k':
+ {
+ char ch= RExC_parse[1];
+ if (ch != '<' && ch != '\'') {
+ if (SIZE_ONLY)
+ vWARN( RExC_parse + 1,
+ "Possible broken named back reference treated as literal k");
+ parse_start--;
+ goto defchar;
+ } else {
+ char* name_start = (RExC_parse += 2);
+ I32 num = 0;
+ SV *svname = reg_scan_name(pRExC_state,!SIZE_ONLY);
+ ch= (ch == '<') ? '>' : '\'';
+
+ if (RExC_parse == name_start || *RExC_parse != ch)
+ vFAIL2("Sequence \\k%c... not terminated",
+ (ch == '>' ? '<' : ch));
+
+ RExC_sawback = 1;
+ ret = reganode(pRExC_state,
+ (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
+ num);
+ *flagp |= HASWIDTH;
+
+
+ if (!SIZE_ONLY) {
+ HE *he_str = NULL;
+ SV *sv_dat;
+ if (!svname)
+ Perl_croak(aTHX_
+ "panic: reg_scan_name returned NULL");
+ if (RExC_paren_names)
+ he_str = hv_fetch_ent( RExC_paren_names, svname, 0, 0 );
+ if ( he_str ) {
+ sv_dat = HeVAL(he_str);
+ } else {
+ vFAIL("Reference to nonexistent group");
+ }
+ num = add_data( pRExC_state, 1, "S" );
+ ARG_SET(ret,num);
+ RExC_rx->data->data[num]=(void*)sv_dat;
+ SvREFCNT_inc(sv_dat);
+ }
+ /* override incorrect value set in reganode MJD */
+ Set_Node_Offset(ret, parse_start+1);
+ Set_Node_Cur_Length(ret); /* MJD */
+ nextchar(pRExC_state);
+
+ }
+ break;
+ }
case 'n':
case 'r':
case 't':
if (SIZE_ONLY) {
SIZE_ALIGN(RExC_size);
RExC_size += 2;
+ /*
+ We can't do this:
+
+ assert(2==regarglen[op]+1);
+
+ Anything larger than this has to allocate the extra amount.
+ If we changed this to be:
+
+ RExC_size += (1 + regarglen[op]);
+
+ then it wouldn't matter. Its not clear what side effect
+ might come from that so its not done so far.
+ -- dmq
+ */
return(ret);
}
* Means relocating the operand.
*/
STATIC void
-S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
+S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
{
dVAR;
register regnode *src;
register regnode *dst;
register regnode *place;
const int offset = regarglen[(U8)op];
+ const int size = NODE_STEP_REGNODE + offset;
GET_RE_DEBUG_FLAGS_DECL;
/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
-
+ DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
if (SIZE_ONLY) {
- RExC_size += NODE_STEP_REGNODE + offset;
+ RExC_size += size;
return;
}
src = RExC_emit;
- RExC_emit += NODE_STEP_REGNODE + offset;
+ RExC_emit += size;
dst = RExC_emit;
+ if (RExC_parens) {
+ int paren;
+ for ( paren=0 ; paren < RExC_npar ; paren++ ) {
+ if ( RExC_parens[paren] >= src )
+ RExC_parens[paren] += size;
+ }
+ }
+
while (src > opnd) {
StructCopy(--src, --dst, regnode);
if (RExC_offsets) { /* MJD 20010112 */
SV * const mysv=sv_newmortal();
DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
regprop(RExC_rx, mysv, scan);
- PerlIO_printf(Perl_debug_log, "~ %s (%d)\n",
- SvPV_nolen_const(mysv), REG_NODE_NUM(scan));
+ PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
+ SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
+ (temp == NULL ? "->" : ""),
+ (temp == NULL ? reg_name[OP(val)] : "")
+ );
});
if (temp == NULL)
break;
SV * const mysv=sv_newmortal();
DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
regprop(RExC_rx, mysv, scan);
- PerlIO_printf(Perl_debug_log, "~ %s (%s) (%d)\n",
+ PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
SvPV_nolen_const(mysv),
- reg_name[exact],
- REG_NODE_NUM(scan));
+ REG_NODE_NUM(scan),
+ reg_name[exact]);
});
if (temp == NULL)
break;
GET_RE_DEBUG_FLAGS_DECL;
sv_setpvn(sv, "", 0);
- if (OP(o) >= reg_num) /* regnode.type is unsigned */
+ if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
/* It would be nice to FAIL() here, but this may be called from
regexec.c, and it would be hard to supply pRExC_state. */
- Perl_croak(aTHX_ "Corrupted regexp opcode");
+ Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
k = PL_regkind[OP(o)];
}
else if (k == WHILEM && o->flags) /* Ordinal/of */
Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
- else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
+ else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP)
Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
+ else if (k == RECURSE)
+ Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
else if (k == LOGICAL)
Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
else if (k == ANYOF) {
return prog->check_substr ? prog->check_substr : prog->check_utf8;
}
+/*
+ pregfree - free a regexp
+
+ See regdupe below if you change anything here.
+*/
+
void
Perl_pregfree(pTHX_ struct regexp *r)
{
SvREFCNT_dec(r->float_utf8);
Safefree(r->substrs);
}
+ if (r->paren_names)
+ SvREFCNT_dec(r->paren_names);
if (r->data) {
int n = r->data->count;
PAD* new_comppad = NULL;
/* If you add a ->what type here, update the comment in regcomp.h */
switch (r->data->what[n]) {
case 's':
+ case 'S':
SvREFCNT_dec((SV*)r->data->data[n]);
break;
case 'f':
Safefree(r);
}
+#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
+#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
+
+/*
+ regdupe - duplicate a regexp.
+
+ This routine is called by sv.c's re_dup and is expected to clone a
+ given regexp structure. It is a no-op when not under USE_ITHREADS.
+ (Originally this *was* re_dup() for change history see sv.c)
+
+ See pregfree() above if you change anything here.
+*/
+#if defined(USE_ITHREADS)
+regexp *
+Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param)
+{
+ dVAR;
+ REGEXP *ret;
+ int i, len, npar;
+ struct reg_substr_datum *s;
+
+ if (!r)
+ return (REGEXP *)NULL;
+
+ if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
+ return ret;
+
+ len = r->offsets[0];
+ npar = r->nparens+1;
+
+ Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+ Copy(r->program, ret->program, len+1, regnode);
+
+ Newx(ret->startp, npar, I32);
+ Copy(r->startp, ret->startp, npar, I32);
+ Newx(ret->endp, npar, I32);
+ Copy(r->startp, ret->startp, npar, I32);
+
+ Newx(ret->substrs, 1, struct reg_substr_data);
+ for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
+ s->min_offset = r->substrs->data[i].min_offset;
+ s->max_offset = r->substrs->data[i].max_offset;
+ s->end_shift = r->substrs->data[i].end_shift;
+ s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
+ s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
+ }
+
+ ret->regstclass = NULL;
+ if (r->data) {
+ struct reg_data *d;
+ const int count = r->data->count;
+ int i;
+
+ Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
+ char, struct reg_data);
+ Newx(d->what, count, U8);
+
+ d->count = count;
+ for (i = 0; i < count; i++) {
+ d->what[i] = r->data->what[i];
+ switch (d->what[i]) {
+ /* legal options are one of: sfpont
+ see also regcomp.h and pregfree() */
+ case 's':
+ case 'S':
+ d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
+ break;
+ case 'p':
+ d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
+ break;
+ case 'f':
+ /* This is cheating. */
+ Newx(d->data[i], 1, struct regnode_charclass_class);
+ StructCopy(r->data->data[i], d->data[i],
+ struct regnode_charclass_class);
+ ret->regstclass = (regnode*)d->data[i];
+ break;
+ case 'o':
+ /* Compiled op trees are readonly, and can thus be
+ shared without duplication. */
+ OP_REFCNT_LOCK;
+ d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+ OP_REFCNT_UNLOCK;
+ break;
+ case 'n':
+ d->data[i] = r->data->data[i];
+ break;
+ case 't':
+ d->data[i] = r->data->data[i];
+ OP_REFCNT_LOCK;
+ ((reg_trie_data*)d->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ break;
+ case 'T':
+ d->data[i] = r->data->data[i];
+ OP_REFCNT_LOCK;
+ ((reg_ac_data*)d->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ /* Trie stclasses are readonly and can thus be shared
+ * without duplication. We free the stclass in pregfree
+ * when the corresponding reg_ac_data struct is freed.
+ */
+ ret->regstclass= r->regstclass;
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
+ }
+ }
+
+ ret->data = d;
+ }
+ else
+ ret->data = NULL;
+
+ Newx(ret->offsets, 2*len+1, U32);
+ Copy(r->offsets, ret->offsets, 2*len+1, U32);
+
+ ret->precomp = SAVEPVN(r->precomp, r->prelen);
+ ret->refcnt = r->refcnt;
+ ret->minlen = r->minlen;
+ ret->prelen = r->prelen;
+ ret->nparens = r->nparens;
+ ret->lastparen = r->lastparen;
+ ret->lastcloseparen = r->lastcloseparen;
+ ret->reganch = r->reganch;
+
+ ret->sublen = r->sublen;
+
+ ret->engine = r->engine;
+
+ ret->paren_names = hv_dup_inc(r->paren_names, param);
+
+ if (RX_MATCH_COPIED(ret))
+ ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
+ else
+ ret->subbeg = NULL;
+#ifdef PERL_OLD_COPY_ON_WRITE
+ ret->saved_copy = NULL;
+#endif
+
+ ptr_table_store(PL_ptr_table, r, ret);
+ return ret;
+}
+#endif
+
#ifndef PERL_IN_XSUB_RE
/*
- regnext - dig the "next" pointer out of a node