regnode **parens; /* offsets of each paren */
I32 utf8;
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_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) == '?' || \
char *str=NULL;
#ifdef DEBUGGING
- regnode *optimize;
+ regnode *optimize = NULL;
U32 mjd_offset = 0;
U32 mjd_nodelen = 0;
#endif
as we won't use them - (which resources?) dmq */
}
/* needed for dumping*/
- DEBUG_r({
+ DEBUG_r(if (optimize) {
regnode *opt = convert;
- while (++opt<optimize) {
+ while ( ++opt < optimize) {
Set_Node_Offset_Length(opt,0,0);
}
/*
RExC_emit = &PL_regdummy;
RExC_whilem_seen = 0;
RExC_charnames = NULL;
- RExC_parens= 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)
r->substrs = 0; /* Useful during FAIL. */
r->startp = 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);
/* 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);
#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); \
int cut; \
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 'R' :
- if (*RExC_parse != ')')
+ case '0' : /* (?0) */
+ case 'R' : /* (?R) */
+ if (*RExC_parse != ')')
FAIL("Sequence (?R) not terminated");
reg_node(pRExC_state, SRECURSE);
- break;
+ 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--;
- {
- const I32 num = atoi(RExC_parse);
- char * const parse_start = RExC_parse - 1; /* MJD */
+ 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_emit++;
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
"Recurse #%"UVuf" to %"IVdf"\n", ARG(ret), ARG2L(ret)));
- } else{
+ } else {
RExC_size++;
RExC_seen|=REG_SEEN_RECURSE;
}
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);
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)];
++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':
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;
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':
#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)
/*
/* 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':
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff