X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9568fada7542fc679689dce1b4a179919efbb71d..5e2adf8597b4131da54f048b3d903feb3849164a:/regcomp.c diff --git a/regcomp.c b/regcomp.c index a6979d7..20824e1 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) == '?') @@ -377,24 +410,6 @@ typedef struct scan_data_t { regnode_ssc *start_class; } scan_data_t; -/* The below is perhaps overboard, but this allows us to save a test at the - * expense of a mask. This is because on both EBCDIC and ASCII machines, 'A' - * and 'a' differ by a single bit; the same with the upper and lower case of - * all other ASCII-range alphabetics. On ASCII platforms, they are 32 apart; - * on EBCDIC, they are 64. This uses an exclusive 'or' to find that bit and - * then inverts it to form a mask, with just a single 0, in the bit position - * where the upper- and lowercase differ. XXX There are about 40 other - * instances in the Perl core where this micro-optimization could be used. - * Should decide if maintenance cost is worse, before changing those - * - * Returns a boolean as to whether or not 'v' is either a lowercase or - * uppercase instance of 'c', where 'c' is in [A-Za-z]. If 'c' is a - * compile-time constant, the generated code is better than some optimizing - * compilers figure out, amounting to a mask and test. The results are - * meaningless if 'c' is not one of [A-Za-z] */ -#define isARG2_lower_or_UPPER_ARG1(c, v) \ - (((v) & ~('A' ^ 'a')) == ((c) & ~('A' ^ 'a'))) - /* * Forward declarations for pregcomp()'s friends. */ @@ -429,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) @@ -513,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 @@ -588,80 +608,85 @@ static const scan_data_t zero_scan_data = REPORT_LOCATION_ARGS(offset)); \ } STMT_END +/* These have asserts in them because of [perl #122671] Many warnings in + * regcomp.c can occur twice. If they get output in pass1 and later in that + * pass, the pattern has to be converted to UTF-8 and the pass restarted, they + * would get output again. So they should be output in pass2, and these + * asserts make sure new warnings follow that paradigm. */ /* m is not necessarily a "literal string", in this macro */ #define reg_warn_non_literal_string(loc, m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \ m, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNreg(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN_dep(loc, m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNregdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN2reg_d(loc,m, a1) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ a1, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN2reg(loc, m, a1) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN3(loc, m, a1, a2) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN3reg(loc, m, a1, a2) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN4(loc, m, a1, a2, a3) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \ } STMT_END @@ -784,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 " : "" \ @@ -818,6 +872,33 @@ DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log,"\n"); \ }); +#ifdef DEBUGGING + +/* is c a control character for which we have a mnemonic? */ +#define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) + +STATIC const char * +S_cntrl_to_mnemonic(const U8 c) +{ + /* Returns the mnemonic string that represents character 'c', if one + * exists; NULL otherwise. The only ones that exist for the purposes of + * this routine are a few control characters */ + + switch (c) { + case '\a': return "\\a"; + case '\b': return "\\b"; + case ESC_NATIVE: return "\\e"; + case '\f': return "\\f"; + case '\n': return "\\n"; + case '\r': return "\\r"; + case '\t': return "\\t"; + } + + return NULL; +} + +#endif + /* Mark that we cannot extend a found fixed substring at this point. Update the longest found anchored substring and the longest found floating substrings if needed. */ @@ -891,7 +972,7 @@ S_ssc_anything(pTHX_ regnode_ssc *ssc) ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */ _append_range_to_invlist(ssc->invlist, 0, UV_MAX); - ANYOF_FLAGS(ssc) |= ANYOF_EMPTY_STRING; /* Plus match empty string */ + ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING; /* Plus matches empty */ } STATIC int @@ -909,7 +990,7 @@ S_ssc_is_anything(const regnode_ssc *ssc) assert(is_ANYOF_SYNTHETIC(ssc)); - if (! (ANYOF_FLAGS(ssc) & ANYOF_EMPTY_STRING)) { + if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) { return FALSE; } @@ -948,7 +1029,7 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) Zero(ssc, 1, regnode_ssc); set_ANYOF_SYNTHETIC(ssc); - ARG_SET(ssc, ANYOF_NONBITMAP_EMPTY); + ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP); ssc_anything(ssc); /* If any portion of the regex is to operate under locale rules, @@ -1018,7 +1099,7 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC; /* Look at the data structure created by S_set_ANYOF_arg() */ - if (n != ANYOF_NONBITMAP_EMPTY) { + if (n != ANYOF_ONLY_HAS_BITMAP) { SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]); AV * const av = MUTABLE_AV(SvRV(rv)); SV **const ary = AvARRAY(av); @@ -1048,15 +1129,16 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, } } - /* An ANYOF node contains a bitmap for the first 256 code points, and an - * inversion list for the others, but if there are code points that should - * match only conditionally on the target string being UTF-8, those are - * placed in the inversion list, and not the bitmap. Since there are - * circumstances under which they could match, they are included in the - * SSC. But if the ANYOF node is to be inverted, we have to exclude them - * here, so that when we invert below, the end result actually does include - * them. (Think about "\xe0" =~ /[^\xc0]/di;). We have to do this here - * before we add the unconditionally matched code points */ + /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS + * code points, and an inversion list for the others, but if there are code + * points that should match only conditionally on the target string being + * UTF-8, those are placed in the inversion list, and not the bitmap. + * Since there are circumstances under which they could match, they are + * included in the SSC. But if the ANYOF node is to be inverted, we have + * to exclude them here, so that when we invert below, the end result + * actually does include them. (Think about "\xe0" =~ /[^\xc0]/di;). We + * have to do this here before we add the unconditionally matched code + * points */ if (ANYOF_FLAGS(node) & ANYOF_INVERT) { _invlist_intersection_complement_2nd(invlist, PL_UpperLatin1, @@ -1064,7 +1146,7 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, } /* Add in the points from the bit map */ - for (i = 0; i < 256; i++) { + for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) { if (ANYOF_BITMAP_TEST(node, i)) { invlist = add_cp_to_invlist(invlist, i); new_node_has_latin1 = TRUE; @@ -1073,13 +1155,13 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, /* If this can match all upper Latin1 code points, have to add them * as well */ - if (ANYOF_FLAGS(node) & ANYOF_NON_UTF8_NON_ASCII_ALL) { + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) { _invlist_union(invlist, PL_UpperLatin1, &invlist); } /* Similarly for these */ - if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) { - invlist = _add_range_to_invlist(invlist, 256, UV_MAX); + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { + _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist); } if (ANYOF_FLAGS(node) & ANYOF_INVERT) { @@ -1112,8 +1194,8 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX) /* 'AND' a given class with another one. Can create false positives. 'ssc' - * should not be inverted. 'and_with->flags & ANYOF_POSIXL' should be 0 if - * 'and_with' is a regnode_charclass instead of a regnode_ssc. */ + * should not be inverted. 'and_with->flags & ANYOF_MATCHES_POSIXL' should be + * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */ STATIC void S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, @@ -1204,7 +1286,7 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, /* If either P1 or P2 is empty, the intersection will be also; can skip * the loop */ - if (! (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) { + if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) { ANYOF_POSIXL_ZERO(ssc); } else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { @@ -1263,16 +1345,16 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, else { ssc->invlist = anded_cp_list; ANYOF_POSIXL_ZERO(ssc); - if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) { + if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc); } } } else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc) - || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) + || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) { /* One or the other of P1, P2 is non-empty. */ - if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) { + if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc); } ssc_union(ssc, anded_cp_list, FALSE); @@ -1334,7 +1416,7 @@ S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, { /* We ignore P2, leaving P1 going forward */ } /* else Not inverted */ - else if (ANYOF_FLAGS(or_with) & ANYOF_POSIXL) { + else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc); if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { unsigned int i; @@ -1423,12 +1505,78 @@ 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) { /* The inversion list in the SSC is marked mortal; now we need a more * permanent copy, which is stored the same way that is done in a regular - * ANYOF node, with the first 256 code points in a bit map */ + * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit + * map */ SV* invlist = invlist_clone(ssc->invlist); @@ -1437,8 +1585,8 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) assert(is_ANYOF_SYNTHETIC(ssc)); /* The code in this file assumes that all but these flags aren't relevant - * to the SSC, except ANYOF_EMPTY_STRING, which should be cleared by the - * time we reach here */ + * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared + * by the time we reach here */ assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS)); populate_ANYOF_from_invlist( (regnode *) ssc, &invlist); @@ -1450,7 +1598,7 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) ssc->invlist = NULL; if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { - ANYOF_FLAGS(ssc) |= ANYOF_POSIXL; + ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL; } assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale); @@ -3114,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: @@ -3516,8 +3664,8 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, } if (len == 2 - && isARG2_lower_or_UPPER_ARG1('s', *s) - && isARG2_lower_or_UPPER_ARG1('s', *(s+1))) + && isALPHA_FOLD_EQ(*s, 's') + && isALPHA_FOLD_EQ(*(s+1), 's')) { /* EXACTF nodes need to know that the minimum length @@ -3563,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 @@ -3610,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); @@ -3620,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",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); @@ -3682,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 @@ -3714,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; @@ -3725,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; @@ -3740,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) { @@ -3865,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 @@ -3883,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 ) ); }); @@ -3964,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), @@ -4072,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 ) { @@ -4112,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; @@ -4136,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 { @@ -4169,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 @@ -4182,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); @@ -4251,7 +4498,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * can't match null string */ if (flags & SCF_DO_STCLASS_AND) { ssc_cp_and(data->start_class, uc); - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ssc_clear_locale(data->start_class); } else if (flags & SCF_DO_STCLASS_OR) { @@ -4259,12 +4506,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } 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 @@ -4434,7 +4681,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } if (flags & SCF_DO_STCLASS_AND) { - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ANYOF_POSIXL_ZERO(data->start_class); ssc_intersection(data->start_class, EXACTF_invlist, FALSE); } @@ -4443,7 +4690,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; SvREFCNT_dec(EXACTF_invlist); @@ -4562,7 +4809,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS_AND; StructCopy(&this_class, data->start_class, regnode_ssc); flags |= SCF_DO_STCLASS_OR; - ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + |= SSC_MATCHES_EMPTY_STRING; } } else { /* Non-zero len */ if (flags & SCF_DO_STCLASS_OR) { @@ -4858,7 +5106,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", ssc_intersection(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); ssc_clear_locale(data->start_class); - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + &= ~SSC_MATCHES_EMPTY_STRING; } else if (flags & SCF_DO_STCLASS_OR) { ssc_union(data->start_class, @@ -4868,7 +5117,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", /* See commit msg for * 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + &= ~SSC_MATCHES_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; } @@ -4895,7 +5145,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", U8 namedclass; /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; /* Some of the logic below assumes that switching locale on will only add false positives. */ @@ -5043,7 +5293,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", else if ( PL_regkind[OP(scan)] == BRANCHJ /* Lookbehind, or need to calculate parens/evals/stclass: */ && (scan->flags || data || (flags & SCF_DO_STCLASS)) - && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) { + && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) + { if ( OP(scan) == UNLESSM && scan->flags == 0 && OP(NEXTOPER(NEXTOPER(scan))) == NOTHING && @@ -5052,14 +5303,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) ); @@ -5083,7 +5333,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; @@ -5131,8 +5381,12 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", */ ssc_init(pRExC_state, data->start_class); } else { - /* AND before and after: combine and continue */ + /* AND before and after: combine and continue. These + * assertions are zero-length, so can match an EMPTY + * string */ ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); + ANYOF_FLAGS(data->start_class) + |= SSC_MATCHES_EMPTY_STRING; } } } @@ -5204,6 +5458,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", if (f & SCF_DO_STCLASS_AND) { ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); + ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; } if (data) { if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) @@ -5322,7 +5577,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; @@ -5445,16 +5700,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; } @@ -5645,9 +5903,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; @@ -5655,32 +5913,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; @@ -5750,7 +6003,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, if (oplist) { assert(oplist->op_type == OP_PADAV || oplist->op_type == OP_RV2AV); - oplist = oplist->op_sibling;; + oplist = OP_SIBLING(oplist); } if (SvRMAGICAL(av)) { @@ -5797,10 +6050,10 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, pRExC_state->code_blocks[n].src_regex = NULL; n++; code = 1; - oplist = oplist->op_sibling; /* skip CONST */ + oplist = OP_SIBLING(oplist); /* skip CONST */ assert(oplist); } - oplist = oplist->op_sibling;; + oplist = OP_SIBLING(oplist);; } /* apply magic and QR overloading to arg */ @@ -6034,7 +6287,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 @@ -6283,6 +6535,13 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist); PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist); + + /* This is calculated here, because the Perl program that generates the + * static global ones doesn't currently have access to + * NUM_ANYOF_CODE_POINTS */ + PL_InBitmap = _new_invlist(2); + PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0, + NUM_ANYOF_CODE_POINTS - 1); } #endif @@ -6298,7 +6557,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *o; int ncode = 0; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) ncode++; /* count of DO blocks */ if (ncode) { @@ -6319,7 +6578,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (expr->op_type == OP_CONST) n = 1; else - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) n++; } @@ -6335,7 +6594,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (expr->op_type == OP_CONST) new_patternp[n] = cSVOPx_sv(expr); else - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) new_patternp[n++] = cSVOPo_sv; } @@ -6355,7 +6614,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, assert( expr->op_type == OP_PUSHMARK || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK) || expr->op_type == OP_PADRANGE); - expr = expr->op_sibling; + expr = OP_SIBLING(expr); } pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count, @@ -6400,7 +6659,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); @@ -6734,10 +7000,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) { @@ -6845,9 +7116,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; } @@ -7000,8 +7269,8 @@ reStudy: if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset) && stclass_flag - && ! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING) - && !ssc_is_anything(data.start_class)) + && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) + && is_ssc_worth_it(pRExC_state, data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7014,7 +7283,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));}); @@ -7080,8 +7349,8 @@ reStudy: r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8 = r->float_substr = r->float_utf8 = NULL; - if (! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING) - && ! ssc_is_anything(data.start_class)) + if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) + && is_ssc_worth_it(pRExC_state, data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7094,7 +7363,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,8 +7382,8 @@ 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" maxlen:%ld\n", - (IV)minlen, (IV)r->minlen, RExC_maxlen); + PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n", + (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen); }); r->minlenret = minlen; if (r->minlen < minlen) @@ -7164,7 +7433,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 @@ -7200,7 +7474,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"); @@ -7738,22 +8015,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) \ @@ -9248,6 +9523,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; @@ -9275,7 +9551,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) { @@ -9353,7 +9629,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) /*NOTREACHED*/ case ONCE_PAT_MOD: /* 'o' */ case GLOBAL_PAT_MOD: /* 'g' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + if (PASS2 && ckWARN(WARN_REGEXP)) { const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; @@ -9373,7 +9649,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) break; case CONTINUE_PAT_MOD: /* 'c' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + if (PASS2 && ckWARN(WARN_REGEXP)) { if (! (wastedflags & WASTED_C) ) { wastedflags |= WASTED_GC; /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ @@ -9388,7 +9664,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) break; case KEEPCOPY_PAT_MOD: /* 'p' */ if (flagsp == &negflags) { - if (SIZE_ONLY) + if (PASS2) ckWARNreg(RExC_parse + 1,"Useless use of (?-p)"); } else { *flagsp |= RXf_PMf_KEEPCOPY; @@ -9412,6 +9688,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: @@ -9425,6 +9704,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); + } } /* @@ -9605,6 +9888,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) else if (*RExC_parse == '?') { /* (?...) */ bool is_logical = 0; const char * const seqstart = RExC_parse; + const char * endptr; if (has_intervening_patws) { RExC_parse++; vFAIL("In '(?...)', the '(' and '?' must be adjacent"); @@ -9814,12 +10098,21 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) 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++; + { + bool is_neg = FALSE; + parse_start = RExC_parse - 1; /* MJD */ + if (*RExC_parse == '-') { + RExC_parse++; + is_neg = TRUE; + } + num = grok_atou(RExC_parse, &endptr); + if (endptr) + RExC_parse = (char*)endptr; + if (is_neg) { + /* Some limit for num? */ + num = -num; + } + } if (*RExC_parse!=')') vFAIL("Expecting close bracket"); @@ -9845,21 +10138,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, "| |", 1 + depth * 2, "", (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 */ @@ -9922,17 +10213,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; @@ -9940,6 +10236,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] == '<' @@ -9959,6 +10256,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) REGTAIL(pRExC_state, ret, tail); goto insert_if; } + /* Fall through to ‘Unknown switch condition’ at the + end of the if/else chain. */ } else if ( RExC_parse[0] == '<' /* (?()...) */ || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ @@ -9980,15 +10279,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; } @@ -9996,9 +10291,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; parno = 0; if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { - parno = atoi(RExC_parse++); - while (isDIGIT(*RExC_parse)) - RExC_parse++; + parno = grok_atou(RExC_parse, &endptr); + if (endptr) + RExC_parse = (char*)endptr; } else if (RExC_parse[0] == '&') { SV *sv_dat; RExC_parse++; @@ -10015,10 +10310,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* (?(1)...) */ char c; char *tmp; - parno = atoi(RExC_parse++); - - while (isDIGIT(*RExC_parse)) - RExC_parse++; + parno = grok_atou(RExC_parse, &endptr); + if (endptr) + RExC_parse = (char*)endptr; ret = reganode(pRExC_state, GROUPP, parno); insert_if_check_paren: @@ -10068,8 +10362,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) { @@ -10083,10 +10381,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) but I can't figure out why. -- dmq*/ return ret; } - else { - RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; - vFAIL("Unknown switch condition (?(...))"); - } + RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; + vFAIL("Unknown switch condition (?(...))"); } case '[': /* (?[ ... ]) */ return handle_regex_sets(pRExC_state, NULL, flagp, depth, @@ -10123,7 +10419,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, "| |", 1+2 * depth, "", (IV)parno, REG_NODE_NUM(ret))); RExC_open_parens[parno-1]= ret; } @@ -10212,8 +10509,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, "| |", 1+2 * depth, "", (IV)parno, REG_NODE_NUM(ender))); RExC_close_parens[parno-1]= ender; if (RExC_nestroot == parno) RExC_nestroot = 0; @@ -10239,15 +10536,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) ); @@ -10280,15 +10575,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) ); @@ -10492,15 +10785,16 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) next++; } if (*next == '}') { /* got one */ + const char* endptr; if (!maxpos) maxpos = next; RExC_parse++; - min = atoi(RExC_parse); + min = grok_atou(RExC_parse, &endptr); if (*maxpos == ',') maxpos++; else maxpos = RExC_parse; - max = atoi(maxpos); + max = grok_atou(maxpos, &endptr); if (!max && *maxpos != '0') max = REG_INFTY; /* meaning "infinity" */ else if (max >= REG_INFTY) @@ -10510,7 +10804,6 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) if (max < min) { /* If can't match, warn and optimize to fail unconditionally */ if (SIZE_ONLY) { - ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); /* We can't back off the size because we have to reserve * enough space for all the things we are about to throw @@ -10519,6 +10812,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL]; } else { + ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); RExC_emit = orig_emit; } ret = reg_node(pRExC_state, OPFAIL); @@ -10528,7 +10822,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) && RExC_parse < RExC_end && (*RExC_parse == '?' || *RExC_parse == '+')) { - if (SIZE_ONLY) { + if (PASS2) { ckWARN2reg(RExC_parse + 1, "Useless use of greediness modifier '%c'", *RExC_parse); @@ -10674,10 +10968,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 ) { @@ -10685,46 +10978,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 */ @@ -10733,6 +11055,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; @@ -10741,6 +11065,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 @@ -10759,7 +11084,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 */ @@ -10768,7 +11093,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 */ @@ -10795,28 +11120,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 (SIZE_ONLY && 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 */ @@ -10828,90 +11139,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 { - 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; @@ -10919,15 +11243,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; @@ -10936,7 +11262,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, nextchar(pRExC_state); } - return TRUE; + return count; } @@ -11038,19 +11364,25 @@ 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) */ *character = toFOLD((U8) code_point); - if (downgradable - && *character == code_point - && ! HAS_NONLATIN1_FOLD_CLOSURE(code_point)) - { + + /* We can downgrade to an EXACT node if this character + * isn't a folding one. Note that this assumes that + * nothing above Latin1 folds to some other invariant than + * one of these alphabetics; otherwise we would also have + * to check: + * && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point) + * || ASCII_FOLD_RESTRICTED)) + */ + if (downgradable && PL_fold[code_point] == code_point) { OP(node) = EXACT; } } @@ -11067,7 +11399,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; @@ -11147,18 +11482,17 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, } -/* return atoi(p), unless it's too big to sensibly be a backref, +/* Parse backref decimal value, unless it's too big to sensibly be a backref, * in which case return I32_MAX (rather than possibly 32-bit wrapping) */ static I32 S_backref_value(char *p) { - char *q = p; - - for (;isDIGIT(*q); q++) {} /* calculate length of num */ - if (q - p == 0 || q - p > 9) + const char* endptr; + UV val = grok_atou(p, &endptr); + if (endptr == p || endptr == NULL || val > I32_MAX) return I32_MAX; - return atoi(p); + return (I32)val; } @@ -11253,10 +11587,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 '$': @@ -11265,10 +11597,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 '.': @@ -11357,6 +11687,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': @@ -11388,6 +11723,9 @@ tryagain: ret = reg_node(pRExC_state, CANY); RExC_seen |= REG_CANY_SEEN; *flagp |= HASWIDTH|SIMPLE; + if (PASS2) { + ckWARNdep(RExC_parse+1, "\\C is deprecated"); + } goto finish_meta_pat; case 'X': ret = reg_node(pRExC_state, CLUMP); @@ -11414,7 +11752,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{\""); } @@ -11432,7 +11770,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{\""); } @@ -11541,8 +11879,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--; @@ -11843,10 +12182,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; @@ -11870,11 +12211,11 @@ tryagain: p++; break; case 'e': - ender = ASCII_TO_NATIVE('\033'); + ender = ESC_NATIVE; p++; break; case 'a': - ender = '\a'; + ender = '\a'; p++; break; case 'o': @@ -11885,7 +12226,7 @@ tryagain: bool valid = grok_bslash_o(&p, &result, &error_msg, - TRUE, /* out warnings */ + PASS2, /* out warnings */ FALSE, /* not strict */ TRUE, /* Output warnings for non- @@ -11914,7 +12255,7 @@ tryagain: bool valid = grok_bslash_x(&p, &result, &error_msg, - TRUE, /* out warnings */ + PASS2, /* out warnings */ FALSE, /* not strict */ TRUE, /* Output warnings for non- @@ -11937,7 +12278,7 @@ tryagain: } case 'c': p++; - ender = grok_bslash_c(*p++, SIZE_ONLY); + ender = grok_bslash_c(*p++, PASS2); break; case '8': case '9': /* must be a backreference */ --p; @@ -11976,7 +12317,7 @@ tryagain: REQUIRE_UTF8; } p += numlen; - if (SIZE_ONLY /* like \08, \178 */ + if (PASS2 /* like \08, \178 */ && numlen < 3 && p < RExC_end && isDIGIT(*p) && ckWARN(WARN_REGEXP)) @@ -11993,7 +12334,7 @@ tryagain: if (! RExC_override_recoding) { SV* enc = PL_encoding; ender = reg_recode((const char)(U8)ender, &enc); - if (!enc && SIZE_ONLY) + if (!enc && PASS2) ckWARNreg(p, "Invalid escape in the specified encoding"); REQUIRE_UTF8; } @@ -12110,9 +12451,8 @@ tryagain: && (PL_fold[ender] != PL_fold_latin1[ender] || ender == LATIN_SMALL_LETTER_SHARP_S || (len > 0 - && isARG2_lower_or_UPPER_ARG1('s', ender) - && isARG2_lower_or_UPPER_ARG1('s', - *(s-1))))) + && isALPHA_FOLD_EQ(ender, 's') + && isALPHA_FOLD_EQ(*(s-1), 's')))) { maybe_exactfu = FALSE; } @@ -12296,7 +12636,7 @@ tryagain: * as if it turns into an EXACTFU, it could later get * joined with another 's' that would then wrongly match * the sharp s */ - if (maybe_exactfu && isARG2_lower_or_UPPER_ARG1('s', ender)) + if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's')) { maybe_exactfu = FALSE; } @@ -12445,22 +12785,24 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) UV high; int i; - if (end == UV_MAX && start <= 256) { - ANYOF_FLAGS(node) |= ANYOF_ABOVE_LATIN1_ALL; + if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) { + ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP; } - else if (end >= 256) { - ANYOF_FLAGS(node) |= ANYOF_UTF8; + else if (end >= NUM_ANYOF_CODE_POINTS) { + ANYOF_FLAGS(node) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES; } /* Quit if are above what we should change */ - if (start > 255) { + if (start >= NUM_ANYOF_CODE_POINTS) { break; } change_invlist = TRUE; /* Set all the bits in the range, up to the max that we are doing */ - high = (end < 255) ? end : 255; + high = (end < NUM_ANYOF_CODE_POINTS - 1) + ? end + : NUM_ANYOF_CODE_POINTS - 1; for (i = start; i <= (int) high; i++) { if (! ANYOF_BITMAP_TEST(node, i)) { ANYOF_BITMAP_SET(node, i); @@ -12470,13 +12812,13 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) invlist_iterfinish(*invlist_ptr); /* Done with loop; remove any code points that are in the bitmap from - * *invlist_ptr; similarly for code points above latin1 if we have a - * flag to match all of them anyways */ + * *invlist_ptr; similarly for code points above the bitmap if we have + * a flag to match all of them anyways */ if (change_invlist) { - _invlist_subtract(*invlist_ptr, PL_Latin1, invlist_ptr); + _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); } - if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) { - _invlist_intersection(*invlist_ptr, PL_Latin1, invlist_ptr); + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { + _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); } /* If have completely emptied it, remove it completely */ @@ -12726,9 +13068,7 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, * upon an unescaped ']' that isn't one ending a regclass. To do both * these things, we need to realize that something preceded by a backslash * is escaped, so we have to keep track of backslashes */ - if (SIZE_ONLY) { - UV depth = 0; /* how many nested (?[...]) constructs */ - + if (PASS2) { Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__REGEX_SETS), "The regex_sets feature is experimental" REPORT_LOCATION, @@ -12736,6 +13076,9 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, UTF8fARG(UTF, RExC_end - RExC_start - (RExC_parse - RExC_precomp), RExC_precomp + (RExC_parse - RExC_precomp))); + } + else { + UV depth = 0; /* how many nested (?[...]) constructs */ while (RExC_parse < RExC_end) { SV* current = NULL; @@ -13194,9 +13537,10 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl * disk to find the possible matches. * * This should be called only for a Latin1-range code points, cp, which is - * known to be involved in a fold with other code points above Latin1. It - * would give false results if /aa has been specified. Multi-char folds - * are outside the scope of this, and must be handled specially. + * known to be involved in a simple fold with other code points above + * Latin1. It would give false results if /aa has been specified. + * Multi-char folds are outside the scope of this, and must be handled + * specially. * * XXX It would be better to generate these via regen, in case a new * version of the Unicode standard adds new mappings, though that is not @@ -13205,6 +13549,8 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS; + assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp)); + switch (cp) { case 'k': case 'K': @@ -13230,30 +13576,63 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl case LATIN_SMALL_LETTER_SHARP_S: *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S); break; - case 'F': case 'f': - case 'I': case 'i': - case 'L': case 'l': - case 'T': case 't': - case 'A': case 'a': - case 'H': case 'h': - case 'J': case 'j': - case 'N': case 'n': - case 'W': case 'w': - case 'Y': case 'y': - /* These all are targets of multi-character folds from code points - * that require UTF8 to express, so they can't match unless the - * target string is in UTF-8, so no action here is necessary, as - * regexec.c properly handles the general case for UTF-8 matching - * and multi-char folds */ - break; default: /* Use deprecated warning to increase the chances of this being * output */ - ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp); + if (PASS2) { + ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp); + } break; } } +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. */ @@ -13285,11 +13664,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * ignored in the recursion by means of a flag: * .) * - * ANYOF nodes contain a bit map for the first 256 characters, with the - * corresponding bit set if that character is in the list. For characters - * above 255, a range list or swash is used. There are extra bits for \w, - * etc. in locale ANYOFs, as what these match is not determinable at - * compile time + * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS + * characters, with the corresponding bit set if that character is in the + * list. For characters above this, a range list or swash is used. There + * are extra bits for \w, etc. in locale ANYOFs, as what these match is not + * determinable at compile time * * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs * to be restarted. This can only happen if ret_invlist is non-NULL. @@ -13436,7 +13815,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; @@ -13476,8 +13854,14 @@ parseit: { namedclass = regpposixcc(pRExC_state, value, strict); } - else if (value == '\\') { - if (UTF) { + else if (value != '\\') { +#ifdef EBCDIC + literal_endpoint++; +#endif + } + else { + /* Is a backslash; get the code point of the char after it */ + if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { value = utf8n_to_uvchr((U8*)RExC_parse, RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT); @@ -13510,19 +13894,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': @@ -13645,7 +14068,8 @@ parseit: * inappropriately, except that any \p{}, including * this one forces Unicode semantics, which means there * is no */ - ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8; + ANYOF_FLAGS(ret) + |= ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES; } else { @@ -13701,7 +14125,7 @@ parseit: case 't': value = '\t'; break; case 'f': value = '\f'; break; case 'b': value = '\b'; break; - case 'e': value = ASCII_TO_NATIVE('\033');break; + case 'e': value = ESC_NATIVE; break; case 'a': value = '\a'; break; case 'o': RExC_parse--; /* function expects to be pointed at the 'o' */ @@ -13710,8 +14134,8 @@ parseit: bool valid = grok_bslash_o(&RExC_parse, &value, &error_msg, - SIZE_ONLY, /* warnings in pass - 1 only */ + PASS2, /* warnings only in + pass 2 */ strict, silence_non_portable, UTF); @@ -13730,7 +14154,7 @@ parseit: bool valid = grok_bslash_x(&RExC_parse, &value, &error_msg, - TRUE, /* Output warnings */ + PASS2, /* Output warnings */ strict, silence_non_portable, UTF); @@ -13742,7 +14166,7 @@ parseit: goto recode_encoding; break; case 'c': - value = grok_bslash_c(*RExC_parse++, SIZE_ONLY); + value = grok_bslash_c(*RExC_parse++, PASS2); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': @@ -13782,7 +14206,7 @@ parseit: if (strict) { vFAIL("Invalid escape in the specified encoding"); } - else if (SIZE_ONLY) { + else if (PASS2) { ckWARNreg(RExC_parse, "Invalid escape in the specified encoding"); } @@ -13807,10 +14231,6 @@ parseit: break; } /* End of switch on char following backslash */ } /* end of handling backslash escape sequences */ -#ifdef EBCDIC - else - literal_endpoint++; -#endif /* Here, we have the current token in 'value' */ @@ -13868,18 +14288,18 @@ parseit: else { RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP; } - ANYOF_FLAGS(ret) |= ANYOF_POSIXL; + ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL; ANYOF_POSIXL_ZERO(ret); } /* Coverity thinks it is possible for this to be negative; both * jhi and khw think it's not, but be safer */ - assert(! (ANYOF_FLAGS(ret) & ANYOF_POSIXL) + assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL) || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0); /* See if it already matches the complement of this POSIX * class */ - if ((ANYOF_FLAGS(ret) & ANYOF_POSIXL) + if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL) && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2) ? -1 : 1))) @@ -13964,22 +14384,23 @@ parseit: namedclass % 2 != 0, posixes_ptr); } - continue; /* Go get next character */ } } /* end of namedclass \blah */ - /* Here, we have a single value. If 'range' is set, it is the ending - * of a range--check its validity. Later, we will handle each - * individual code point in the range. If 'range' isn't set, this - * could be the beginning of a range, so check for that by looking - * ahead to see if the next real character to be processed is the range - * indicator--the minus sign */ - if (skip_white) { RExC_parse = regpatws(pRExC_state, RExC_parse, FALSE /* means don't recognize comments */ ); } + /* If 'range' is set, 'value' is the ending of a range--check its + * validity. (If value isn't a single code point in the case of a + * range, we should have figured that out above in the code that + * catches false ranges). Later, we will handle each individual code + * point in the range. If 'range' isn't set, this could be the + * beginning of a range, so check for that by looking ahead to see if + * the next real character to be processed is the range indicator--the + * minus sign */ + if (range) { if (prevvalue > value) /* b-a */ { const int w = RExC_parse - rangebegin; @@ -14009,15 +14430,15 @@ parseit: /* a bad range like \w-, [:word:]- ? */ if (namedclass > OOB_NAMEDCLASS) { - if (strict || ckWARN(WARN_REGEXP)) { - const int w = - RExC_parse >= rangebegin ? - RExC_parse - rangebegin : 0; + if (strict || (PASS2 && ckWARN(WARN_REGEXP))) { + const int w = RExC_parse >= rangebegin + ? RExC_parse - rangebegin + : 0; if (strict) { vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin); } - else { + else if (PASS2) { vWARN4(RExC_parse, "False [] range \"%*.*s\"", w, w, rangebegin); @@ -14034,8 +14455,12 @@ parseit: } } - /* Here, is the beginning of the range, if any; or - * if not */ + if (namedclass > OOB_NAMEDCLASS) { + continue; + } + + /* Here, we have a single value, 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 */ @@ -14083,44 +14508,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 @@ -14151,19 +14549,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 } @@ -14234,6 +14633,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); @@ -14243,6 +14643,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; } @@ -14601,7 +15002,7 @@ parseit: if (DEPENDS_SEMANTICS) { /* Under /d, everything in the upper half of the Latin1 range * matches these complements */ - ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_NON_ASCII_ALL; + ANYOF_FLAGS(ret) |= ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII; } else if (AT_LEAST_ASCII_RESTRICTED) { /* Under /a and /aa, everything above ASCII matches these @@ -14907,7 +15308,7 @@ parseit: else { cp_list = depends_list; } - ANYOF_FLAGS(ret) |= ANYOF_UTF8; + ANYOF_FLAGS(ret) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES; } /* If there is a swash and more than one element, we can't use the swash in @@ -14917,6 +15318,10 @@ parseit: swash = NULL; } + /* Note that the optimization of using 'swash' if it is the only thing in + * the class doesn't have us change swash at all, so it can include things + * that are also in the bitmap; otherwise we have purposely deleted that + * duplicate information */ set_ANYOF_arg(pRExC_state, ret, cp_list, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) ? listsv : NULL, @@ -14945,7 +15350,7 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, { /* Sets the arg field of an ANYOF-type node 'node', using information about * the node passed-in. If there is nothing outside the node's bitmap, the - * arg is set to ANYOF_NONBITMAP_EMPTY. Otherwise, it sets the argument to + * arg is set to ANYOF_ONLY_HAS_BITMAP. Otherwise, it sets the argument to * the count returned by add_data(), having allocated and stored an array, * av, that that count references, as follows: * av[0] stores the character class description in its textual form. @@ -14971,15 +15376,17 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) { assert(! (ANYOF_FLAGS(node) - & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8))); - ARG_SET(node, ANYOF_NONBITMAP_EMPTY); + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES))); + ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); } else { AV * const av = newAV(); SV *rv; assert(ANYOF_FLAGS(node) - & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD)); + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD)); av_store(av, 0, (runtime_defns) ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef); @@ -15010,6 +15417,135 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, } } +#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) +SV * +Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, + const regnode* node, + bool doinit, + SV** listsvp, + SV** only_utf8_locale_ptr, + SV* exclude_list) + +{ + /* For internal core use only. + * Returns the swash for the input 'node' in the regex 'prog'. + * If is 'true', will attempt to create the swash if not already + * done. + * If is non-null, will return the printable contents of the + * swash. This can be used to get debugging information even before the + * swash exists, by calling this function with 'doinit' set to false, in + * which case the components that will be used to eventually create the + * swash are returned (in a printable form). + * If is not NULL, it is an inversion list of things to + * exclude from what's returned in . + * Tied intimately to how S_set_ANYOF_arg sets up the data structure. Note + * that, in spite of this function's name, the swash it returns may include + * the bitmap data as well */ + + SV *sw = NULL; + SV *si = NULL; /* Input swash initialization string */ + SV* invlist = NULL; + + RXi_GET_DECL(prog,progi); + const struct reg_data * const data = prog ? progi->data : NULL; + + PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA; + + assert(ANYOF_FLAGS(node) + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD)); + + if (data && data->count) { + const U32 n = ARG(node); + + if (data->what[n] == 's') { + SV * const rv = MUTABLE_SV(data->data[n]); + AV * const av = MUTABLE_AV(SvRV(rv)); + SV **const ary = AvARRAY(av); + U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; + + si = *ary; /* ary[0] = the string to initialize the swash with */ + + /* Elements 3 and 4 are either both present or both absent. [3] is + * any inversion list generated at compile time; [4] indicates if + * that inversion list has any user-defined properties in it. */ + if (av_tindex(av) >= 2) { + if (only_utf8_locale_ptr + && ary[2] + && ary[2] != &PL_sv_undef) + { + *only_utf8_locale_ptr = ary[2]; + } + else { + assert(only_utf8_locale_ptr); + *only_utf8_locale_ptr = NULL; + } + + if (av_tindex(av) >= 3) { + invlist = ary[3]; + if (SvUV(ary[4])) { + swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY; + } + } + else { + invlist = NULL; + } + } + + /* Element [1] is reserved for the set-up swash. If already there, + * return it; if not, create it and store it there */ + if (ary[1] && SvROK(ary[1])) { + sw = ary[1]; + } + else if (doinit && ((si && si != &PL_sv_undef) + || (invlist && invlist != &PL_sv_undef))) { + assert(si); + sw = _core_swash_init("utf8", /* the utf8 package */ + "", /* nameless */ + si, + 1, /* binary */ + 0, /* not from tr/// */ + invlist, + &swash_init_flags); + (void)av_store(av, 1, sw); + } + } + } + + /* If requested, return a printable version of what this swash matches */ + if (listsvp) { + SV* matches_string = newSVpvs(""); + + /* The swash should be used, if possible, to get the data, as it + * contains the resolved data. But this function can be called at + * compile-time, before everything gets resolved, in which case we + * return the currently best available information, which is the string + * that will eventually be used to do that resolving, 'si' */ + if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL) + && (si && si != &PL_sv_undef)) + { + sv_catsv(matches_string, si); + } + + /* Add the inversion list to whatever we have. This may have come from + * the swash, or from an input parameter */ + if (invlist) { + if (exclude_list) { + SV* clone = invlist_clone(invlist); + _invlist_subtract(clone, exclude_list, &clone); + sv_catsv(matches_string, _invlist_contents(clone)); + SvREFCNT_dec_NN(clone); + } + else { + sv_catsv(matches_string, _invlist_contents(invlist)); + } + } + *listsvp = matches_string; + } + + return sw; +} +#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */ /* reg_skipcomment() @@ -15089,21 +15625,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) @@ -15111,13 +15649,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", @@ -15127,7 +15665,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); } @@ -15137,54 +15694,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); } @@ -15314,11 +15853,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)] : "") ); @@ -15357,7 +15895,6 @@ STATIC U8 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth) { - dVAR; regnode *scan; U8 exact = PSEUDO; #ifdef EXPERIMENTAL_INPLACESCAN @@ -15404,11 +15941,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]); }); @@ -15417,12 +15953,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) ); @@ -15520,7 +16055,6 @@ void Perl_regdump(pTHX_ const regexp *r) { #ifdef DEBUGGING - dVAR; SV * const sv = sv_newmortal(); SV *dsv= sv_newmortal(); RXi_GET_DECL(r,ri); @@ -15575,13 +16109,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) @@ -15616,10 +16148,9 @@ 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 - dVAR; int k; /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */ @@ -15672,7 +16203,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 @@ -15722,9 +16253,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ ); if ( IS_ANYOF_TRIE(op) || trie->bitmap ) { sv_catpvs(sv, "["); - (void) put_latin1_charclass_innards(sv, IS_ANYOF_TRIE(op) - ? ANYOF_BITMAP(o) - : TRIE_BITMAP(trie)); + (void) put_charclass_bitmap_innards(sv, + (IS_ANYOF_TRIE(op)) + ? ANYOF_BITMAP(o) + : TRIE_BITMAP(trie), + NULL); sv_catpvs(sv, "]"); } @@ -15738,19 +16271,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, @@ -15788,6 +16338,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ else if (k == ANYOF) { const U8 flags = ANYOF_FLAGS(o); int do_sep = 0; + SV* bitmap_invlist; /* Will hold what the bit map contains */ if (flags & ANYOF_LOCALE_FLAGS) @@ -15798,8 +16349,10 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (flags & ANYOF_INVERT) sv_catpvs(sv, "^"); - /* output what the standard cp 0-255 bitmap matches */ - do_sep = put_latin1_charclass_innards(sv, ANYOF_BITMAP(o)); + /* output what the standard cp 0-NUM_ANYOF_CODE_POINTS-1 bitmap matches + * */ + do_sep = put_charclass_bitmap_innards(sv, ANYOF_BITMAP(o), + &bitmap_invlist); /* output any special charclass tests (used entirely under use * locale) * */ @@ -15813,9 +16366,9 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } - if ((flags & (ANYOF_ABOVE_LATIN1_ALL - |ANYOF_UTF8 - |ANYOF_NONBITMAP_NON_UTF8 + if ((flags & (ANYOF_MATCHES_ALL_ABOVE_BITMAP + |ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES |ANYOF_LOC_FOLD))) { if (do_sep) { @@ -15825,22 +16378,25 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpvs(sv, "^"); } - if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL) { + if (flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) { sv_catpvs(sv, "{non-utf8-latin1-all}"); } /* output information about the unicode matching */ - if (flags & ANYOF_ABOVE_LATIN1_ALL) - sv_catpvs(sv, "{unicode_all}"); - else if (ARG(o) != ANYOF_NONBITMAP_EMPTY) { + if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) + sv_catpvs(sv, "{above_bitmap_all}"); + else if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) { SV *lv; /* Set if there is something outside the bit map. */ bool byte_output = FALSE; /* If something in the bitmap has been output */ SV *only_utf8_locale; - /* Get the stuff that wasn't in the bitmap */ + /* Get the stuff that wasn't in the bitmap. 'bitmap_invlist' + * is used to guarantee that nothing in the bitmap gets + * returned */ (void) _get_regclass_nonbitmap_data(prog, o, FALSE, - &lv, &only_utf8_locale); + &lv, &only_utf8_locale, + bitmap_invlist); if (lv && lv != &PL_sv_undef) { char *s = savesvpv(lv); char * const origs = s; @@ -15851,7 +16407,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (*s == '\n') { const char * const t = ++s; - if (flags & ANYOF_NONBITMAP_NON_UTF8) { + if (flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) { sv_catpvs(sv, "{outside bitmap}"); } else { @@ -15903,7 +16459,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ invlist_iterinit(only_utf8_locale); while (invlist_iternext(only_utf8_locale, &start, &end)) { - put_range(sv, start, end); + put_range(sv, start, end, FALSE); max_entries --; if (max_entries < 0) { sv_catpvs(sv, "..."); @@ -15914,6 +16470,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } } + SvREFCNT_dec(bitmap_invlist); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); } @@ -15934,6 +16492,8 @@ 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); @@ -16506,138 +17066,295 @@ 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. */ +#define isBACKSLASHED_PUNCT(c) \ + ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^') STATIC void -S_put_byte(pTHX_ SV *sv, int c) +S_put_code_point(pTHX_ SV *sv, UV c) { - PERL_ARGS_ASSERT_PUT_BYTE; - - if (!isPRINT(c)) { - switch (c) { - case '\r': Perl_sv_catpvf(aTHX_ sv, "\\r"); break; - case '\n': Perl_sv_catpvf(aTHX_ sv, "\\n"); break; - case '\t': Perl_sv_catpvf(aTHX_ sv, "\\t"); break; - case '\f': Perl_sv_catpvf(aTHX_ sv, "\\f"); break; - case '\a': Perl_sv_catpvf(aTHX_ sv, "\\a"); break; + PERL_ARGS_ASSERT_PUT_CODE_POINT; - default: - Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c); - break; - } + if (c > 255) { + Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c); } - else { - const char string = c; - if (c == '-' || c == ']' || c == '\\' || c == '^') + else if (isPRINT(c)) { + const char string = (char) c; + if (isBACKSLASHED_PUNCT(c)) sv_catpvs(sv, "\\"); sv_catpvn(sv, &string, 1); } + else { + const char * const mnemonic = cntrl_to_mnemonic((char) c); + if (mnemonic) { + Perl_sv_catpvf(aTHX_ sv, "%s", mnemonic); + } + else { + Perl_sv_catpvf(aTHX_ sv, "\\x{%02X}", (U8) c); + } + } } +#define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C + STATIC void -S_put_range(pTHX_ SV *sv, UV start, UV end) +S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals) { - /* Appends to 'sv' a displayable version of the range of code points from - * 'start' to 'end' */ + * 'start' to 'end'. It assumes that only ASCII printables are displayable + * as-is (though some of these will be escaped by put_code_point()). */ + + const unsigned int min_range_count = 3; assert(start <= end); PERL_ARGS_ASSERT_PUT_RANGE; - if (end - start < 3) { /* Individual chars in short ranges */ - for (; start <= end; start++) - put_byte(sv, start); - } - else if ( end > 255 - || ! isALPHANUMERIC(start) - || ! isALPHANUMERIC(end) - || isDIGIT(start) != isDIGIT(end) - || isUPPER(start) != isUPPER(end) - || isLOWER(start) != isLOWER(end) - - /* This final test should get optimized out except on EBCDIC - * platforms, where it causes ranges that cross discontinuities - * like i/j to be shown as hex instead of the misleading, - * e.g. H-K (since that range includes more than H, I, J, K). + while (start <= end) { + UV this_end; + const char * format; + + if (end - start < min_range_count) { + + /* Individual chars in short ranges */ + for (; start <= end; start++) { + put_code_point(sv, start); + } + break; + } + + /* If permitted by the input options, and there is a possibility that + * this range contains a printable literal, look to see if there is + * one. */ + if (allow_literals && start <= MAX_PRINT_A) { + + /* If the range begin isn't an ASCII printable, effectively split + * the range into two parts: + * 1) the portion before the first such printable, + * 2) the rest + * and output them separately. */ + if (! isPRINT_A(start)) { + UV temp_end = start + 1; + + /* There is no point looking beyond the final possible + * printable, in MAX_PRINT_A */ + UV max = MIN(end, MAX_PRINT_A); + + while (temp_end <= max && ! isPRINT_A(temp_end)) { + temp_end++; + } + + /* Here, temp_end points to one beyond the first printable if + * found, or to one beyond 'max' if not. If none found, make + * sure that we use the entire range */ + if (temp_end > MAX_PRINT_A) { + temp_end = end + 1; + } + + /* Output the first part of the split range, the part that + * doesn't have printables, with no looking for literals + * (otherwise we would infinitely recurse) */ + put_range(sv, start, temp_end - 1, FALSE); + + /* The 2nd part of the range (if any) starts here. */ + start = temp_end; + + /* We continue instead of dropping down because even if the 2nd + * part is non-empty, it could be so short that we want to + * output it specially, as tested for at the top of this loop. * */ - || (end - start) != NATIVE_TO_ASCII(end) - NATIVE_TO_ASCII(start)) - { - Perl_sv_catpvf(aTHX_ sv, "\\x{%02" UVXf "}-\\x{%02" UVXf "}", - start, - (end < 256) ? end : 255); - } - else { /* Here, the ends of the range are both digits, or both uppercase, - or both lowercase; and there's no discontinuity in the range - (which could happen on EBCDIC platforms) */ - put_byte(sv, start); - sv_catpvs(sv, "-"); - put_byte(sv, end); + continue; + } + + /* Here, 'start' is a printable ASCII. If it is an alphanumeric, + * output a sub-range of just the digits or letters, then process + * the remaining portion as usual. */ + if (isALPHANUMERIC_A(start)) { + UV mask = (isDIGIT_A(start)) + ? _CC_DIGIT + : isUPPER_A(start) + ? _CC_UPPER + : _CC_LOWER; + UV temp_end = start + 1; + + /* Find the end of the sub-range that includes just the + * characters in the same class as the first character in it */ + while (temp_end <= end && _generic_isCC_A(temp_end, mask)) { + temp_end++; + } + temp_end--; + + /* For short ranges, don't duplicate the code above to output + * them; just call recursively */ + if (temp_end - start < min_range_count) { + put_range(sv, start, temp_end, FALSE); + } + else { /* Output as a range */ + put_code_point(sv, start); + sv_catpvs(sv, "-"); + put_code_point(sv, temp_end); + } + start = temp_end + 1; + continue; + } + + /* We output any other printables as individual characters */ + if (isPUNCT_A(start) || isSPACE_A(start)) { + while (start <= end && (isPUNCT_A(start) + || isSPACE_A(start))) + { + put_code_point(sv, start); + start++; + } + continue; + } + } /* End of looking for literals */ + + /* Here is not to output as a literal. Some control characters have + * mnemonic names. Split off any of those at the beginning and end of + * the range to print mnemonically. It isn't possible for many of + * these to be in a row, so this won't overwhelm with output */ + while (isMNEMONIC_CNTRL(start) && start <= end) { + put_code_point(sv, start); + start++; + } + if (start < end && isMNEMONIC_CNTRL(end)) { + + /* Here, the final character in the range has a mnemonic name. + * Work backwards from the end to find the final non-mnemonic */ + UV temp_end = end - 1; + while (isMNEMONIC_CNTRL(temp_end)) { + temp_end--; + } + + /* And separately output the range that doesn't have mnemonics */ + put_range(sv, start, temp_end, FALSE); + + /* Then output the mnemonic trailing controls */ + start = temp_end + 1; + while (start <= end) { + put_code_point(sv, start); + start++; + } + break; + } + + /* As a final resort, output the range or subrange as hex. */ + + this_end = (end < NUM_ANYOF_CODE_POINTS) + ? end + : NUM_ANYOF_CODE_POINTS - 1; + format = (this_end < 256) + ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}" + : "\\x{%04"UVXf"}-\\x{%04"UVXf"}"; + Perl_sv_catpvf(aTHX_ sv, format, start, this_end); + break; } } STATIC bool -S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap) +S_put_charclass_bitmap_innards(pTHX_ SV *sv, char *bitmap, SV** bitmap_invlist) { /* Appends to 'sv' a displayable version of the innards of the bracketed * character class whose bitmap is 'bitmap'; Returns 'TRUE' if it actually - * output anything */ + * output anything, and bitmap_invlist, if not NULL, will point to an + * inversion list of what is in the bit map */ int i; - bool has_output_anything = FALSE; + UV start, end; + unsigned int punct_count = 0; + SV* invlist = NULL; + SV** invlist_ptr; /* Temporary, in case bitmap_invlist is NULL */ + bool allow_literals = TRUE; + + PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS; + + invlist_ptr = (bitmap_invlist) ? bitmap_invlist : &invlist; + + /* Worst case is exactly every-other code point is in the list */ + *invlist_ptr = _new_invlist(NUM_ANYOF_CODE_POINTS / 2); + + /* Convert the bit map to an inversion list, keeping track of how many + * ASCII puncts are set, including an extra amount for the backslashed + * ones. */ + for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) { + if (BITMAP_TEST(bitmap, i)) { + *invlist_ptr = add_cp_to_invlist(*invlist_ptr, i); + if (isPUNCT_A(i)) { + punct_count++; + if isBACKSLASHED_PUNCT(i) { + punct_count++; + } + } + } + } + + /* Nothing to output */ + if (_invlist_len(*invlist_ptr) == 0) { + SvREFCNT_dec(invlist); + return FALSE; + } - PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS; + /* Generally, it is more readable if printable characters are output as + * literals, but if a range (nearly) spans all of them, it's best to output + * it as a single range. This code will use a single range if all but 2 + * printables are in it */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { - for (i = 0; i < 256; i++) { - if (i < 256 && BITMAP_TEST((U8 *) bitmap,i)) { + /* If range starts beyond final printable, it doesn't have any in it */ + if (start > MAX_PRINT_A) { + break; + } - /* The character at index i should be output. Find the next - * character that should NOT be output */ - int j; - for (j = i + 1; j <= 256; j++) { - if (! BITMAP_TEST((U8 *) bitmap, j)) { - break; - } + /* In both ASCII and EBCDIC, a SPACE is the lowest printable. To span + * all but two, the range must start and end no later than 2 from + * either end */ + if (start < ' ' + 2 && end > MAX_PRINT_A - 2) { + if (end > MAX_PRINT_A) { + end = MAX_PRINT_A; } - - /* Everything between them is a single range that should be output - * */ - put_range(sv, i, j - 1); - has_output_anything = TRUE; - i = j; + if (start < ' ') { + start = ' '; + } + if (end - start >= MAX_PRINT_A - ' ' - 2) { + allow_literals = FALSE; + } + break; } } + invlist_iterfinish(*invlist_ptr); + + /* The legibility of the output depends mostly on how many punctuation + * characters are output. There are 32 possible ASCII ones, and some have + * an additional backslash, bringing it to currently 36, so if any more + * than 18 are to be output, we can instead output it as its complement, + * yielding fewer puncts, and making it more legible. But give some weight + * to the fact that outputting it as a complement is less legible than a + * straight output, so don't complement unless we are somewhat over the 18 + * mark */ + if (allow_literals && punct_count > 22) { + sv_catpvs(sv, "^"); + + /* Add everything remaining to the list, so when we invert it just + * below, it will be excluded */ + _invlist_union_complement_2nd(*invlist_ptr, PL_InBitmap, invlist_ptr); + _invlist_invert(*invlist_ptr); + } + + /* Here we have figured things out. Output each range */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { + if (start >= NUM_ANYOF_CODE_POINTS) { + break; + } + put_range(sv, start, end, allow_literals); + } + invlist_iterfinish(*invlist_ptr); - return has_output_anything; + return TRUE; } #define CLEAR_OPTSTART \ @@ -16656,7 +17373,6 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, const regnode *last, const regnode *plast, SV* sv, I32 indent, U32 depth) { - dVAR; U8 op = PSEUDO; /* Arbitrary non-END op. */ const regnode *next; const regnode *optstart= NULL; @@ -16692,7 +17408,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)); @@ -16789,7 +17505,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } else if (PL_regkind[(U8)op] == ANYOF) { /* arglen 1 + class block */ - node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL) + node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL) ? ANYOF_POSIXL_SKIP : ANYOF_SKIP); node = NEXTOPER(node);