X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regcomp.c;h=15f1feb41cc5d64cb36ed1125e1743a744582e9c;hb=87e33296bf0538cd7a52dd3a42dce8c2210d7406;hp=1523fc17a7fb6ff099914341a6b1f61349cd7c56;hpb=24b23f37fefbcc71a881f6805d87449a234dc645;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regcomp.c b/regcomp.c index 1523fc1..15f1feb 100644 --- a/regcomp.c +++ b/regcomp.c @@ -113,7 +113,9 @@ typedef struct RExC_state_t { I32 sawback; /* Did we see \1, ...? */ U32 seen; I32 size; /* Code size. */ - I32 npar; /* () count. */ + I32 npar; /* Capture buffer count, (OPEN). */ + I32 cpar; /* Capture buffer count, (CLOSE). */ + I32 nestroot; /* root parens we are in - used by accept */ I32 extralen; I32 seen_zerolen; I32 seen_evals; @@ -152,6 +154,8 @@ typedef struct RExC_state_t { #define RExC_seen (pRExC_state->seen) #define RExC_size (pRExC_state->size) #define RExC_npar (pRExC_state->npar) +#define RExC_cpar (pRExC_state->cpar) +#define RExC_nestroot (pRExC_state->nestroot) #define RExC_extralen (pRExC_state->extralen) #define RExC_seen_zerolen (pRExC_state->seen_zerolen) #define RExC_seen_evals (pRExC_state->seen_evals) @@ -335,7 +339,7 @@ static const scan_data_t zero_scan_data = #define SCF_WHILEM_VISITED_POS 0x2000 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */ - +#define SCF_SEEN_ACCEPT 0x8000 #define UTF (RExC_utf8 != 0) #define LOC ((RExC_flags & PMf_LOCALE) != 0) @@ -499,7 +503,7 @@ static const scan_data_t zero_scan_data = #define Set_Node_Offset_To_R(node,byte) STMT_START { \ if (! SIZE_ONLY) { \ MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ - __LINE__, (node), (int)(byte))); \ + __LINE__, (int)(node), (int)(byte))); \ if((node) < 0) { \ Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \ } else { \ @@ -547,7 +551,7 @@ static const scan_data_t zero_scan_data = #define DEBUG_STUDYDATA(data,depth) \ DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log, \ - "%*s"/* Len:%"IVdf"/%"IVdf" */" Pos:%"IVdf"/%"IVdf \ + "%*s"/* Len:%"IVdf"/%"IVdf" */"Pos:%"IVdf"/%"IVdf \ " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \ (int)(depth)*2, "", \ (IV)((data)->pos_min), \ @@ -1890,21 +1894,30 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } if ( count == 1 ) { SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0); - const char *ch = SvPV_nolen_const( *tmp ); - DEBUG_OPTIMISE_r( + char *ch = SvPV_nolen( *tmp ); + DEBUG_OPTIMISE_r({ + SV *sv=sv_newmortal(); PerlIO_printf( Perl_debug_log, "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n", (int)depth * 2 + 2, "", - (UV)state, (UV)idx, ch) - ); + (UV)state, (UV)idx, + pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR + ) + ); + }); if ( state==1 ) { OP( convert ) = nodetype; str=STRING(convert); STR_LEN(convert)=0; } - *str++=*ch; - STR_LEN(convert)++; - + while (*ch) { + *str++ = *ch++; + STR_LEN(convert)++; + } + } else { #ifdef DEBUGGING if (state>1) @@ -1921,11 +1934,21 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs trie->maxlen -= (state - 1); DEBUG_r({ regnode *fix = convert; + U32 word = trie->wordcount; mjd_nodelen++; Set_Node_Offset_Length(convert, mjd_offset, state - 1); while( ++fix < n ) { Set_Node_Offset_Length(fix, 0, 0); } + while (word--) { + SV ** const tmp = av_fetch( trie->words, word, 0 ); + if (tmp) { + if ( STR_LEN(convert) <= SvCUR(*tmp) ) + sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert)); + else + sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp)); + } + } }); if (trie->maxlen) { convert = n; @@ -2089,8 +2112,9 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode */ fail[ 0 ] = fail[ 1 ] = 0; DEBUG_TRIE_COMPILE_r({ - PerlIO_printf(Perl_debug_log, "%*sStclass Failtable (%"UVuf" states): 0", - (int)(depth * 2), "", numstates + PerlIO_printf(Perl_debug_log, + "%*sStclass Failtable (%"UVuf" states): 0", + (int)(depth * 2), "", (UV)numstates ); for( q_read=1; q_read%3d: %s (%d)\n", \ (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\ Next ? (REG_NODE_NUM(Next)) : 0 ); \ - }); + }}); @@ -2284,6 +2308,17 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags Newx(and_withp,1,struct regnode_charclass_class); \ SAVEFREEPV(and_withp) +/* this is a chain of data about sub patterns we are processing that + need to be handled seperately/specially in study_chunk. Its so + we can simulate recursion without losing state. */ +struct scan_frame; +typedef struct scan_frame { + regnode *last; /* last node to process in this frame */ + regnode *next; /* next node to process when last is reached */ + struct scan_frame *prev; /*previous frame*/ + I32 stop; /* what stopparen do we use */ +} scan_frame; + STATIC I32 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, @@ -2311,7 +2346,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, scan_data_t data_fake; SV *re_trie_maxbuff = NULL; regnode *first_non_open = scan; + I32 stopmin = I32_MAX; + scan_frame *frame = NULL; + GET_RE_DEBUG_FLAGS_DECL; + #ifdef DEBUGGING StructCopy(&zero_scan_data, &data_fake, scan_data_t); #endif @@ -2322,7 +2361,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } - while (scan && OP(scan) != END && scan < last) { + fake_study_recurse: + while ( scan && OP(scan) != END && scan < last ){ /* Peephole optimizer: */ DEBUG_STUDYDATA(data,depth); DEBUG_PEEP("Peep",scan,depth); @@ -2356,12 +2396,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* The principal pseudo-switch. Cannot be a switch, since we look into several different things. */ if (OP(scan) == BRANCH || OP(scan) == BRANCHJ - || OP(scan) == IFTHEN || OP(scan) == SUSPEND) { + || OP(scan) == IFTHEN) { next = regnext(scan); code = OP(scan); /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */ - if (OP(next) == code || code == IFTHEN || code == SUSPEND) { + if (OP(next) == code || code == IFTHEN) { /* NOTE - There is similar code to this block below for handling TRIE nodes on a re-study. If you change stuff here check there too. */ @@ -2369,7 +2409,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, struct regnode_charclass_class accum; regnode * const startbranch=scan; - if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ + if (flags & SCF_DO_SUBSTR) scan_commit(pRExC_state, data, minlenp); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) cl_init_zero(pRExC_state, &accum); @@ -2411,6 +2451,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, scan = next; if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > minnext) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -2418,8 +2465,6 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } if (flags & SCF_DO_STCLASS) cl_or(pRExC_state, &accum, &this_class); - if (code == SUSPEND) - break; } if (code == IFTHEN && num < 2) /* Empty ELSE branch */ min1 = 0; @@ -2638,8 +2683,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if ( ((made == MADE_EXACT_TRIE && startbranch == first) || ( first_non_open == first )) && - depth==0 ) + depth==0 ) { flags |= SCF_TRIE_RESTUDY; + if ( startbranch == first + && scan == tail ) + { + RExC_seen &=~REG_TOP_LEVEL_BRANCHES; + } + } #endif } } @@ -2652,6 +2703,63 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else /* single branch is optimized. */ scan = NEXTOPER(scan); continue; + } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) { + scan_frame *newframe = NULL; + I32 paren; + regnode *start; + regnode *end; + + if (OP(scan) != SUSPEND) { + /* set the pointer */ + if (OP(scan) == GOSUB) { + paren = ARG(scan); + RExC_recurse[ARG2L(scan)] = scan; + start = RExC_open_parens[paren-1]; + end = RExC_close_parens[paren-1]; + } else { + paren = 0; + start = RExC_rx->program + 1; + end = RExC_opend; + } + if (!recursed) { + Newxz(recursed, (((RExC_npar)>>3) +1), U8); + SAVEFREEPV(recursed); + } + if (!PAREN_TEST(recursed,paren+1)) { + PAREN_SET(recursed,paren+1); + Newx(newframe,1,scan_frame); + } else { + if (flags & SCF_DO_SUBSTR) { + scan_commit(pRExC_state,data,minlenp); + data->longest = &(data->longest_float); + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + cl_anything(pRExC_state, data->start_class); + flags &= ~SCF_DO_STCLASS; + } + } else { + Newx(newframe,1,scan_frame); + paren = stopparen; + start = scan+2; + end = regnext(scan); + } + if (newframe) { + assert(start); + assert(end); + SAVEFREEPV(newframe); + newframe->next = regnext(scan); + newframe->last = last; + newframe->stop = stopparen; + newframe->prev = frame; + + frame = newframe; + scan = start; + stopparen = paren; + last = end; + + continue; + } } else if (OP(scan) == EXACT) { I32 l = STR_LEN(scan); @@ -3521,70 +3629,20 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data) *(data->last_closep) = ARG(scan); } - else if (OP(scan) == GOSUB || OP(scan) == GOSTART) { - /* set the pointer */ - I32 paren; - regnode *start; - regnode *end; - if (OP(scan) == GOSUB) { - paren = ARG(scan); - RExC_recurse[ARG2L(scan)] = scan; - start = RExC_open_parens[paren-1]; - end = RExC_close_parens[paren-1]; - } else { - paren = 0; - start = RExC_rx->program + 1; - end = RExC_opend; - } - assert(start); - assert(end); - if (!recursed) { - Newxz(recursed, (((RExC_npar)>>3) +1), U8); - SAVEFREEPV(recursed); - } - if (!PAREN_TEST(recursed,paren+1)) { - I32 deltanext = 0; - PAREN_SET(recursed,paren+1); - - DEBUG_PEEP("goto",start,depth); - min += study_chunk( - pRExC_state, - &start, - minlenp, - &deltanext, - end+1, - data, - paren, - recursed, - and_withp, - flags,depth+1); - delta+=deltanext; - if (deltanext == I32_MAX) { - is_inf = is_inf_internal = 1; - delta=deltanext; - } - DEBUG_PEEP("rtrn",end,depth); - PAREN_UNSET(recursed,paren+1); - } else { - if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); - data->longest = &(data->longest_float); - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(pRExC_state, data->start_class); - flags &= ~SCF_DO_STCLASS; - } - } else if (OP(scan) == EVAL) { if (data) data->flags |= SF_HAS_EVAL; } - else if ( OP(scan)==OPFAIL ) { + else if ( PL_regkind[OP(scan)] == ENDLIKE ) { if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state,data,minlenp); flags &= ~SCF_DO_SUBSTR; } + if (data && OP(scan)==ACCEPT) { + data->flags |= SCF_SEEN_ACCEPT; + if (stopmin > min) + stopmin = min; + } } else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ { @@ -3666,7 +3724,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; - + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > min + min1) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -3735,8 +3799,17 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* Else: zero-length, ignore. */ scan = regnext(scan); } + if (frame) { + last = frame->last; + scan = frame->next; + stopparen = frame->stop; + frame = frame->prev; + goto fake_study_recurse; + } finish: + assert(!frame); + *scanp = scan; *deltap = is_inf_internal ? I32_MAX : delta; if (flags & SCF_DO_SUBSTR && is_inf) @@ -3758,7 +3831,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_STUDYDATA(data,depth); - return min; + return min < stopmin ? min : stopmin; } STATIC I32 @@ -3915,6 +3988,8 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_end = xend; RExC_naughty = 0; RExC_npar = 1; + RExC_cpar = 1; + RExC_nestroot = 0; RExC_size = 0L; RExC_emit = &PL_regdummy; RExC_whilem_seen = 0; @@ -3952,6 +4027,11 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) if (RExC_whilem_seen > 15) RExC_whilem_seen = 15; +#ifdef DEBUGGING + /* Make room for a sentinel value at the end of the program */ + RExC_size++; +#endif + /* Allocate space and zero-initialize. Note, the two step process of zeroing when in debug mode, thus anything assigned has to happen after that */ @@ -3979,6 +4059,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) r->substrs = 0; /* Useful during FAIL. */ r->startp = 0; /* Useful during FAIL. */ r->endp = 0; + r->swap = NULL; r->paren_names = 0; if (RExC_seen & REG_SEEN_RECURSE) { @@ -4006,8 +4087,14 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_end = xend; RExC_naughty = 0; RExC_npar = 1; + RExC_cpar = 1; RExC_emit_start = r->program; RExC_emit = r->program; +#ifdef DEBUGGING + /* put a sentinal on the end of the program so we can check for + overwrites */ + r->program[RExC_size].type = 255; +#endif /* Store the count of eval-groups for security checks: */ RExC_emit->next_off = (RExC_seen_evals > (I32)U16_MAX) ? U16_MAX : (U16)RExC_seen_evals; REGC((U8)REG_MAGIC, (char*) RExC_emit++); @@ -4029,8 +4116,14 @@ reStudy: #ifdef TRIE_STUDY_OPT if ( restudied ) { + U32 seen=RExC_seen; DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n")); - RExC_state=copyRExC_state; + + RExC_state = copyRExC_state; + if (seen & REG_TOP_LEVEL_BRANCHES) + RExC_seen |= REG_TOP_LEVEL_BRANCHES; + else + RExC_seen &= ~REG_TOP_LEVEL_BRANCHES; if (data.last_found) { SvREFCNT_dec(data.longest_fixed); SvREFCNT_dec(data.longest_float); @@ -4039,7 +4132,7 @@ reStudy: StructCopy(&zero_scan_data, &data, scan_data_t); } else { StructCopy(&zero_scan_data, &data, scan_data_t); - copyRExC_state=RExC_state; + copyRExC_state = RExC_state; } #else StructCopy(&zero_scan_data, &data, scan_data_t); @@ -4139,7 +4232,8 @@ reStudy: first = NEXTOPER(first); goto again; } - else if (!sawopen && (OP(first) == STAR && + else if ((!sawopen || !RExC_sawback) && + (OP(first) == STAR && PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && !(r->reganch & ROPT_ANCH) ) { @@ -4183,8 +4277,7 @@ reStudy: * it happens that c_offset_min has been invalidated, since the * earlier string may buy us something the later one won't.] */ - minlen = 0; - + data.longest_fixed = newSVpvs(""); data.longest_float = newSVpvs(""); data.last_found = newSVpvs(""); @@ -4197,7 +4290,7 @@ reStudy: } else /* XXXX Check for BOUND? */ stclass_flag = 0; data.last_closep = &last_close; - + minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */ &data, -1, NULL, NULL, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0); @@ -4368,16 +4461,17 @@ reStudy: struct regnode_charclass_class ch_class; I32 last_close = 0; - DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n")); + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n")); scan = r->program + 1; cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; data.last_closep = &last_close; + minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size, &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0); - + CHECK_RESTUDY_GOTO; r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8 @@ -4404,6 +4498,11 @@ reStudy: /* Guard against an embedded (?=) or (?<=) with a longer minlen than the "real" pattern. */ + DEBUG_OPTIMISE_r({ + PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n", + minlen, r->minlen); + }); + r->minlenret = minlen; if (r->minlen < minlen) r->minlen = minlen; @@ -4415,6 +4514,10 @@ reStudy: r->reganch |= ROPT_EVAL_SEEN; if (RExC_seen & REG_SEEN_CANY) r->reganch |= ROPT_CANY_SEEN; + if (RExC_seen & REG_SEEN_VERBARG) + r->reganch |= ROPT_VERBARG_SEEN; + if (RExC_seen & REG_SEEN_CUTGROUP) + r->reganch |= ROPT_CUTGROUP_SEEN; if (RExC_paren_names) r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names); else @@ -4428,8 +4531,8 @@ reStudy: } Newxz(r->startp, RExC_npar, I32); Newxz(r->endp, RExC_npar, I32); - - DEBUG_r( RX_DEBUG_on(r) ); + /* assume we don't need to swap parens around before we match */ + DEBUG_DUMP_r({ PerlIO_printf(Perl_debug_log,"Final program:\n"); regdump(r); @@ -4605,6 +4708,10 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) { #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1) #endif +/* this idea is borrowed from STR_WITH_LEN in handy.h */ +#define CHECK_WORD(s,v,l) \ + (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1)))) + STATIC regnode * S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */ @@ -4641,6 +4748,111 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* Make an OPEN node, if parenthesized. */ if (paren) { + if ( *RExC_parse == '*') { /* (*VERB:ARG) */ + char *start_verb = RExC_parse; + STRLEN verb_len = 0; + char *start_arg = NULL; + unsigned char op = 0; + int argok = 1; + int internal_argval = 0; /* internal_argval is only useful if !argok */ + while ( *RExC_parse && *RExC_parse != ')' ) { + if ( *RExC_parse == ':' ) { + start_arg = RExC_parse + 1; + break; + } + RExC_parse++; + } + ++start_verb; + verb_len = RExC_parse - start_verb; + if ( start_arg ) { + RExC_parse++; + while ( *RExC_parse && *RExC_parse != ')' ) + RExC_parse++; + if ( *RExC_parse != ')' ) + vFAIL("Unterminated verb pattern argument"); + if ( RExC_parse == start_arg ) + start_arg = NULL; + } else { + if ( *RExC_parse != ')' ) + vFAIL("Unterminated verb pattern"); + } + + switch ( *start_verb ) { + case 'A': /* (*ACCEPT) */ + if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) { + op = ACCEPT; + internal_argval = RExC_nestroot; + } + break; + case 'C': /* (*COMMIT) */ + if ( CHECK_WORD("COMMIT",start_verb,verb_len) ) + op = COMMIT; + break; + case 'F': /* (*FAIL) */ + if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) { + op = OPFAIL; + argok = 0; + } + break; + case ':': /* (*:NAME) */ + case 'M': /* (*MARK:NAME) */ + if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) { + op = MARKPOINT; + argok = -1; + } + break; + case 'P': /* (*PRUNE) */ + if ( CHECK_WORD("PRUNE",start_verb,verb_len) ) + op = PRUNE; + break; + case 'S': /* (*SKIP) */ + if ( CHECK_WORD("SKIP",start_verb,verb_len) ) + op = SKIP; + break; + case 'T': /* (*THEN) */ + /* [19:06] :: is then */ + if ( CHECK_WORD("THEN",start_verb,verb_len) ) { + op = CUTGROUP; + RExC_seen |= REG_SEEN_CUTGROUP; + } + break; + } + if ( ! op ) { + RExC_parse++; + vFAIL3("Unknown verb pattern '%.*s'", + verb_len, start_verb); + } + if ( argok ) { + if ( start_arg && internal_argval ) { + vFAIL3("Verb pattern '%.*s' may not have an argument", + verb_len, start_verb); + } else if ( argok < 0 && !start_arg ) { + vFAIL3("Verb pattern '%.*s' has a mandatory argument", + verb_len, start_verb); + } else { + ret = reganode(pRExC_state, op, internal_argval); + if ( ! internal_argval && ! SIZE_ONLY ) { + if (start_arg) { + SV *sv = newSVpvn( start_arg, RExC_parse - start_arg); + ARG(ret) = add_data( pRExC_state, 1, "S" ); + RExC_rx->data->data[ARG(ret)]=(void*)sv; + ret->flags = 0; + } else { + ret->flags = 1; + } + } + } + if (!internal_argval) + RExC_seen |= REG_SEEN_VERBARG; + } else if ( start_arg ) { + vFAIL3("Verb pattern '%.*s' may not have an argument", + verb_len, start_verb); + } else { + ret = reg_node(pRExC_state, op); + } + nextchar(pRExC_state); + return ret; + } else if (*RExC_parse == '?') { /* (?...) */ U32 posflags = 0, negflags = 0; U32 *flagsp = &posflags; @@ -4711,62 +4923,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; case '=': /* (?=...) */ case '!': /* (?!...) */ - if (*RExC_parse == ')') - goto do_op_fail; RExC_seen_zerolen++; + if (*RExC_parse == ')') { + ret=reg_node(pRExC_state, OPFAIL); + nextchar(pRExC_state); + return ret; + } case ':': /* (?:...) */ case '>': /* (?>...) */ break; - case 'C': /* (?CUT) and (?COMMIT) */ - if (RExC_parse[0] == 'O' && - RExC_parse[1] == 'M' && - RExC_parse[2] == 'M' && - RExC_parse[3] == 'I' && - RExC_parse[4] == 'T' && - RExC_parse[5] == ')') - { - RExC_parse+=5; - ret = reg_node(pRExC_state, COMMIT); - } else if ( - RExC_parse[0] == 'U' && - RExC_parse[1] == 'T' && - RExC_parse[2] == ')') - { - RExC_parse+=2; - ret = reg_node(pRExC_state, CUT); - } else { - vFAIL("Sequence (?C... not terminated"); - } - nextchar(pRExC_state); - return ret; - break; - case 'E': /* (?ERROR) */ - if (RExC_parse[0] == 'R' && - RExC_parse[1] == 'R' && - RExC_parse[2] == 'O' && - RExC_parse[3] == 'R' && - RExC_parse[4] == ')') - { - RExC_parse+=4; - ret = reg_node(pRExC_state, OPERROR); - } else { - vFAIL("Sequence (?E... not terminated"); - } - nextchar(pRExC_state); - return ret; - break; - case 'F': - if (RExC_parse[0] == 'A' && - RExC_parse[1] == 'I' && - RExC_parse[2] == 'L') - RExC_parse+=3; - if (*RExC_parse != ')') - vFAIL("Sequence (?FAIL) or (?F) not terminated"); - do_op_fail: - ret = reg_node(pRExC_state, OPFAIL); - nextchar(pRExC_state); - return ret; - break; case '$': /* (?$...) */ case '@': /* (?@...) */ vFAIL2("Sequence (?%c...) not implemented", (int)paren); @@ -4799,17 +4964,54 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } goto gen_recurse_regop; /* NOT REACHED */ + case '+': + if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) { + RExC_parse++; + vFAIL("Illegal pattern"); + } + goto parse_recursion; + /* NOT REACHED*/ + case '-': /* (?-1) */ + if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) { + RExC_parse--; /* rewind to let it be handled later */ + goto parse_flags; + } + /*FALLTHROUGH */ case '1': case '2': case '3': case '4': /* (?1) */ case '5': case '6': case '7': case '8': case '9': RExC_parse--; + parse_recursion: num = atoi(RExC_parse); parse_start = RExC_parse - 1; /* MJD */ + if (*RExC_parse == '-') + RExC_parse++; while (isDIGIT(*RExC_parse)) RExC_parse++; if (*RExC_parse!=')') vFAIL("Expecting close bracket"); gen_recurse_regop: + if ( paren == '-' ) { + /* + Diagram of capture buffer numbering. + Top line is the normal capture buffer numbers + Botton line is the negative indexing as from + the X (the (?-2)) + + + 1 2 3 4 5 X 6 7 + /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/ + - 5 4 3 2 1 X x x + + */ + num = RExC_npar + num; + if (num < 1) { + RExC_parse++; + vFAIL("Reference to nonexistent group"); + } + } else if ( paren == '+' ) { + num = RExC_npar + num - 1; + } + ret = reganode(pRExC_state, GOSUB, num); if (!SIZE_ONLY) { if (num > (I32)RExC_rx->nparens) { @@ -5098,12 +5300,17 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) 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, + if (!SIZE_ONLY ){ + if (!RExC_nestroot) + RExC_nestroot = parno; + if (RExC_seen & REG_SEEN_RECURSE) { + DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, "Setting open paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ret))); - RExC_open_parens[parno-1]= ret; + RExC_open_parens[parno-1]= ret; + } } Set_Node_Length(ret, 1); /* MJD */ Set_Node_Offset(ret, RExC_parse); /* MJD */ @@ -5169,12 +5376,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ender = reg_node(pRExC_state, TAIL); break; case 1: + RExC_cpar++; ender = reganode(pRExC_state, CLOSE, parno); if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, "Setting close paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ender))); RExC_close_parens[parno-1]= ender; + if (RExC_nestroot == parno) + RExC_nestroot = 0; } Set_Node_Offset(ender,RExC_parse+1); /* MJD */ Set_Node_Length(ender,1); /* MJD */ @@ -5782,6 +5992,39 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) } +/* + * reg_recode + * + * It returns the code point in utf8 for the value in *encp. + * value: a code value in the source encoding + * encp: a pointer to an Encode object + * + * If the result from Encode is not a single character, + * it returns U+FFFD (Replacement character) and sets *encp to NULL. + */ +STATIC UV +S_reg_recode(pTHX_ const char value, SV **encp) +{ + STRLEN numlen = 1; + SV * const sv = sv_2mortal(newSVpvn(&value, numlen)); + const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp) + : SvPVX(sv); + const STRLEN newlen = SvCUR(sv); + UV uv = UNICODE_REPLACEMENT; + + if (newlen) + uv = SvUTF8(sv) + ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT) + : *(U8*)s; + + if (!newlen || numlen != newlen) { + uv = UNICODE_REPLACEMENT; + if (encp) + *encp = NULL; + } + return uv; +} + /* - regatom - the lowest level @@ -6078,11 +6321,20 @@ tryagain: case 'c': case '0': goto defchar; + case 'R': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - const I32 num = atoi(RExC_parse); - + I32 num; + bool isrel=(*RExC_parse=='R'); + if (isrel) + RExC_parse++; + num = atoi(RExC_parse); + if (isrel) { + num = RExC_cpar - num; + if (num < 1) + vFAIL("Reference to nonexistent or unclosed group"); + } if (num > 9 && num >= RExC_npar) goto defchar; else { @@ -6090,8 +6342,16 @@ tryagain: while (isDIGIT(*RExC_parse)) RExC_parse++; - if (!SIZE_ONLY && num > (I32)RExC_rx->nparens) - vFAIL("Reference to nonexistent group"); + if (!SIZE_ONLY) { + if (num > (I32)RExC_rx->nparens) + vFAIL("Reference to nonexistent group"); + /* People make this error all the time apparently. + So we cant fail on it, even though we should + + else if (num >= RExC_cpar) + vFAIL("Reference to unclosed group will always match"); + */ + } RExC_sawback = 1; ret = reganode(pRExC_state, (U8)(FOLD ? (LOC ? REFFL : REFF) : REF), @@ -6180,6 +6440,7 @@ tryagain: case 'p': case 'P': case 'N': + case 'R': --p; goto loopdone; case 'n': @@ -6230,6 +6491,8 @@ tryagain: ender = grok_hex(p, &numlen, &flags, NULL); p += numlen; } + if (PL_encoding && ender < 0x100) + goto recode_encoding; break; case 'c': p++; @@ -6249,6 +6512,17 @@ tryagain: --p; goto loopdone; } + if (PL_encoding && ender < 0x100) + goto recode_encoding; + break; + recode_encoding: + { + SV* enc = PL_encoding; + ender = reg_recode((const char)(U8)ender, &enc); + if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) + vWARN(p, "Invalid escape in the specified encoding"); + RExC_utf8 = 1; + } break; case '\0': if (p >= RExC_end) @@ -6376,33 +6650,6 @@ tryagain: break; } - /* If the encoding pragma is in effect recode the text of - * any EXACT-kind nodes. */ - 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 (RExC_utf8) - SvUTF8_on(sv); - if (sv_utf8_downgrade(sv, TRUE)) { - const char * const s = sv_recode_to_utf8(sv, PL_encoding); - const STRLEN newlen = SvCUR(sv); - - if (SvUTF8(sv)) - RExC_utf8 = 1; - if (!SIZE_ONLY) { - GET_RE_DEBUG_FLAGS_DECL; - DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n", - (int)oldlen, STRING(ret), - (int)newlen, s)); - Copy(s, STRING(ret), newlen, char); - STR_LEN(ret) += newlen - oldlen; - RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen); - } else - RExC_size += STR_SZ(newlen) - STR_SZ(oldlen); - } - } - return(ret); } @@ -6773,6 +7020,8 @@ parseit: value = grok_hex(RExC_parse, &numlen, &flags, NULL); RExC_parse += numlen; } + if (PL_encoding && value < 0x100) + goto recode_encoding; break; case 'c': value = UCHARAT(RExC_parse++); @@ -6780,13 +7029,24 @@ parseit: break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - { - I32 flags = 0; - numlen = 3; - value = grok_oct(--RExC_parse, &numlen, &flags, NULL); - RExC_parse += numlen; - break; - } + { + I32 flags = 0; + numlen = 3; + value = grok_oct(--RExC_parse, &numlen, &flags, NULL); + RExC_parse += numlen; + if (PL_encoding && value < 0x100) + goto recode_encoding; + break; + } + recode_encoding: + { + SV* enc = PL_encoding; + value = reg_recode((const char)(U8)value, &enc); + if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) + vWARN(RExC_parse, + "Invalid escape in the specified encoding"); + break; + } default: if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP)) vWARN2(RExC_parse, @@ -7473,6 +7733,11 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) RExC_size += 1; return(ret); } +#ifdef DEBUGGING + if (OP(RExC_emit) == 255) + Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ", + reg_name[op], OP(RExC_emit)); +#endif NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE(ptr, op); @@ -7489,7 +7754,6 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) } RExC_emit = ptr; - return(ret); } @@ -7523,7 +7787,10 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) */ return(ret); } - +#ifdef DEBUGGING + if (OP(RExC_emit) == 255) + Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space"); +#endif NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE_ARG(ptr, op, arg); @@ -7541,7 +7808,6 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) } RExC_emit = ptr; - return(ret); } @@ -7582,7 +7848,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) dst = RExC_emit; if (RExC_open_parens) { int paren; - DEBUG_PARSE_FMT("inst"," - %d",RExC_npar); + DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar); for ( paren=0 ; paren < RExC_npar ; paren++ ) { if ( RExC_open_parens[paren] >= opnd ) { DEBUG_PARSE_FMT("open"," - %d",size); @@ -7896,6 +8162,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) GET_RE_DEBUG_FLAGS_DECL; sv_setpvn(sv, "", 0); + 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. */ @@ -7974,11 +8241,15 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *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 || OP(o)==ACCEPT) Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ else if (k == GOSUB) Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */ - else if (k == LOGICAL) + else if (k == VERB) { + if (!o->flags) + Perl_sv_catpvf(aTHX_ sv, ":%"SVf, + (SV*)prog->data->data[ ARG( o ) ]); + } else if (k == LOGICAL) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ else if (k == ANYOF) { int i, rangestart = -1; @@ -8173,8 +8444,8 @@ Perl_pregfree(pTHX_ struct regexp *r) DEBUG_COMPILE_r({ if (!PL_colorset) reginitcolors(); - if (RX_DEBUG(r)){ - SV *dsv= sv_newmortal(); + { + SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, (r->reganch & ROPT_UTF8), dsv, r->precomp, r->prelen, 60); PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", @@ -8283,12 +8554,10 @@ Perl_pregfree(pTHX_ struct regexp *r) if (trie->nextword) Safefree(trie->nextword); #ifdef DEBUGGING - if (RX_DEBUG(r)) { - if (trie->words) - SvREFCNT_dec((SV*)trie->words); - if (trie->revcharmap) - SvREFCNT_dec((SV*)trie->revcharmap); - } + if (trie->words) + SvREFCNT_dec((SV*)trie->words); + if (trie->revcharmap) + SvREFCNT_dec((SV*)trie->revcharmap); #endif Safefree(r->data->data[n]); /* do this last!!!! */ } @@ -8303,6 +8572,11 @@ Perl_pregfree(pTHX_ struct regexp *r) } Safefree(r->startp); Safefree(r->endp); + if (r->swap) { + Safefree(r->swap->startp); + Safefree(r->swap->endp); + Safefree(r->swap); + } Safefree(r); } @@ -8345,6 +8619,14 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) Copy(r->startp, ret->startp, npar, I32); Newx(ret->endp, npar, I32); Copy(r->startp, ret->startp, npar, I32); + if(r->swap) { + Newx(ret->swap, 1, regexp_paren_ofs); + /* no need to copy these */ + Newx(ret->swap->startp, npar, I32); + Newx(ret->swap->endp, npar, I32); + } else { + ret->swap = NULL; + } Newx(ret->substrs, 1, struct reg_substr_data); for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { @@ -8369,7 +8651,7 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) for (i = 0; i < count; i++) { d->what[i] = r->data->what[i]; switch (d->what[i]) { - /* legal options are one of: sfpont + /* legal options are one of: sSfpont see also regcomp.h and pregfree() */ case 's': case 'S': @@ -8428,6 +8710,7 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) ret->precomp = SAVEPVN(r->precomp, r->prelen); ret->refcnt = r->refcnt; ret->minlen = r->minlen; + ret->minlenret = r->minlenret; ret->prelen = r->prelen; ret->nparens = r->nparens; ret->lastparen = r->lastparen; @@ -8453,6 +8736,111 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) } #endif +/* + reg_stringify() + + converts a regexp embedded in a MAGIC struct to its stringified form, + caching the converted form in the struct and returns the cached + string. + + If lp is nonnull then it is used to return the length of the + resulting string + + If flags is nonnull and the returned string contains UTF8 then + (flags & 1) will be true. + + If haseval is nonnull then it is used to return whether the pattern + contains evals. + + Normally called via macro: + + CALLREG_STRINGIFY(mg,0,0); + + And internally with + + CALLREG_AS_STR(mg,lp,flags,haseval) + + See sv_2pv_flags() in sv.c for an example of internal usage. + + */ + +char * +Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) { + dVAR; + const regexp * const re = (regexp *)mg->mg_obj; + + if (!mg->mg_ptr) { + const char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + bool need_newline = 0; + U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); + + while((ch = *fptr++)) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + /* + * If /x was used, we have to worry about a regex ending with a + * comment later being embedded within another regex. If so, we don't + * want this regex's "commentization" to leak out to the right part of + * the enclosing regex, we must cap it with a newline. + * + * So, if /x was used, we scan backwards from the end of the regex. If + * we find a '#' before we find a newline, we need to add a newline + * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), + * we don't need to add anything. -jfriedl + */ + if (PMf_EXTENDED & re->reganch) { + const char *endptr = re->precomp + re->prelen; + while (endptr >= re->precomp) { + const char c = *(endptr--); + if (c == '\n') + break; /* don't need another */ + if (c == '#') { + /* we end while in a comment, so we need a newline */ + mg->mg_len++; /* save space for it */ + need_newline = 1; /* note to add it */ + break; + } + } + } + + Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); + mg->mg_ptr[0] = '('; + mg->mg_ptr[1] = '?'; + Copy(reflags, mg->mg_ptr+2, left, char); + *(mg->mg_ptr+left+2) = ':'; + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + if (need_newline) + mg->mg_ptr[mg->mg_len - 2] = '\n'; + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; + } + if (haseval) + *haseval = re->program[0].next_off; + if (flags) + *flags = ((re->reganch & ROPT_UTF8) ? 1 : 0); + + if (lp) + *lp = mg->mg_len; + return mg->mg_ptr; +} + + #ifndef PERL_IN_XSUB_RE /* - regnext - dig the "next" pointer out of a node @@ -8614,7 +9002,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, NODE_ALIGN(node); op = OP(node); - if (op == CLOSE) + if (op == CLOSE || op == WHILEM) indent--; next = regnext((regnode *)node); @@ -8733,8 +9121,6 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } if (op == CURLYX || op == OPEN) indent++; - else if (op == WHILEM) - indent--; } CLEAR_OPTSTART; #ifdef DEBUG_DUMPUNTIL