X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/499333dc7a261e5b3794e032f578b461bd895084..43275f00a97a14a80f9493c38895a5c77f0fc88a:/regcomp.c diff --git a/regcomp.c b/regcomp.c index 92dc395..7ea5d89 100644 --- a/regcomp.c +++ b/regcomp.c @@ -102,6 +102,25 @@ EXTERN_C const struct regexp_engine my_reg_engine; #define STATIC static #endif +#ifndef MIN +#define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +/* this is a chain of data about sub patterns we are processing that + need to be handled separately/specially in study_chunk. Its so + we can simulate recursion without losing state. */ +struct scan_frame; +typedef struct scan_frame { + regnode *last_regnode; /* last node to process in this frame */ + regnode *next_regnode; /* next node to process when last is reached */ + U32 prev_recursed_depth; + I32 stopparen; /* what stopparen do we use */ + U32 is_top_frame; /* what flags do we use? */ + + struct scan_frame *this_prev_frame; /* this previous frame */ + struct scan_frame *prev_frame; /* previous frame */ + struct scan_frame *next_frame; /* next frame */ +} scan_frame; struct RExC_state_t { U32 flags; /* RXf_* are we folding, multilining? */ @@ -149,7 +168,7 @@ struct RExC_state_t { regnode **recurse; /* Recurse regops */ I32 recurse_count; /* Number of recurse regops */ - U8 *study_chunk_recursed; /* bitmap of which parens we have moved + U8 *study_chunk_recursed; /* bitmap of which subs we have moved through */ U32 study_chunk_recursed_bytes; /* bytes in bitmap */ I32 in_lookbehind; @@ -162,6 +181,9 @@ struct RExC_state_t { int num_code_blocks; /* size of code_blocks[] */ int code_index; /* next code_blocks[] slot */ SSize_t maxlen; /* mininum possible number of chars in string to match */ + scan_frame *frame_head; + scan_frame *frame_last; + U32 frame_count; #ifdef ADD_TO_REGEXEC char *starttry; /* -Dr: where regtry was called. */ #define RExC_starttry (pRExC_state->starttry) @@ -171,9 +193,17 @@ struct RExC_state_t { const char *lastparse; I32 lastnum; AV *paren_name_list; /* idx -> name */ + U32 study_chunk_recursed_count; + SV *mysv1; + SV *mysv2; #define RExC_lastparse (pRExC_state->lastparse) #define RExC_lastnum (pRExC_state->lastnum) #define RExC_paren_name_list (pRExC_state->paren_name_list) +#define RExC_study_chunk_recursed_count (pRExC_state->study_chunk_recursed_count) +#define RExC_mysv (pRExC_state->mysv1) +#define RExC_mysv1 (pRExC_state->mysv1) +#define RExC_mysv2 (pRExC_state->mysv2) + #endif }; @@ -221,6 +251,9 @@ struct RExC_state_t { #define RExC_contains_i (pRExC_state->contains_i) #define RExC_override_recoding (pRExC_state->override_recoding) #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class) +#define RExC_frame_head (pRExC_state->frame_head) +#define RExC_frame_last (pRExC_state->frame_last) +#define RExC_frame_count (pRExC_state->frame_count) #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') @@ -411,6 +444,10 @@ static const scan_data_t zero_scan_data = #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */ #define SCF_SEEN_ACCEPT 0x8000 #define SCF_TRIE_DOING_RESTUDY 0x10000 +#define SCF_IN_DEFINE 0x20000 + + + #define UTF cBOOL(RExC_utf8) @@ -495,7 +532,8 @@ static const scan_data_t zero_scan_data = * Simple_vFAIL -- like FAIL, but marks the current location in the scan */ #define Simple_vFAIL(m) STMT_START { \ - const IV offset = RExC_parse - RExC_precomp; \ + const IV offset = \ + (RExC_parse > RExC_end ? RExC_end : RExC_parse) - RExC_precomp; \ Perl_croak(aTHX_ "%s" REPORT_LOCATION, \ m, REPORT_LOCATION_ARGS(offset)); \ } STMT_END @@ -771,15 +809,44 @@ static const scan_data_t zero_scan_data = PerlIO_printf(Perl_debug_log,"\n"); \ }); +#define DEBUG_SHOW_STUDY_FLAG(flags,flag) \ + if ((flags) & flag) PerlIO_printf(Perl_debug_log, "%s ", #flag) + +#define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str) \ + if ( ( flags ) ) { \ + PerlIO_printf(Perl_debug_log, "%s", open_str); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR); \ + DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY); \ + DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE); \ + PerlIO_printf(Perl_debug_log, "%s", close_str); \ + } + + #define DEBUG_STUDYDATA(str,data,depth) \ DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log, \ "%*s" str "Pos:%"IVdf"/%"IVdf \ - " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \ + " Flags: 0x%"UVXf, \ (int)(depth)*2, "", \ (IV)((data)->pos_min), \ (IV)((data)->pos_delta), \ - (UV)((data)->flags), \ + (UV)((data)->flags) \ + ); \ + DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]"); \ + PerlIO_printf(Perl_debug_log, \ + " Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \ (IV)((data)->whilem_c), \ (IV)((data)->last_closep ? *((data)->last_closep) : -1), \ is_inf ? "INF " : "" \ @@ -1438,6 +1505,71 @@ S_ssc_clear_locale(regnode_ssc *ssc) ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS; } +#define NON_OTHER_COUNT NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C + +STATIC bool +S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc) +{ + /* The synthetic start class is used to hopefully quickly winnow down + * places where a pattern could start a match in the target string. If it + * doesn't really narrow things down that much, there isn't much point to + * having the overhead of using it. This function uses some very crude + * heuristics to decide if to use the ssc or not. + * + * It returns TRUE if 'ssc' rules out more than half what it considers to + * be the "likely" possible matches, but of course it doesn't know what the + * actual things being matched are going to be; these are only guesses + * + * For /l matches, it assumes that the only likely matches are going to be + * in the 0-255 range, uniformly distributed, so half of that is 127 + * For /a and /d matches, it assumes that the likely matches will be just + * the ASCII range, so half of that is 63 + * For /u and there isn't anything matching above the Latin1 range, it + * assumes that that is the only range likely to be matched, and uses + * half that as the cut-off: 127. If anything matches above Latin1, + * it assumes that all of Unicode could match (uniformly), except for + * non-Unicode code points and things in the General Category "Other" + * (unassigned, private use, surrogates, controls and formats). This + * is a much large number. */ + + const U32 max_match = (LOC) + ? 127 + : (! UNI_SEMANTICS) + ? 63 + : (invlist_highest(ssc->invlist) < 256) + ? 127 + : ((NON_OTHER_COUNT + 1) / 2) - 1; + U32 count = 0; /* Running total of number of code points matched by + 'ssc' */ + UV start, end; /* Start and end points of current range in inversion + list */ + + PERL_ARGS_ASSERT_IS_SSC_WORTH_IT; + + invlist_iterinit(ssc->invlist); + while (invlist_iternext(ssc->invlist, &start, &end)) { + + /* /u is the only thing that we expect to match above 255; so if not /u + * and even if there are matches above 255, ignore them. This catches + * things like \d under /d which does match the digits above 255, but + * since the pattern is /d, it is not likely to be expecting them */ + if (! UNI_SEMANTICS) { + if (start > 255) { + break; + } + end = MIN(end, 255); + } + count += end - start + 1; + if (count > max_match) { + invlist_iterfinish(ssc->invlist); + return FALSE; + } + } + + return TRUE; +} + + STATIC void S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) { @@ -3130,15 +3262,15 @@ S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *sour #define DEBUG_PEEP(str,scan,depth) \ DEBUG_OPTIMISE_r({if (scan){ \ - SV * const mysv=sv_newmortal(); \ regnode *Next = regnext(scan); \ - regprop(RExC_rx, mysv, scan, NULL); \ - PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \ - (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\ - Next ? (REG_NODE_NUM(Next)) : 0 ); \ + regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state); \ + PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)", \ + (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\ + Next ? (REG_NODE_NUM(Next)) : 0 ); \ + DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\ + PerlIO_printf(Perl_debug_log, "\n"); \ }}); - /* The below joins as many adjacent EXACTish nodes as possible into a single * one. The regop may be changed if the node(s) contain certain sequences that * require special handling. The joining is only done if: @@ -3579,17 +3711,17 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, Newx(and_withp,1, regnode_ssc); \ SAVEFREEPV(and_withp) -/* this is a chain of data about sub patterns we are processing that - need to be handled separately/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*/ - U32 prev_recursed_depth; - I32 stop; /* what stopparen do we use */ -} scan_frame; + +static void +S_unwind_scan_frames(pTHX_ const void *p) +{ + scan_frame *f= (scan_frame *)p; + do { + scan_frame *n= f->next_frame; + Safefree(f); + f= n; + } while (f); +} STATIC SSize_t @@ -3626,9 +3758,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, PERL_ARGS_ASSERT_STUDY_CHUNK; -#ifdef DEBUGGING - StructCopy(&zero_scan_data, &data_fake, scan_data_t); -#endif + if ( depth == 0 ) { while (first_non_open && OP(first_non_open) == OPEN) first_non_open=regnext(first_non_open); @@ -3636,35 +3766,50 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, fake_study_recurse: + DEBUG_r( + RExC_study_chunk_recursed_count++; + ); + DEBUG_OPTIMISE_MORE_r( + { + PerlIO_printf(Perl_debug_log, + "%*sstudy_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p", + (int)(depth*2), "", (long)stopparen, + (unsigned long)RExC_study_chunk_recursed_count, + (unsigned long)depth, (unsigned long)recursed_depth, + scan, + last); + if (recursed_depth) { + U32 i; + U32 j; + for ( j = 0 ; j < recursed_depth ; j++ ) { + for ( i = 0 ; i < (U32)RExC_npar ; i++ ) { + if ( + PAREN_TEST(RExC_study_chunk_recursed + + ( j * RExC_study_chunk_recursed_bytes), i ) + && ( + !j || + !PAREN_TEST(RExC_study_chunk_recursed + + (( j - 1 ) * RExC_study_chunk_recursed_bytes), i) + ) + ) { + PerlIO_printf(Perl_debug_log," %d",(int)i); + break; + } + } + if ( j + 1 < recursed_depth ) { + PerlIO_printf(Perl_debug_log, ","); + } + } + } + PerlIO_printf(Perl_debug_log,"\n"); + } + ); while ( scan && OP(scan) != END && scan < last ){ UV min_subtract = 0; /* How mmany chars to subtract from the minimum node length to get a real minimum (because the folded version may be shorter) */ bool unfolded_multi_char = FALSE; /* Peephole optimizer: */ - DEBUG_OPTIMISE_MORE_r( - { - PerlIO_printf(Perl_debug_log, - "%*sstudy_chunk stopparen=%ld depth=%lu recursed_depth=%lu ", - ((int) depth*2), "", (long)stopparen, - (unsigned long)depth, (unsigned long)recursed_depth); - if (recursed_depth) { - U32 i; - U32 j; - for ( j = 0 ; j < recursed_depth ; j++ ) { - PerlIO_printf(Perl_debug_log,"["); - for ( i = 0 ; i < (U32)RExC_npar ; i++ ) - PerlIO_printf(Perl_debug_log,"%d", - PAREN_TEST(RExC_study_chunk_recursed + - (j * RExC_study_chunk_recursed_bytes), i) - ? 1 : 0 - ); - PerlIO_printf(Perl_debug_log,"]"); - } - } - PerlIO_printf(Perl_debug_log,"\n"); - } - ); DEBUG_STUDYDATA("Peep:", data, depth); DEBUG_PEEP("Peep", scan, depth); @@ -3698,17 +3843,47 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, NEXT_OFF(scan) = off; } - - /* 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) { + if ( OP(scan) == DEFINEP ) { + SSize_t minlen = 0; + SSize_t deltanext = 0; + SSize_t fake_last_close = 0; + I32 f = SCF_IN_DEFINE; + + StructCopy(&zero_scan_data, &data_fake, scan_data_t); + scan = regnext(scan); + assert( OP(scan) == IFTHEN ); + DEBUG_PEEP("expect IFTHEN", scan, depth); + + data_fake.last_closep= &fake_last_close; + minlen = *minlenp; + next = regnext(scan); + scan = NEXTOPER(NEXTOPER(scan)); + DEBUG_PEEP("scan", scan, depth); + DEBUG_PEEP("next", next, depth); + + /* we suppose the run is continuous, last=next... + * NOTE we dont use the return here! */ + (void)study_chunk(pRExC_state, &scan, &minlen, + &deltanext, next, &data_fake, stopparen, + recursed_depth, NULL, f, depth+1); + + scan = next; + } else + if ( + OP(scan) == BRANCH || + OP(scan) == BRANCHJ || + OP(scan) == IFTHEN + ) { next = regnext(scan); code = OP(scan); - /* demq: the op(next)==code check is to see if we have - * "branch-branch" AFAICT */ + /* The op(next)==code check below is to see if we + * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN" + * IFTHEN is special as it might not appear in pairs. + * Not sure whether BRANCH-BRANCHJ is possible, regardless + * we dont handle it cleanly. */ 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 @@ -3730,8 +3905,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 f = 0; regnode_ssc this_class; + DEBUG_PEEP("Branch", scan, depth); + num++; - data_fake.flags = 0; + StructCopy(&zero_scan_data, &data_fake, scan_data_t); if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; @@ -3741,9 +3918,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data_fake.pos_delta = delta; next = regnext(scan); - scan = NEXTOPER(scan); - if (code != BRANCH) + + scan = NEXTOPER(scan); /* everything */ + if (code != BRANCH) /* everything but BRANCH */ scan = NEXTOPER(scan); + if (flags & SCF_DO_STCLASS) { ssc_init(pRExC_state, &this_class); data_fake.start_class = &this_class; @@ -3756,6 +3935,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, next, &data_fake, stopparen, recursed_depth, NULL, f,depth+1); + if (min1 > minnext) min1 = minnext; if (deltanext == SSize_t_MAX) { @@ -3881,9 +4061,6 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, U8 trietype = 0; U32 count=0; -#ifdef DEBUGGING - SV * const mysv = sv_newmortal(); /* for dumping */ -#endif /* var tail is used because there may be a TAIL regop in the way. Ie, the exacts will point to the thing following the TAIL, but the last branch will @@ -3899,11 +4076,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_TRIE_COMPILE_r({ - regprop(RExC_rx, mysv, tail, NULL); + regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state); PerlIO_printf( Perl_debug_log, "%*s%s%s\n", (int)depth * 2 + 2, "", "Looking for TRIE'able sequences. Tail node is: ", - SvPV_nolen_const( mysv ) + SvPV_nolen_const( RExC_mysv ) ); }); @@ -3980,18 +4157,18 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, #endif DEBUG_TRIE_COMPILE_r({ - regprop(RExC_rx, mysv, cur, NULL); + regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state); PerlIO_printf( Perl_debug_log, "%*s- %s (%d)", - (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) ); + (int)depth * 2 + 2,"", SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) ); - regprop(RExC_rx, mysv, noper, NULL); + regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state); PerlIO_printf( Perl_debug_log, " -> %s", - SvPV_nolen_const(mysv)); + SvPV_nolen_const(RExC_mysv)); if ( noper_next ) { - regprop(RExC_rx, mysv, noper_next, NULL); + regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state); PerlIO_printf( Perl_debug_log,"\t=> %s\t", - SvPV_nolen_const(mysv)); + SvPV_nolen_const(RExC_mysv)); } PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n", REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur), @@ -4088,11 +4265,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } /* end handle unmergable node */ } /* loop over branches */ DEBUG_TRIE_COMPILE_r({ - regprop(RExC_rx, mysv, cur, NULL); + regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state); PerlIO_printf( Perl_debug_log, "%*s- %s (%d) \n", (int)depth * 2 + 2, - "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur)); + "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur)); }); if ( last && trietype ) { @@ -4128,10 +4305,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * something like this: (?:|) So we can * turn it into a plain NOTHING op. */ DEBUG_TRIE_COMPILE_r({ - regprop(RExC_rx, mysv, cur, NULL); + regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state); PerlIO_printf( Perl_debug_log, "%*s- %s (%d) \n", (int)depth * 2 + 2, - "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur)); + "", SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur)); }); OP(startbranch)= NOTHING; @@ -4152,28 +4329,68 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 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; + I32 paren = 0; + regnode *start = NULL; + regnode *end = NULL; U32 my_recursed_depth= recursed_depth; - if (OP(scan) != SUSPEND) { - /* set the pointer */ + + if (OP(scan) != SUSPEND) { /* GOSUB/GOSTART */ + /* Do setup, note this code has side effects beyond + * the rest of this block. Specifically setting + * RExC_recurse[] must happen at least once during + * study_chunk(). */ 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_rxi->program + 1; end = RExC_opend; } - if (!recursed_depth + /* NOTE we MUST always execute the above code, even + * if we do nothing with a GOSUB/GOSTART */ + if ( + ( flags & SCF_IN_DEFINE ) + || + ( + (is_inf_internal || is_inf || data->flags & SF_IS_INF) + && + ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 ) + ) + ) { + /* no need to do anything here if we are in a define. */ + /* or we are after some kind of infinite construct + * so we can skip recursing into this item. + * Since it is infinite we will not change the maxlen + * or delta, and if we miss something that might raise + * the minlen it will merely pessimise a little. + * + * Iow /(?(DEFINE)(?foo|food))a+(?&foo)/ + * might result in a minlen of 1 and not of 4, + * but this doesn't make us mismatch, just try a bit + * harder than we should. + * */ + scan= regnext(scan); + continue; + } + + if ( + !recursed_depth || !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren) ) { + /* it is quite possible that there are more efficient ways + * to do this. We maintain a bitmap per level of recursion + * of which patterns we have entered so we can detect if a + * pattern creates a possible infinite loop. When we + * recurse down a level we copy the previous levels bitmap + * down. When we are at recursion level 0 we zero the top + * level bitmap. It would be nice to implement a different + * more efficient way of doing this. In particular the top + * level bitmap may be unnecessary. + */ if (!recursed_depth) { Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8); } else { @@ -4185,7 +4402,6 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_STUDYDATA("set:", data,depth); PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren); my_recursed_depth= recursed_depth + 1; - Newx(newframe,1,scan_frame); } else { DEBUG_STUDYDATA("inf:", data,depth); /* some form of infinite recursion, assume infinite length @@ -4198,22 +4414,37 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ ssc_anything(data->start_class); flags &= ~SCF_DO_STCLASS; + + start= NULL; /* reset start so we dont recurse later on. */ } } else { - Newx(newframe,1,scan_frame); paren = stopparen; - start = scan+2; + start = scan + 2; end = regnext(scan); } - if (newframe) { - assert(start); + if (start) { + scan_frame *newframe; assert(end); - SAVEFREEPV(newframe); - newframe->next = regnext(scan); - newframe->last = last; - newframe->stop = stopparen; - newframe->prev = frame; + if (!RExC_frame_last) { + Newxz(newframe, 1, scan_frame); + SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe); + RExC_frame_head= newframe; + RExC_frame_count++; + } else if (!RExC_frame_last->next_frame) { + Newxz(newframe,1,scan_frame); + RExC_frame_last->next_frame= newframe; + newframe->prev_frame= RExC_frame_last; + RExC_frame_count++; + } else { + newframe= RExC_frame_last->next_frame; + } + RExC_frame_last= newframe; + + newframe->next_regnode = regnext(scan); + newframe->last_regnode = last; + newframe->stopparen = stopparen; newframe->prev_recursed_depth = recursed_depth; + newframe->this_prev_frame= frame; DEBUG_STUDYDATA("frame-new:",data,depth); DEBUG_PEEP("fnew", scan, depth); @@ -4279,8 +4510,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } flags &= ~SCF_DO_STCLASS; } - else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT!, so is - EXACTFish */ + else if (PL_regkind[OP(scan)] == EXACT) { + /* But OP != EXACT!, so is EXACTFish */ SSize_t l = STR_LEN(scan); UV uc = *((U8*)STRING(scan)); SV* EXACTF_invlist = _new_invlist(4); /* Start out big enough for 2 @@ -4602,8 +4833,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, { /* Fatal warnings may leak the regexp without this: */ SAVEFREESV(RExC_rx_sv); - ckWARNreg(RExC_parse, - "Quantifier unexpected on zero-length expression"); + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), + "Quantifier unexpected on zero-length expression " + "in regex m/%"UTF8f"/", + UTF8fARG(UTF, RExC_end - RExC_precomp, + RExC_precomp)); (void)ReREFCNT_inc(RExC_rx_sv); } @@ -5072,14 +5306,13 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", regnode *opt; regnode *upto= regnext(scan); DEBUG_PARSE_r({ - SV * const mysv_val=sv_newmortal(); DEBUG_STUDYDATA("OPFAIL",data,depth); /*DEBUG_PARSE_MSG("opfail");*/ - regprop(RExC_rx, mysv_val, upto, NULL); + regprop(RExC_rx, RExC_mysv, upto, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n", - SvPV_nolen_const(mysv_val), + SvPV_nolen_const(RExC_mysv), (IV)REG_NODE_NUM(upto), (IV)(upto - scan) ); @@ -5103,7 +5336,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", regnode_ssc intrnl; int f = 0; - data_fake.flags = 0; + StructCopy(&zero_scan_data, &data_fake, scan_data_t); if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; @@ -5347,7 +5580,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", SSize_t deltanext=0, minnext=0, f = 0, fake; regnode_ssc this_class; - data_fake.flags = 0; + StructCopy(&zero_scan_data, &data_fake, scan_data_t); if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; @@ -5470,16 +5703,19 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", } */ if (frame) { + depth = depth - 1; + DEBUG_STUDYDATA("frame-end:",data,depth); DEBUG_PEEP("fend", scan, depth); + /* restore previous context */ - last = frame->last; - scan = frame->next; - stopparen = frame->stop; + last = frame->last_regnode; + scan = frame->next_regnode; + stopparen = frame->stopparen; recursed_depth = frame->prev_recursed_depth; - depth = depth - 1; - frame = frame->prev; + RExC_frame_last = frame->prev_frame; + frame = frame->this_prev_frame; goto fake_study_recurse; } @@ -5670,9 +5906,9 @@ S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, char **pat_p, STRLEN *plen_p, int num_code_blocks) { U8 *const src = (U8*)*pat_p; - U8 *dst; + U8 *dst, *d; int n=0; - STRLEN s = 0, d = 0; + STRLEN s = 0; bool do_end = 0; GET_RE_DEBUG_FLAGS_DECL; @@ -5680,32 +5916,27 @@ S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); Newx(dst, *plen_p * 2 + 1, U8); + d = dst; while (s < *plen_p) { - if (NATIVE_BYTE_IS_INVARIANT(src[s])) - dst[d] = src[s]; - else { - dst[d++] = UTF8_EIGHT_BIT_HI(src[s]); - dst[d] = UTF8_EIGHT_BIT_LO(src[s]); - } + append_utf8_from_native_byte(src[s], &d); if (n < num_code_blocks) { if (!do_end && pRExC_state->code_blocks[n].start == s) { - pRExC_state->code_blocks[n].start = d; - assert(dst[d] == '('); + pRExC_state->code_blocks[n].start = d - dst - 1; + assert(*(d - 1) == '('); do_end = 1; } else if (do_end && pRExC_state->code_blocks[n].end == s) { - pRExC_state->code_blocks[n].end = d; - assert(dst[d] == ')'); + pRExC_state->code_blocks[n].end = d - dst - 1; + assert(*(d - 1) == ')'); do_end = 0; n++; } } s++; - d++; } - dst[d] = '\0'; - *plen_p = d; + *d = '\0'; + *plen_p = d - dst; *pat_p = (char*) dst; SAVEFREEPV(*pat_p); RExC_orig_utf8 = RExC_utf8 = 1; @@ -6059,7 +6290,6 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, ENTER; SAVETMPS; - save_re_context(); PUSHSTACKi(PERLSI_REQUIRE); /* G_RE_REPARSING causes the toker to collapse \\ into \ when * parsing qr''; normally only q'' does this. It also alters @@ -6432,7 +6662,14 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_contains_locale = 0; RExC_contains_i = 0; pRExC_state->runtime_code_qr = NULL; + RExC_frame_head= NULL; + RExC_frame_last= NULL; + RExC_frame_count= 0; + DEBUG_r({ + RExC_mysv1= sv_newmortal(); + RExC_mysv2= sv_newmortal(); + }); DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60); @@ -6766,10 +7003,15 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, reStudy: r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0; + DEBUG_r( + RExC_study_chunk_recursed_count= 0; + ); Zero(r->substrs, 1, struct reg_substr_data); - if (RExC_study_chunk_recursed) + if (RExC_study_chunk_recursed) { Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes * RExC_npar, U8); + } + #ifdef TRIE_STUDY_OPT if (!restudied) { @@ -6877,9 +7119,7 @@ reStudy: else if (PL_regkind[OP(first)] == BOL) { r->intflags |= (OP(first) == MBOL ? PREGf_ANCH_MBOL - : (OP(first) == SBOL - ? PREGf_ANCH_SBOL - : PREGf_ANCH_BOL)); + : PREGf_ANCH_SBOL); first = NEXTOPER(first); goto again; } @@ -7033,7 +7273,7 @@ reStudy: if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset) && stclass_flag && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && !ssc_is_anything(data.start_class)) + && is_ssc_worth_it(pRExC_state, data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7046,7 +7286,7 @@ reStudy: ri->regstclass = (regnode*)RExC_rxi->data->data[n]; r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); - regprop(r, sv, (regnode*)data.start_class, NULL); + regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "synthetic stclass \"%s\".\n", SvPVX_const(sv));}); @@ -7113,7 +7353,7 @@ reStudy: = r->float_substr = r->float_utf8 = NULL; if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && ! ssc_is_anything(data.start_class)) + && is_ssc_worth_it(pRExC_state, data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7126,7 +7366,7 @@ reStudy: ri->regstclass = (regnode*)RExC_rxi->data->data[n]; r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); - regprop(r, sv, (regnode*)data.start_class, NULL); + regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "synthetic stclass \"%s\".\n", SvPVX_const(sv));}); @@ -7196,7 +7436,12 @@ reStudy: if (PL_regkind[fop] == NOTHING && nop == END) r->extflags |= RXf_NULL; - else if (PL_regkind[fop] == BOL && nop == END) + else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END) + /* when fop is SBOL first->flags will be true only when it was + * produced by parsing /\A/, and not when parsing /^/. This is + * very important for the split code as there we want to + * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m. + * See rt #122761 for more details. -- Yves */ r->extflags |= RXf_START_ONLY; else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE @@ -7232,7 +7477,10 @@ reStudy: } Newxz(r->offs, RExC_npar, regexp_paren_pair); /* assume we don't need to swap parens around before we match */ - + DEBUG_TEST_r({ + PerlIO_printf(Perl_debug_log,"study_chunk_recursed_count: %lu\n", + (unsigned long)RExC_study_chunk_recursed_count); + }); DEBUG_DUMP_r({ DEBUG_RExC_seen(); PerlIO_printf(Perl_debug_log,"Final program:\n"); @@ -7770,22 +8018,20 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) } #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \ - int rem=(int)(RExC_end - RExC_parse); \ - int cut; \ int num; \ - int iscut=0; \ - if (rem>10) { \ - rem=10; \ - iscut=1; \ - } \ - cut=10-rem; \ - if (RExC_lastparse!=RExC_parse) \ - PerlIO_printf(Perl_debug_log," >%.*s%-*s", \ - rem, RExC_parse, \ - cut + 4, \ - iscut ? "..." : "<" \ + if (RExC_lastparse!=RExC_parse) { \ + PerlIO_printf(Perl_debug_log, "%s", \ + Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse, \ + RExC_end - RExC_parse, 16, \ + "", "", \ + PERL_PV_ESCAPE_UNI_DETECT | \ + PERL_PV_PRETTY_ELLIPSES | \ + PERL_PV_PRETTY_LTGT | \ + PERL_PV_ESCAPE_RE | \ + PERL_PV_PRETTY_EXACTSIZE \ + ) \ ); \ - else \ + } else \ PerlIO_printf(Perl_debug_log,"%16s",""); \ \ if (SIZE_ONLY) \ @@ -8858,7 +9104,7 @@ Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end) /* Add the range from 'start' to 'end' inclusive to the inversion list's * set. A pointer to the inversion list is returned. This may actually be * a new list, in which case the passed in one has been destroyed. The - * passed in inversion list can be NULL, in which case a new one is created + * passed-in inversion list can be NULL, in which case a new one is created * with just the one range in it */ SV* range_invlist; @@ -9280,6 +9526,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) regex_charset cs; bool has_use_defaults = FALSE; const char* const seqstart = RExC_parse - 1; /* Point to the '?' */ + int x_mod_count = 0; PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS; @@ -9307,7 +9554,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) switch (*RExC_parse) { /* Code for the imsx flags */ - CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp); + CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count); case LOCALE_PAT_MOD: if (has_charset_modifier) { @@ -9444,6 +9691,9 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) if (RExC_flags & RXf_PMf_FOLD) { RExC_contains_i = 1; } + if (PASS2) { + STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count); + } return; /*NOTREACHED*/ default: @@ -9457,6 +9707,10 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) ++RExC_parse; } + + if (PASS2) { + STD_PMMOD_FLAGS_PARSE_X_WARN(x_mod_count); + } } /* @@ -9887,21 +10141,19 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) num = RExC_npar + num - 1; } - ret = reganode(pRExC_state, GOSUB, num); + ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count); if (!SIZE_ONLY) { if (num > (I32)RExC_rx->nparens) { RExC_parse++; vFAIL("Reference to nonexistent group"); } - ARG2L_SET( ret, RExC_recurse_count++); - RExC_emit++; + RExC_recurse_count++; DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Recurse #%"UVuf" to %"IVdf"\n", + "%*s%*s Recurse #%"UVuf" to %"IVdf"\n", + 22, "| |", (int)(depth * 2 + 1), "", (UV)ARG(ret), (IV)ARG2L(ret))); - } else { - RExC_size++; - } - RExC_seen |= REG_RECURSE_SEEN; + } + RExC_seen |= REG_RECURSE_SEEN; Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */ Set_Node_Offset(ret, parse_start); /* MJD */ @@ -9964,17 +10216,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (is_logical) { regnode *eval; ret = reg_node(pRExC_state, LOGICAL); - eval = reganode(pRExC_state, EVAL, n); + + eval = reg2Lanode(pRExC_state, EVAL, + n, + + /* for later propagation into (??{}) + * return value */ + RExC_flags & RXf_PMf_COMPILETIME + ); if (!SIZE_ONLY) { ret->flags = 2; - /* for later propagation into (??{}) return value */ - eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME); } REGTAIL(pRExC_state, ret, eval); /* deal with the length of this later - MJD */ return ret; } - ret = reganode(pRExC_state, EVAL, n); + ret = reg2Lanode(pRExC_state, EVAL, n, 0); Set_Node_Length(ret, RExC_parse - parse_start + 1); Set_Node_Offset(ret, parse_start); return ret; @@ -9982,6 +10239,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case '(': /* (?(?{...})...) and (?(?=...)...) */ { int is_define= 0; + const int DEFINE_len = sizeof("DEFINE") - 1; if (RExC_parse[0] == '?') { /* (?(?...)) */ if (RExC_parse[1] == '=' || RExC_parse[1] == '!' || RExC_parse[1] == '<' @@ -10024,15 +10282,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ret = reganode(pRExC_state,NGROUPP,num); goto insert_if_check_paren; } - else if (RExC_parse[0] == 'D' && - RExC_parse[1] == 'E' && - RExC_parse[2] == 'F' && - RExC_parse[3] == 'I' && - RExC_parse[4] == 'N' && - RExC_parse[5] == 'E') - { + else if (strnEQ(RExC_parse, "DEFINE", + MIN(DEFINE_len, RExC_end - RExC_parse))) + { ret = reganode(pRExC_state,DEFINEP,0); - RExC_parse +=6 ; + RExC_parse += DEFINE_len; is_define = 1; goto insert_if_check_paren; } @@ -10111,8 +10365,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else lastbr = NULL; - if (c != ')') - vFAIL("Switch (?(condition)... contains too many branches"); + if (c != ')') { + if (RExC_parse>RExC_end) + vFAIL("Switch (?(condition)... not terminated"); + else + vFAIL("Switch (?(condition)... contains too many branches"); + } ender = reg_node(pRExC_state, TAIL); REGTAIL(pRExC_state, br, ender); if (lastbr) { @@ -10164,7 +10422,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) && !RExC_open_parens[parno-1]) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Setting open paren #%"IVdf" to %d\n", + "%*s%*s Setting open paren #%"IVdf" to %d\n", + 22, "| |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ret))); RExC_open_parens[parno-1]= ret; } @@ -10253,8 +10512,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ender = reganode(pRExC_state, CLOSE, parno); if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Setting close paren #%"IVdf" to %d\n", - (IV)parno, REG_NODE_NUM(ender))); + "%*s%*s Setting close paren #%"IVdf" to %d\n", + 22, "| |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender))); RExC_close_parens[parno-1]= ender; if (RExC_nestroot == parno) RExC_nestroot = 0; @@ -10280,15 +10539,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) break; } DEBUG_PARSE_r(if (!SIZE_ONLY) { - SV * const mysv_val1=sv_newmortal(); - SV * const mysv_val2=sv_newmortal(); DEBUG_PARSE_MSG("lsbr"); - regprop(RExC_rx, mysv_val1, lastbr, NULL); - regprop(RExC_rx, mysv_val2, ender, NULL); + regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state); + regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n", - SvPV_nolen_const(mysv_val1), + SvPV_nolen_const(RExC_mysv1), (IV)REG_NODE_NUM(lastbr), - SvPV_nolen_const(mysv_val2), + SvPV_nolen_const(RExC_mysv2), (IV)REG_NODE_NUM(ender), (IV)(ender - lastbr) ); @@ -10321,15 +10578,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (is_nothing) { br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret; DEBUG_PARSE_r(if (!SIZE_ONLY) { - SV * const mysv_val1=sv_newmortal(); - SV * const mysv_val2=sv_newmortal(); DEBUG_PARSE_MSG("NADA"); - regprop(RExC_rx, mysv_val1, ret, NULL); - regprop(RExC_rx, mysv_val2, ender, NULL); + regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state); + regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n", - SvPV_nolen_const(mysv_val1), + SvPV_nolen_const(RExC_mysv1), (IV)REG_NODE_NUM(ret), - SvPV_nolen_const(mysv_val2), + SvPV_nolen_const(RExC_mysv2), (IV)REG_NODE_NUM(ender), (IV)(ender - ret) ); @@ -10716,10 +10971,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) return(ret); } -STATIC bool +STATIC STRLEN S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, - UV *valuep, I32 *flagp, U32 depth, bool in_char_class, - const bool strict /* Apply stricter parsing rules? */ + UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse ) { @@ -10727,46 +10981,75 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, 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. On successful return, RExC_parse has been updated to point to just after the sequence identified - by this routine, and <*flagp> has been updated. - - The \N may be inside (indicated by the boolean ) or outside a - character class. - - \N may begin either a named sequence, or if outside a character class, mean - to match a non-newline. For non single-quoted regexes, the tokenizer has - attempted to decide which, and in the case of a named sequence, converted it + by this routine, <*flagp> has been updated, and the non-NULL input pointers + have been set appropriately. + + The typical case for this is \N{some character name}. This is usually + called while parsing the input, filling in or ready to fill in an EXACTish + node, and the code point for the character should be returned, so that it + can be added to the node, and parsing continued with the next input + character. But it may be that instead of a single character the \N{} + expands to more than one, a named sequence. In this case any following + quantifier applies to the whole sequence, and it is easier, given the code + structure that calls this, to handle it from a different area of the code. + For this reason, the input parameters can be set so that it returns valid + only on one or the other of these cases. + + Another possibility is for the input to be an empty \N{}, which for + backwards compatibility we accept, but generate a NOTHING node which should + later get optimized out. This is handled from the area of code which can + handle a named sequence, so if called with the parameters for the other, it + fails. + + Still another possibility is for the \N to mean [^\n], and not a single + character or explicit sequence at all. This is determined by context. + Again, this is handled from the area of code which can handle a named + sequence, so if called with the parameters for the other, it also fails. + + And the final possibility is for the \N to be called from within a bracketed + character class. In this case the [^\n] meaning makes no sense, and so is + an error. Other anomalous situations are left to the calling code to handle. + + For non-single-quoted regexes, the tokenizer has attempted to decide which + of the above applies, and in the case of a named sequence, has converted it into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...}, where c1... are the characters in the sequence. For single-quoted regexes, the tokenizer passes the \N sequence through unchanged; this code will not attempt to determine this nor expand those, instead raising a syntax error. The net effect is that if the beginning of the passed-in pattern isn't '{U+' or there is no '}', it signals that this \N occurrence means to match a - non-newline. + non-newline. (This mostly was done because of [perl #56444].) - Only the \N{U+...} form should occur in a character class, for the same - reason that '.' inside a character class means to just match a period: it - just doesn't make sense. + The API is somewhat convoluted due to historical and the above reasons. The function raises an error (via vFAIL), and doesn't return for various - syntax errors. Otherwise it returns TRUE and sets or on - success; it returns FALSE otherwise. Returns FALSE, setting *flagp to - RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is - only possible if node_p is non-NULL. - + syntax errors. For other failures, it returns (STRLEN) -1. For successes, + it returns a count of how many characters were accounted for by it. (This + can be 0 for \N{}; 1 for it meaning [^\n]; and otherwise the number of code + points in the sequence. It sets , , and/or + on success. If is non-null, it means the caller can accept an input sequence - consisting of a just a single code point; <*valuep> is set to that value - if the input is such. - - If is non-null it signifies that the caller can accept any other - legal sequence (i.e., one that isn't just a single code point). <*node_p> - is set as follows: - 1) \N means not-a-NL: points to a newly created REG_ANY node; - 2) \N{}: points to a new NOTHING node; + consisting of a just a single code point; <*valuep> is set to the value + of the only or first code point in the input. + + If is non-null, it means the caller can accept an input + sequence consisting of one or more code points; <*substitute_parse> is a + newly created mortal SV* in this case, containing \x{} escapes representing + those code points. + + Both and can be non-NULL. + + If is non-null, must be NULL. This signifies + that the caller can accept any legal sequence other than a single code + point. To wit, <*node_p> is set as follows: + 1) \N means not-a-NL: points to a newly created REG_ANY node; return is 1 + 2) \N{}: points to a new NOTHING node; return is 0 3) otherwise: points to a new EXACT node containing the resolved - string. - Note that FALSE is returned for single code point sequences if is - null. + string; return is the number of code points in the + string. This will never be 1. + Note that failure is returned for single code point sequences if is + null and is not. */ char * endbrace; /* '}' following the name */ @@ -10775,6 +11058,8 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, stream */ bool has_multiple_chars; /* true if the input stream contains a sequence of more than one character */ + bool in_char_class = substitute_parse != NULL; + STRLEN count = 0; /* Number of characters in this sequence */ GET_RE_DEBUG_FLAGS_DECL; @@ -10783,6 +11068,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, GET_RE_DEBUG_FLAGS; assert(cBOOL(node_p) ^ cBOOL(valuep)); /* Exactly one should be set */ + assert(! (node_p && substitute_parse)); /* At most 1 should be set */ /* The [^\n] meaning of \N ignores spaces and comments under the /x * modifier. The other meaning does not, so use a temporary until we find @@ -10801,7 +11087,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, if (in_char_class) { vFAIL("\\N in a character class must be a named character: \\N{...}"); } - return FALSE; + return (STRLEN) -1; } RExC_parse--; /* Need to back off so nextchar() doesn't skip the current char */ @@ -10810,7 +11096,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, *flagp |= HASWIDTH|SIMPLE; RExC_naughty++; Set_Node_Length(*node_p, 1); /* MJD */ - return TRUE; + return 1; } /* Here, we have decided it should be a named character or sequence */ @@ -10837,28 +11123,14 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, } if (endbrace == RExC_parse) { /* empty: \N{} */ - bool ret = TRUE; if (node_p) { *node_p = reg_node(pRExC_state,NOTHING); } - else if (in_char_class) { - if (PASS2 && in_char_class) { - if (strict) { - RExC_parse++; /* Position after the "}" */ - vFAIL("Zero length \\N{}"); - } - else { - ckWARNreg(RExC_parse, - "Ignoring zero length \\N{} in character class"); - } - } - ret = FALSE; - } - else { - return FALSE; + else if (! in_char_class) { + return (STRLEN) -1; } nextchar(pRExC_state); - return ret; + return 0; } RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */ @@ -10870,90 +11142,103 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, * point, and is terminated by the brace */ has_multiple_chars = (endchar < endbrace); - if (valuep && (! has_multiple_chars || in_char_class)) { - /* We only pay attention to the first char of - multichar strings being returned in char classes. I kinda wonder - if this makes sense as it does change the behaviour - from earlier versions, OTOH that behaviour was broken - as well. XXX Solution is to recharacterize as - [rest-of-class]|multi1|multi2... */ - + /* We get the first code point if we want it, and either there is only one, + * or we can accept both cases of one and more than one */ + if (valuep && (substitute_parse || ! has_multiple_chars)) { STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse); I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_DISALLOW_PREFIX - | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); + | PERL_SCAN_DISALLOW_PREFIX + + /* No errors in the first pass (See [perl + * #122671].) We let the code below find the + * errors when there are multiple chars. */ + | ((SIZE_ONLY || has_multiple_chars) + ? PERL_SCAN_SILENT_ILLDIGIT + : 0); *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL); /* The tokenizer should have guaranteed validity, but it's possible to - * bypass it by using single quoting, so check */ - if (length_of_hex == 0 - || length_of_hex != (STRLEN)(endchar - RExC_parse) ) - { - RExC_parse += length_of_hex; /* Includes all the valid */ - RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */ - ? UTF8SKIP(RExC_parse) - : 1; - /* Guard against malformed utf8 */ - if (RExC_parse >= endchar) { - RExC_parse = endchar; + * bypass it by using single quoting, so check. Don't do the check + * here when there are multiple chars; we do it below anyway. */ + if (! has_multiple_chars) { + if (length_of_hex == 0 + || length_of_hex != (STRLEN)(endchar - RExC_parse) ) + { + RExC_parse += length_of_hex; /* Includes all the valid */ + RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */ + ? UTF8SKIP(RExC_parse) + : 1; + /* Guard against malformed utf8 */ + if (RExC_parse >= endchar) { + RExC_parse = endchar; + } + vFAIL("Invalid hexadecimal number in \\N{U+...}"); } - vFAIL("Invalid hexadecimal number in \\N{U+...}"); - } - if (in_char_class && has_multiple_chars) { - if (strict) { - RExC_parse = endbrace; - vFAIL("\\N{} in character class restricted to one character"); - } - else if (PASS2) { - ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class"); - } + RExC_parse = endbrace + 1; + return 1; } - - RExC_parse = endbrace + 1; } - else if (! node_p || ! has_multiple_chars) { - /* Here, the input is legal, but not according to the caller's - * options. We fail without advancing the parse, so that the - * caller can try again */ + /* Here, we should have already handled the case where a single character + * is expected and found. So it is a failure if we aren't expecting + * multiple chars and got them; or didn't get them but wanted them. We + * fail without advancing the parse, so that the caller can try again with + * different acceptance criteria */ + if ((! node_p && ! substitute_parse) || ! has_multiple_chars) { RExC_parse = p; - return FALSE; + return (STRLEN) -1; } - else { + + { /* What is done here is to convert this to a sub-pattern of the form - * (?:\x{char1}\x{char2}...) - * and then call reg recursively. That way, it retains its atomicness, - * while not having to worry about special handling that some code - * points may have. toke.c has converted the original Unicode values - * to native, so that we can just pass on the hex values unchanged. We - * do have to set a flag to keep recoding from happening in the - * recursion */ - - SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP); + * \x{char1}\x{char2}... + * and then either return it in <*substitute_parse> if non-null; or + * call reg recursively to parse it (enclosing in "(?: ... )" ). That + * way, it retains its atomicness, while not having to worry about + * special handling that some code points may have. toke.c has + * converted the original Unicode values to native, so that we can just + * pass on the hex values unchanged. We do have to set a flag to keep + * recoding from happening in the recursion */ + + SV * dummy = NULL; STRLEN len; char *orig_end = RExC_end; I32 flags; + if (substitute_parse) { + *substitute_parse = newSVpvs(""); + } + else { + substitute_parse = &dummy; + *substitute_parse = newSVpvs("?:"); + } + *substitute_parse = sv_2mortal(*substitute_parse); + while (RExC_parse < endbrace) { /* Convert to notation the rest of the code understands */ - sv_catpv(substitute_parse, "\\x{"); - sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse); - sv_catpv(substitute_parse, "}"); + sv_catpv(*substitute_parse, "\\x{"); + sv_catpvn(*substitute_parse, RExC_parse, endchar - RExC_parse); + sv_catpv(*substitute_parse, "}"); /* Point to the beginning of the next character in the sequence. */ RExC_parse = endchar + 1; endchar = RExC_parse + strcspn(RExC_parse, ".}"); + + count++; } - sv_catpv(substitute_parse, ")"); + if (! in_char_class) { + sv_catpv(*substitute_parse, ")"); + } - RExC_parse = SvPV(substitute_parse, len); + RExC_parse = SvPV(*substitute_parse, len); /* Don't allow empty number */ - if (len < 8) { + if (len < (STRLEN) ((substitute_parse) ? 6 : 8)) { + RExC_parse = endbrace; vFAIL("Invalid hexadecimal number in \\N{U+...}"); } RExC_end = RExC_parse + len; @@ -10961,15 +11246,17 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, /* The values are Unicode, and therefore not subject to recoding */ RExC_override_recoding = 1; - if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) { - if (flags & RESTART_UTF8) { - *flagp = RESTART_UTF8; - return FALSE; + if (node_p) { + if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return (STRLEN) -1; + } + FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", + (UV) flags); } - FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", - (UV) flags); + *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); } - *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); RExC_parse = endbrace; RExC_end = orig_end; @@ -10978,7 +11265,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, nextchar(pRExC_state); } - return TRUE; + return count; } @@ -11080,11 +11367,11 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, if (! len_passed_in) { if (UTF) { - if (UNI_IS_INVARIANT(code_point)) { + if (UVCHR_IS_INVARIANT(code_point)) { if (LOC || ! FOLD) { /* /l defers folding until runtime */ *character = (U8) code_point; } - else { /* Here is /i and not /l (toFOLD() is defined on just + else { /* Here is /i and not /l. (toFOLD() is defined on just ASCII, which isn't the same thing as INVARIANT on EBCDIC, but it works there, as the extra invariants fold to themselves) */ @@ -11115,7 +11402,10 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, ? FOLD_FLAGS_NOMIX_ASCII : 0)); if (downgradable - && folded == code_point + && folded == code_point /* This quickly rules out many + cases, avoiding the + _invlist_contains_cp() overhead + for those. */ && ! _invlist_contains_cp(PL_utf8_foldable, code_point)) { OP(node) = EXACT; @@ -11300,10 +11590,8 @@ tryagain: nextchar(pRExC_state); if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MBOL); - else if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SBOL); else - ret = reg_node(pRExC_state, BOL); + ret = reg_node(pRExC_state, SBOL); Set_Node_Length(ret, 1); /* MJD */ break; case '$': @@ -11312,10 +11600,8 @@ tryagain: RExC_seen_zerolen++; if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MEOL); - else if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SEOL); else - ret = reg_node(pRExC_state, EOL); + ret = reg_node(pRExC_state, SEOL); Set_Node_Length(ret, 1); /* MJD */ break; case '.': @@ -11404,6 +11690,11 @@ tryagain: case 'A': RExC_seen_zerolen++; ret = reg_node(pRExC_state, SBOL); + /* SBOL is shared with /^/ so we set the flags so we can tell + * /\A/ from /^/ in split. We check ret because first pass we + * have no regop struct to set the flags on. */ + if (PASS2) + ret->flags = 1; *flagp |= SIMPLE; goto finish_meta_pat; case 'G': @@ -11464,7 +11755,7 @@ tryagain: ret = reg_node(pRExC_state, op); FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; - if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { + if ((U8) *(RExC_parse + 1) == '{') { /* diag_listed_as: Use "%s" instead of "%s" */ vFAIL("Use \"\\b\\{\" instead of \"\\b{\""); } @@ -11482,7 +11773,7 @@ tryagain: ret = reg_node(pRExC_state, op); FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; - if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { + if ((U8) *(RExC_parse + 1) == '{') { /* diag_listed_as: Use "%s" instead of "%s" */ vFAIL("Use \"\\B\\{\" instead of \"\\B{\""); } @@ -11591,8 +11882,9 @@ tryagain: * special treatment for quantifiers is not needed for such single * character sequences */ ++RExC_parse; - if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE, - FALSE /* not strict */ )) { + if ((STRLEN) -1 == grok_bslash_N(pRExC_state, &ret, NULL, flagp, + depth, FALSE)) + { if (*flagp & RESTART_UTF8) return NULL; RExC_parse--; @@ -11893,10 +12185,12 @@ tryagain: * point sequence. Handle those in the switch() above * */ RExC_parse = p + 1; - if (! grok_bslash_N(pRExC_state, NULL, &ender, - flagp, depth, FALSE, - FALSE /* not strict */ )) - { + if ((STRLEN) -1 == grok_bslash_N(pRExC_state, NULL, + &ender, + flagp, + depth, + FALSE + )) { if (*flagp & RESTART_UTF8) FAIL("panic: grok_bslash_N set RESTART_UTF8"); RExC_parse = p = oldp; @@ -12182,7 +12476,7 @@ tryagain: * the simple case just below.) */ UV folded; - if (isASCII(ender)) { + if (isASCII_uni(ender)) { folded = toFOLD(ender); *(s)++ = (U8) folded; } @@ -13295,6 +13589,53 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl } } +STATIC AV * +S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count) +{ + /* This adds the string scalar to the array + * . is known to have exactly + * code points in it. This is used when constructing a + * bracketed character class and we find something that needs to match more + * than a single character. + * + * is actually an array of arrays. Each top-level + * element is an array that contains all the strings known so far that are + * the same length. And that length (in number of code points) is the same + * as the index of the top-level array. Hence, the [2] element is an + * array, each element thereof is a string containing TWO code points; + * while element [3] is for strings of THREE characters, and so on. Since + * this is for multi-char strings there can never be a [0] nor [1] element. + * + * When we rewrite the character class below, we will do so such that the + * longest strings are written first, so that it prefers the longest + * matching strings first. This is done even if it turns out that any + * quantifier is non-greedy, out of this programmer's (khw) laziness. Tom + * Christiansen has agreed that this is ok. This makes the test for the + * ligature 'ffi' come before the test for 'ff', for example */ + + AV* this_array; + AV** this_array_ptr; + + PERL_ARGS_ASSERT_ADD_MULTI_MATCH; + + if (! multi_char_matches) { + multi_char_matches = newAV(); + } + + if (av_exists(multi_char_matches, cp_count)) { + this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE); + this_array = *this_array_ptr; + } + else { + this_array = newAV(); + av_store(multi_char_matches, cp_count, + (SV*) this_array); + } + av_push(this_array, multi_string); + + return multi_char_matches; +} + /* The names of properties whose definitions are not known at compile time are * stored in this SV, after a constant heading. So if the length has been * changed since initialization, then there is a run-time definition. */ @@ -13477,7 +13818,6 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (UCHARAT(RExC_parse) == ']') goto charclassloop; -parseit: while (1) { if (RExC_parse >= stop_ptr) { break; @@ -13524,7 +13864,7 @@ parseit: } else { /* Is a backslash; get the code point of the char after it */ - if (UTF && ! UTF8_IS_INVARIANT(RExC_parse)) { + if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { value = utf8n_to_uvchr((U8*)RExC_parse, RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT); @@ -13557,19 +13897,58 @@ parseit: case 'H': namedclass = ANYOF_NHORIZWS; 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. */ - if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth, - TRUE, /* => charclass */ - strict)) - { - if (*flagp & RESTART_UTF8) - FAIL("panic: grok_bslash_N set RESTART_UTF8"); - goto parseit; + SV *as_text; + STRLEN cp_count = grok_bslash_N(pRExC_state, NULL, &value, + flagp, depth, &as_text); + if (*flagp & RESTART_UTF8) + FAIL("panic: grok_bslash_N set RESTART_UTF8"); + if (cp_count != 1) { /* The typical case drops through */ + assert(cp_count != (STRLEN) -1); + if (cp_count == 0) { + if (strict) { + RExC_parse++; /* Position after the "}" */ + vFAIL("Zero length \\N{}"); + } + else if (PASS2) { + ckWARNreg(RExC_parse, + "Ignoring zero length \\N{} in character class"); + } + } + else { /* cp_count > 1 */ + if (! RExC_in_multi_char_class) { + if (invert || range || *RExC_parse == '-') { + if (strict) { + RExC_parse--; + vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character"); + } + else if (PASS2) { + ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class"); + } + } + else { + multi_char_matches + = add_multi_match(multi_char_matches, + as_text, + cp_count); + } + break; /* contains the first code + point. Drop out of the switch to + process it */ + } + } /* End of cp_count != 1 */ + + /* This element should not be processed further in this + * class */ + element_count--; + value = save_value; + prevvalue = save_prevvalue; + continue; /* Back to top of loop to get next char */ } + /* Here, is a single code point, and contains it */ +#ifdef EBCDIC + /* We consider named characters to be literal characters */ + literal_endpoint++; +#endif } break; case 'p': @@ -14083,8 +14462,9 @@ parseit: continue; } - /* Here, we have a single value, and is the beginning of - * the range, if any; or if not */ + /* Here, we have a single value this time through the loop, and + * is the beginning of the range, if any; or if + * not. */ /* non-Latin1 code point implies unicode semantics. Must be set in * pass1 so is there for the whole of pass 2 */ @@ -14132,44 +14512,17 @@ parseit: * again. Otherwise add this character to the list of * multi-char folds. */ if (! RExC_in_multi_char_class) { - AV** this_array_ptr; - AV* this_array; STRLEN cp_count = utf8_length(foldbuf, foldbuf + foldlen); SV* multi_fold = sv_2mortal(newSVpvs("")); Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value); + multi_char_matches + = add_multi_match(multi_char_matches, + multi_fold, + cp_count); - if (! multi_char_matches) { - multi_char_matches = newAV(); - } - - /* is actually an array of arrays. - * There will be one or two top-level elements: [2], - * and/or [3]. The [2] element is an array, each - * element thereof is a character which folds to TWO - * characters; [3] is for folds to THREE characters. - * (Unicode guarantees a maximum of 3 characters in any - * fold.) When we rewrite the character class below, - * we will do so such that the longest folds are - * written first, so that it prefers the longest - * matching strings first. This is done even if it - * turns out that any quantifier is non-greedy, out of - * programmer laziness. Tom Christiansen has agreed - * that this is ok. This makes the test for the - * ligature 'ffi' come before the test for 'ff' */ - if (av_exists(multi_char_matches, cp_count)) { - this_array_ptr = (AV**) av_fetch(multi_char_matches, - cp_count, FALSE); - this_array = *this_array_ptr; - } - else { - this_array = newAV(); - av_store(multi_char_matches, cp_count, - (SV*) this_array); - } - av_push(this_array, multi_fold); } /* This element should not be processed further in this @@ -14200,19 +14553,20 @@ parseit: * included. literal_endpoint==2 means both ends of the range used * a literal character, not \x{foo} */ if (literal_endpoint == 2 - && ((prevvalue >= 'a' && value <= 'z') - || (prevvalue >= 'A' && value <= 'Z'))) + && ((isLOWER_A(prevvalue) && isLOWER_A(value)) + || (isUPPER_A(prevvalue) && isUPPER_A(value)))) { _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ASCII], &this_range); - /* Since this above only contains ascii, the intersection of it - * with anything will still yield only ascii */ + /* Since 'this_range' now only contains ascii, the intersection + * of it with anything will still yield only ascii */ _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ALPHA], &this_range); } _invlist_union(cp_foldable_list, this_range, &cp_foldable_list); literal_endpoint = 0; + SvREFCNT_dec_NN(this_range); #endif } @@ -14283,6 +14637,7 @@ parseit: RExC_parse = SvPV(substitute_parse, len); RExC_end = RExC_parse + len; RExC_in_multi_char_class = 1; + RExC_override_recoding = 1; RExC_emit = (regnode *)orig_emit; ret = reg(pRExC_state, 1, ®_flags, depth+1); @@ -14292,6 +14647,7 @@ parseit: RExC_parse = save_parse; RExC_end = save_end; RExC_in_multi_char_class = 0; + RExC_override_recoding = 0; SvREFCNT_dec_NN(multi_char_matches); return ret; } @@ -15273,21 +15629,23 @@ S_nextchar(pTHX_ RExC_state_t *pRExC_state) } } -/* -- reg_node - emit a node -*/ -STATIC regnode * /* Location. */ -S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) +STATIC regnode * +S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name) { - regnode *ptr; + /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra + * space. In pass1, it aligns and increments RExC_size; in pass2, + * RExC_emit */ + regnode * const ret = RExC_emit; GET_RE_DEBUG_FLAGS_DECL; - PERL_ARGS_ASSERT_REG_NODE; + PERL_ARGS_ASSERT_REGNODE_GUTS; + + assert(extra_size >= regarglen[op]); if (SIZE_ONLY) { SIZE_ALIGN(RExC_size); - RExC_size += 1; + RExC_size += 1 + extra_size; return(ret); } if (RExC_emit >= RExC_emit_bound) @@ -15295,13 +15653,13 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) op, (void*)RExC_emit, (void*)RExC_emit_bound); NODE_ALIGN_FILL(ret); - ptr = ret; - FILL_ADVANCE_NODE(ptr, op); -#ifdef RE_TRACK_PATTERN_OFFSETS +#ifndef RE_TRACK_PATTERN_OFFSETS + PERL_UNUSED_ARG(name); +#else if (RExC_offsets) { /* MJD */ MJD_OFFSET_DEBUG( ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", - "reg_node", __LINE__, + name, __LINE__, PL_reg_name[op], (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", @@ -15311,7 +15669,26 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) Set_Node_Offset(RExC_emit, RExC_parse + (op == END)); } #endif - RExC_emit = ptr; + return(ret); +} + +/* +- reg_node - emit a node +*/ +STATIC regnode * /* Location. */ +S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) +{ + regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node"); + + PERL_ARGS_ASSERT_REG_NODE; + + assert(regarglen[op] == 0); + + if (PASS2) { + regnode *ptr = ret; + FILL_ADVANCE_NODE(ptr, op); + RExC_emit = ptr; + } return(ret); } @@ -15321,54 +15698,36 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) STATIC regnode * /* Location. */ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) { - regnode *ptr; - regnode * const ret = RExC_emit; - GET_RE_DEBUG_FLAGS_DECL; + regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode"); PERL_ARGS_ASSERT_REGANODE; - if (SIZE_ONLY) { - SIZE_ALIGN(RExC_size); - RExC_size += 2; - /* - We can't do this: + assert(regarglen[op] == 1); - assert(2==regarglen[op]+1); + if (PASS2) { + regnode *ptr = ret; + FILL_ADVANCE_NODE_ARG(ptr, op, arg); + RExC_emit = ptr; + } + return(ret); +} - Anything larger than this has to allocate the extra amount. - If we changed this to be: +STATIC regnode * +S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2) +{ + /* emit a node with U32 and I32 arguments */ - RExC_size += (1 + regarglen[op]); + regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode"); - then it wouldn't matter. Its not clear what side effect - might come from that so its not done so far. - -- dmq - */ - return(ret); - } - if (RExC_emit >= RExC_emit_bound) - Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p", - op, (void*)RExC_emit, (void*)RExC_emit_bound); + PERL_ARGS_ASSERT_REG2LANODE; - NODE_ALIGN_FILL(ret); - ptr = ret; - FILL_ADVANCE_NODE_ARG(ptr, op, arg); -#ifdef RE_TRACK_PATTERN_OFFSETS - if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG( - ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", - "reganode", - __LINE__, - PL_reg_name[op], - (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? - "Overwriting end of array!\n" : "OK", - (UV)(RExC_emit - RExC_emit_start), - (UV)(RExC_parse - RExC_start), - (UV)RExC_offsets[0])); - Set_Cur_Node_Offset; + assert(regarglen[op] == 2); + + if (PASS2) { + regnode *ptr = ret; + FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2); + RExC_emit = ptr; } -#endif - RExC_emit = ptr; return(ret); } @@ -15498,11 +15857,10 @@ S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, for (;;) { regnode * const temp = regnext(scan); DEBUG_PARSE_r({ - SV * const mysv=sv_newmortal(); DEBUG_PARSE_MSG((scan==p ? "tail" : "")); - regprop(RExC_rx, mysv, scan, NULL); + regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n", - SvPV_nolen_const(mysv), REG_NODE_NUM(scan), + SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan), (temp == NULL ? "->" : ""), (temp == NULL ? PL_reg_name[OP(val)] : "") ); @@ -15587,11 +15945,10 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, } } DEBUG_PARSE_r({ - SV * const mysv=sv_newmortal(); DEBUG_PARSE_MSG((scan==p ? "tsdy" : "")); - regprop(RExC_rx, mysv, scan, NULL); + regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n", - SvPV_nolen_const(mysv), + SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan), PL_reg_name[exact]); }); @@ -15600,12 +15957,11 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, scan = temp; } DEBUG_PARSE_r({ - SV * const mysv_val=sv_newmortal(); DEBUG_PARSE_MSG(""); - regprop(RExC_rx, mysv_val, val, NULL); + regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state); PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n", - SvPV_nolen_const(mysv_val), + SvPV_nolen_const(RExC_mysv), (IV)REG_NODE_NUM(val), (IV)(val - scan) ); @@ -15757,13 +16113,11 @@ Perl_regdump(pTHX_ const regexp *r) PerlIO_printf(Perl_debug_log, ") "); if (ri->regstclass) { - regprop(r, sv, ri->regstclass, NULL); + regprop(r, sv, ri->regstclass, NULL, NULL); PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv)); } if (r->intflags & PREGf_ANCH) { PerlIO_printf(Perl_debug_log, "anchored"); - if (r->intflags & PREGf_ANCH_BOL) - PerlIO_printf(Perl_debug_log, "(BOL)"); if (r->intflags & PREGf_ANCH_MBOL) PerlIO_printf(Perl_debug_log, "(MBOL)"); if (r->intflags & PREGf_ANCH_SBOL) @@ -15798,7 +16152,7 @@ Perl_regdump(pTHX_ const regexp *r) */ void -Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo) +Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state) { #ifdef DEBUGGING int k; @@ -15853,7 +16207,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ PERL_ARGS_ASSERT_REGPROP; - sv_setpvs(sv, ""); + 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 @@ -15921,19 +16275,23 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { + AV *name_list= NULL; Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ if ( RXp_PAREN_NAMES(prog) ) { + name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); + } else if ( pRExC_state ) { + name_list= RExC_paren_name_list; + } + if (name_list) { if ( k != REF || (OP(o) < NREF)) { - AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); - SV **name= av_fetch(list, ARG(o), 0 ); + SV **name= av_fetch(name_list, ARG(o), 0 ); if (name) Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); } else { - AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]); SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]); I32 *nums=(I32*)SvPVX(sv_dat); - SV **name= av_fetch(list, nums[0], 0 ); + SV **name= av_fetch(name_list, nums[0], 0 ); I32 n; if (name) { for ( n=0; ndata->data[progi->name_list_idx]); + } else if ( pRExC_state ) { + name_list= RExC_paren_name_list; + } + /* Paren and offset */ Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); + if (name_list) { + SV **name= av_fetch(name_list, ARG(o), 0 ); + if (name) + Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); + } + } else if (k == VERB) { if (!o->flags) Perl_sv_catpvf(aTHX_ sv, ":%"SVf, @@ -16125,12 +16496,15 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags)); + else if (OP(o) == SBOL) + Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(o); PERL_UNUSED_ARG(prog); PERL_UNUSED_ARG(reginfo); + PERL_UNUSED_ARG(pRExC_state); #endif /* DEBUGGING */ } @@ -16697,35 +17071,6 @@ S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...) Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf)); } -/* XXX Here's a total kludge. But we need to re-enter for swash routines. */ - -#ifndef PERL_IN_XSUB_RE -void -Perl_save_re_context(pTHX) -{ - /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ - if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { - U32 i; - for (i = 1; i <= RX_NPARENS(rx); i++) { - char digits[TYPE_CHARS(long)]; - const STRLEN len = my_snprintf(digits, sizeof(digits), - "%lu", (long)i); - GV *const *const gvp - = (GV**)hv_fetch(PL_defstash, digits, len, 0); - - if (gvp) { - GV * const gv = *gvp; - if (SvTYPE(gv) == SVt_PVGV && GvSV(gv)) - save_scalar(gv); - } - } - } - } -} -#endif - #ifdef DEBUGGING /* Certain characters are output as a sequence with the first being a * backslash. */ @@ -16759,10 +17104,6 @@ S_put_code_point(pTHX_ SV *sv, UV c) #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C -#ifndef MIN -#define MIN(a,b) ((a) < (b) ? (a) : (b)) -#endif - STATIC void S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals) { @@ -17072,7 +17413,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } else CLEAR_OPTSTART; - regprop(r, sv, node, NULL); + regprop(r, sv, node, NULL, NULL); PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start), (int)(2*indent + 1), "", SvPVX_const(sv));