I32 extralen;
I32 seen_zerolen;
I32 seen_evals;
+ 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_seen_zerolen (pRExC_state->seen_zerolen)
#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_size = 0L;
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);
copyRExC_state=RExC_state;
}
#endif
+
/* Dig out information for optimizations. */
r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
pm->op_pmflags = RExC_flags;
/* 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);
-
+
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)) {
return(ret);
}
+
+/* reg_namedseq(pRExC_state,UVp)
+
+ This is expected to be called by a parser routine that has
+ recognized'\N' and needs to handle the rest. RExC_parse is
+ expected to point at the first char following the N at the time
+ of the call.
+
+ If valuep is non-null then it is assumed that we are parsing inside
+ of a charclass definition and the first codepoint in the resolved
+ string is returned via *valuep and the routine will return NULL.
+ In this mode if a multichar string is returned from the charnames
+ handler a warning will be issued, and only the first char in the
+ sequence will be examined. If the string returned is zero length
+ then the value of *valuep is undefined and NON-NULL will
+ be returned to indicate failure. (This will NOT be a valid pointer
+ to a regnode.)
+
+ If value is null then it is assumed that we are parsing normal text
+ and inserts a new EXACT node into the program containing the resolved
+ string and returns a pointer to the new node. If the string is
+ zerolength a NOTHING node is emitted.
+
+ On success RExC_parse is set to the char following the endbrace.
+ Parsing failures will generate a fatal errorvia vFAIL(...)
+
+ NOTE: We cache all results from the charnames handler locally in
+ the RExC_charnames hash (created on first use) to prevent a charnames
+ handler from playing silly-buggers and returning a short string and
+ then a long string for a given pattern. Since the regexp program
+ size is calculated during an initial parse this would result
+ in a buffer overrun so we cache to prevent the charname result from
+ changing during the course of the parse.
+
+ */
+STATIC regnode *
+S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep)
+{
+ char * name; /* start of the content of the name */
+ char * endbrace; /* endbrace following the name */
+ SV *sv_str = NULL;
+ SV *sv_name = NULL;
+ STRLEN len; /* this has various purposes throughout the code */
+ bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
+ regnode *ret = NULL;
+
+ if (*RExC_parse != '{') {
+ vFAIL("Missing braces on \\N{}");
+ }
+ name = RExC_parse+1;
+ endbrace = strchr(RExC_parse, '}');
+ if ( ! endbrace ) {
+ RExC_parse++;
+ vFAIL("Missing right brace on \\N{}");
+ }
+ RExC_parse = endbrace + 1;
+
+
+ /* RExC_parse points at the beginning brace,
+ endbrace points at the last */
+ if ( name[0]=='U' && name[1]=='+' ) {
+ /* its a "unicode hex" notation {U+89AB} */
+ I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
+ | PERL_SCAN_DISALLOW_PREFIX
+ | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
+ UV cp;
+ len = (STRLEN)(endbrace - name - 2);
+ cp = grok_hex(name + 2, &len, &fl, NULL);
+ if ( len != (STRLEN)(endbrace - name - 2) ) {
+ cp = 0xFFFD;
+ }
+ if (cp > 0xff)
+ RExC_utf8 = 1;
+ if ( valuep ) {
+ *valuep = cp;
+ return NULL;
+ }
+ sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
+ } else {
+ /* fetch the charnames handler for this scope */
+ HV * const table = GvHV(PL_hintgv);
+ SV **cvp= table ?
+ hv_fetchs(table, "charnames", FALSE) :
+ NULL;
+ SV *cv= cvp ? *cvp : NULL;
+ HE *he_str;
+ int count;
+ /* create an SV with the name as argument */
+ sv_name = newSVpvn(name, endbrace - name);
+
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
+ vFAIL2("Constant(\\N{%s}) unknown: "
+ "(possibly a missing \"use charnames ...\")",
+ SvPVX(sv_name));
+ }
+ if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
+ vFAIL2("Constant(\\N{%s}): "
+ "$^H{charnames} is not defined",SvPVX(sv_name));
+ }
+
+
+
+ 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 ( he_str ) {
+ sv_str = HeVAL(he_str);
+ cached = 1;
+ } else {
+ dSP ;
+
+ ENTER ;
+ SAVETMPS ;
+ PUSHMARK(SP) ;
+
+ XPUSHs(sv_name);
+
+ PUTBACK ;
+
+ count= call_sv(cv, G_SCALAR);
+
+ if (count == 1) { /* XXXX is this right? dmq */
+ sv_str = POPs;
+ SvREFCNT_inc_simple_void(sv_str);
+ }
+
+ SPAGAIN ;
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ if ( !sv_str || !SvOK(sv_str) ) {
+ vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
+ "did not return a defined value",SvPVX(sv_name));
+ }
+ if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
+ cached = 1;
+ }
+ }
+ if (valuep) {
+ char *p = SvPV(sv_str, len);
+ if (len) {
+ STRLEN numlen = 1;
+ if ( SvUTF8(sv_str) ) {
+ *valuep = utf8_to_uvchr((U8*)p, &numlen);
+ if (*valuep > 0x7F)
+ RExC_utf8 = 1;
+ /* XXXX
+ We have to turn on utf8 for high bit chars otherwise
+ we get failures with
+
+ "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
+ "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
+
+ This is different from what \x{} would do with the same
+ codepoint, where the condition is > 0xFF.
+ - dmq
+ */
+
+
+ } else {
+ *valuep = (UV)*p;
+ /* warn if we havent used the whole string? */
+ }
+ if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ vWARN2(RExC_parse,
+ "Ignoring excess chars from \\N{%s} in character class",
+ SvPVX(sv_name)
+ );
+ }
+ } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ vWARN2(RExC_parse,
+ "Ignoring zero length \\N{%s} in character class",
+ SvPVX(sv_name)
+ );
+ }
+ if (sv_name)
+ SvREFCNT_dec(sv_name);
+ if (!cached)
+ SvREFCNT_dec(sv_str);
+ return len ? NULL : (regnode *)&len;
+ } else if(SvCUR(sv_str)) {
+
+ char *s;
+ char *p, *pend;
+ STRLEN charlen = 1;
+ char * parse_start = name-3; /* needed for the offsets */
+ GET_RE_DEBUG_FLAGS_DECL; /* needed for the offsets */
+
+ ret = reg_node(pRExC_state,
+ (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
+ s= STRING(ret);
+
+ if ( RExC_utf8 && !SvUTF8(sv_str) ) {
+ sv_utf8_upgrade(sv_str);
+ } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
+ RExC_utf8= 1;
+ }
+
+ p = SvPV(sv_str, len);
+ pend = p + len;
+ /* 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((U8*)p, &charlen);
+ if (FOLD) {
+ STRLEN foldlen,numlen;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
+ uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
+ /* Emit all the Unicode characters. */
+
+ for (foldbuf = tmpbuf;
+ foldlen;
+ foldlen -= numlen)
+ {
+ uvc = utf8_to_uvchr(foldbuf, &numlen);
+ if (numlen > 0) {
+ const STRLEN unilen = reguni(pRExC_state, uvc, s);
+ s += unilen;
+ len += unilen;
+ /* In EBCDIC the numlen
+ * and unilen can differ. */
+ foldbuf += numlen;
+ if (numlen >= foldlen)
+ break;
+ }
+ else
+ break; /* "Can't happen." */
+ }
+ } else {
+ const STRLEN unilen = reguni(pRExC_state, uvc, s);
+ if (unilen > 0) {
+ s += unilen;
+ len += unilen;
+ }
+ }
+ } else {
+ len++;
+ REGC(*p, s++);
+ }
+ }
+ if (SIZE_ONLY) {
+ RExC_size += STR_SZ(len);
+ } else {
+ STR_LEN(ret) = len;
+ RExC_emit += STR_SZ(len);
+ }
+ Set_Node_Cur_Length(ret); /* MJD */
+ RExC_parse--;
+ nextchar(pRExC_state);
+ } else {
+ ret = reg_node(pRExC_state,NOTHING);
+ }
+ if (!cached) {
+ SvREFCNT_dec(sv_str);
+ }
+ if (sv_name) {
+ SvREFCNT_dec(sv_name);
+ }
+ return ret;
+
+}
+
+
+
/*
- regatom - the lowest level
*
*flagp |= HASWIDTH|SIMPLE;
}
break;
+ case 'N':
+ /* Handle \N{NAME} here and not below because it can be
+ multicharacter. join_exact() will join them up later on.
+ Also this makes sure that things like /\N{BLAH}+/ and
+ \N{BLAH} being multi char Just Happen. dmq*/
+ ++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':
case 'D':
case 'p':
case 'P':
+ case 'N':
--p;
goto loopdone;
case 'n':
/* If the encoding pragma is in effect recode the text of
* any EXACT-kind nodes. */
- if (PL_encoding && PL_regkind[OP(ret)] == EXACT) {
+ if (ret && PL_encoding && PL_regkind[OP(ret)] == EXACT) {
const STRLEN oldlen = STR_LEN(ret);
SV * const sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
if (UCHARAT(RExC_parse) == ']')
goto charclassloop;
+parseit:
while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
charclassloop:
case 'S': namedclass = ANYOF_NSPACE; break;
case 'd': namedclass = ANYOF_DIGIT; break;
case 'D': namedclass = ANYOF_NDIGIT; break;
+ case 'N': /* Handle \N{NAME} in class */
+ {
+ /* We only pay attention to the first char of
+ multichar strings being returned. I kinda wonder
+ if this makes sense as it does change the behaviour
+ from earlier versions, OTOH that behaviour was broken
+ as well. */
+ UV v; /* value is register so we cant & it /grrr */
+ if (reg_namedseq(pRExC_state, &v)) {
+ goto parseit;
+ }
+ value= v;
+ }
+ break;
case 'p':
case 'P':
{
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
projects / p5sagit/p5-mst-13.2.git / blobdiff