X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/502c6561fcd473b7da3277363169d75f16ac2f8b..2867cdbcac19071f99ab71a81d63dbd894cebd3b:/regcomp.c diff --git a/regcomp.c b/regcomp.c index a751136..56d7e55 100644 --- a/regcomp.c +++ b/regcomp.c @@ -2,7 +2,9 @@ */ /* - * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee + * 'A fair jaw-cracker dwarf-language must be.' --Samwise Gamgee + * + * [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"] */ /* This file contains functions for compiling a regular expression. See @@ -130,7 +132,6 @@ typedef struct RExC_state_t { I32 orig_utf8; /* whether the pattern was originally in utf8 */ /* XXX use this for future optimisation of case * where pattern must be upgraded to utf8. */ - HV *charnames; /* cache of named sequences */ HV *paren_names; /* Paren names */ regnode **recurse; /* Recurse regops */ @@ -175,7 +176,6 @@ typedef struct RExC_state_t { #define RExC_seen_evals (pRExC_state->seen_evals) #define RExC_utf8 (pRExC_state->utf8) #define RExC_orig_utf8 (pRExC_state->orig_utf8) -#define RExC_charnames (pRExC_state->charnames) #define RExC_open_parens (pRExC_state->open_parens) #define RExC_close_parens (pRExC_state->close_parens) #define RExC_opend (pRExC_state->opend) @@ -473,23 +473,22 @@ static const scan_data_t zero_scan_data = (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END -#define vWARN(loc,m) STMT_START { \ +#define ckWARNreg(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \ - m, (int)offset, RExC_precomp, RExC_precomp + offset); \ + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END -#define vWARNdep(loc,m) STMT_START { \ +#define ckWARNregdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ - "%s" REPORT_LOCATION, \ - m, (int)offset, RExC_precomp, RExC_precomp + offset); \ + Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ + m REPORT_LOCATION, \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END - -#define vWARN2(loc, m, a1) STMT_START { \ +#define ckWARN2reg(loc, m, a1) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END @@ -499,12 +498,24 @@ static const scan_data_t zero_scan_data = a1, a2, (int)offset, RExC_precomp, RExC_precomp + 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, \ + a1, a2, (int)offset, RExC_precomp, RExC_precomp + 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, \ a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + 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, \ + a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + 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, \ @@ -1996,7 +2007,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( folder ) TRIE_BITMAP_SET(trie, folder[ *ch ]); DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, (char*)ch) + PerlIO_printf(Perl_debug_log, "%s", (char*)ch) ); } } @@ -2820,13 +2831,18 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } else { /* - Currently we assume that the trie can handle unicode and ascii - matches fold cased matches. If this proves true then the following - define will prevent tries in this situation. - - #define TRIE_TYPE_IS_SAFE (UTF || optype==EXACT) -*/ + Currently we do not believe that the trie logic can + handle case insensitive matching properly when the + pattern is not unicode (thus forcing unicode semantics). + + If/when this is fixed the following define can be swapped + in below to fully enable trie logic. + #define TRIE_TYPE_IS_SAFE 1 + +*/ +#define TRIE_TYPE_IS_SAFE (UTF || optype==EXACT) + if ( last && TRIE_TYPE_IS_SAFE ) { make_trie( pRExC_state, startbranch, first, cur, tail, count, @@ -3177,11 +3193,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, (next_is_eval || !(mincount == 0 && maxcount == 1)) && (minnext == 0) && (deltanext == 0) && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) - && maxcount <= REG_INFTY/3 /* Complement check for big count */ - && ckWARN(WARN_REGEXP)) + && maxcount <= REG_INFTY/3) /* Complement check for big count */ { - vWARN(RExC_parse, - "Quantifier unexpected on zero-length expression"); + ckWARNreg(RExC_parse, + "Quantifier unexpected on zero-length expression"); } min += minnext * mincount; @@ -3725,11 +3740,22 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->whilem_c = data_fake.whilem_c; } if (f & SCF_DO_STCLASS_AND) { - const int was = (data->start_class->flags & ANYOF_EOS); - - cl_and(data->start_class, &intrnl); - if (was) - data->start_class->flags |= ANYOF_EOS; + if (flags & SCF_DO_STCLASS_OR) { + /* OR before, AND after: ideally we would recurse with + * data_fake to get the AND applied by study of the + * remainder of the pattern, and then derecurse; + * *** HACK *** for now just treat as "no information". + * See [perl #56690]. + */ + cl_init(pRExC_state, data->start_class); + } else { + /* AND before and after: combine and continue */ + const int was = (data->start_class->flags & ANYOF_EOS); + + cl_and(data->start_class, &intrnl); + if (was) + data->start_class->flags |= ANYOF_EOS; + } } } #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY @@ -4157,7 +4183,7 @@ extern const struct regexp_engine my_reg_engine; #ifndef PERL_IN_XSUB_RE REGEXP * -Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags) +Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags) { dVAR; HV * const table = GvHV(PL_hintgv); @@ -4183,14 +4209,14 @@ Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags) #endif REGEXP * -Perl_re_compile(pTHX_ const SV * const pattern, U32 pm_flags) +Perl_re_compile(pTHX_ SV * const pattern, U32 pm_flags) { dVAR; REGEXP *rx; struct regexp *r; register regexp_internal *ri; STRLEN plen; - char* exp = SvPV((SV*)pattern, plen); + char *exp = SvPV(pattern, plen); char* xend = exp + plen; regnode *scan; I32 flags; @@ -4240,7 +4266,6 @@ redo_first_pass: RExC_size = 0L; RExC_emit = &PL_regdummy; RExC_whilem_seen = 0; - RExC_charnames = NULL; RExC_open_parens = NULL; RExC_close_parens = NULL; RExC_opend = NULL; @@ -4329,7 +4354,7 @@ redo_first_pass: + (sizeof(STD_PAT_MODS) - 1) + (sizeof("(?:)") - 1); - p = sv_grow((SV *)rx, wraplen + 1); + p = sv_grow(MUTABLE_SV(rx), wraplen + 1); SvCUR_set(rx, wraplen); SvPOK_on(rx); SvFLAGS(rx) |= SvUTF8(pattern); @@ -4922,7 +4947,7 @@ Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value, if (flags & RXapif_FETCH) { return reg_named_buff_fetch(rx, key, flags); } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); return NULL; } else if (flags & RXapif_EXISTS) { return reg_named_buff_exists(rx, key, flags) @@ -4990,7 +5015,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv, av_push(retarray, ret); } if (retarray) - return newRV_noinc((SV*)retarray); + return newRV_noinc(MUTABLE_SV(retarray)); } } return NULL; @@ -5129,7 +5154,7 @@ Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags) } } - return newRV_noinc((SV*)av); + return newRV_noinc(MUTABLE_SV(av)); } void @@ -5222,7 +5247,7 @@ Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, PERL_UNUSED_ARG(value); if (!PL_localizing) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } I32 @@ -5269,7 +5294,7 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv, goto getlen; } else { if (ckWARN(WARN_UNINITIALIZED)) - report_uninit((SV*)sv); + report_uninit((const SV *)sv); return 0; } } @@ -5637,10 +5662,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) "panic: reg_scan_name returned NULL"); if (!RExC_paren_names) { RExC_paren_names= newHV(); - sv_2mortal((SV*)RExC_paren_names); + sv_2mortal(MUTABLE_SV(RExC_paren_names)); #ifdef DEBUGGING RExC_paren_name_list= newAV(); - sv_2mortal((SV*)RExC_paren_name_list); + sv_2mortal(MUTABLE_SV(RExC_paren_name_list)); #endif } he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 ); @@ -6063,8 +6088,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) break; case KEEPCOPY_PAT_MOD: /* 'p' */ if (flagsp == &negflags) { - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) - vWARN(RExC_parse + 1,"Useless use of (?-p)"); + if (SIZE_ONLY) + ckWARNreg(RExC_parse + 1,"Useless use of (?-p)"); } else { *flagsp |= RXf_PMf_KEEPCOPY; } @@ -6136,6 +6161,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* Pick up the branches, linking them together. */ parse_start = RExC_parse; /* MJD */ br = regbranch(pRExC_state, &flags, 1,depth+1); + + if (freeze_paren) { + if (RExC_npar > after_freeze) + after_freeze = RExC_npar; + RExC_npar = freeze_paren; + } + /* branch_len = (paren != 0); */ if (br == NULL) @@ -6452,7 +6484,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) *flagp = WORST; if (max > 0) *flagp |= HASWIDTH; - if (max && max < min) + if (max < min) vFAIL("Can't do {n,m} with n > m"); if (!SIZE_ONLY) { ARG1_SET(ret, (U16)min); @@ -6512,11 +6544,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) goto do_curly; } nest_check: - if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) { - vWARN3(RExC_parse, - "%.*s matches null string many times", - (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0), - origparse); + if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) { + ckWARN3reg(RExC_parse, + "%.*s matches null string many times", + (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0), + origparse); } if (RExC_parse < RExC_end && *RExC_parse == '?') { @@ -6551,273 +6583,278 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) /* reg_namedseq(pRExC_state,UVp) This is expected to be called by a parser routine that has - recognized'\N' and needs to handle the rest. RExC_parse is + recognized '\N' and needs to handle the rest. RExC_parse is expected to point at the first char following the N at the time of the call. + + The \N may be inside (indicated by valuep not being NULL) 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 + 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. 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. + + 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. If valuep is non-null then it is assumed that we are parsing inside of a charclass definition and the first codepoint in the resolved string is returned via *valuep and the routine will return NULL. In this mode if a multichar string is returned from the charnames - handler a warning will be issued, and only the first char in the + handler, a warning will be issued, and only the first char in the sequence will be examined. If the string returned is zero length then the value of *valuep is undefined and NON-NULL will be returned to indicate failure. (This will NOT be a valid pointer to a regnode.) - If value is null then it is assumed that we are parsing normal text - and inserts a new EXACT node into the program containing the resolved - string and returns a pointer to the new node. If the string is - zerolength a NOTHING node is emitted. - + If valuep is null then it is assumed that we are parsing normal text and a + new EXACT node is inserted into the program containing the resolved string, + and a pointer to the new node is returned. But if the string is zero length + a NOTHING node is emitted instead. + On success RExC_parse is set to the char following the endbrace. - Parsing failures will generate a fatal errorvia vFAIL(...) - - NOTE: We cache all results from the charnames handler locally in - the RExC_charnames hash (created on first use) to prevent a charnames - handler from playing silly-buggers and returning a short string and - then a long string for a given pattern. Since the regexp program - size is calculated during an initial parse this would result - in a buffer overrun so we cache to prevent the charname result from - changing during the course of the parse. - + Parsing failures will generate a fatal error via vFAIL(...) */ STATIC regnode * -S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) +S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) { - char * name; /* start of the content of the name */ - char * endbrace; /* endbrace following the name */ - SV *sv_str = NULL; - SV *sv_name = NULL; - STRLEN len; /* this has various purposes throughout the code */ - bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */ + char * endbrace; /* '}' following the name */ regnode *ret = NULL; +#ifdef DEBUGGING + char* parse_start = RExC_parse - 2; /* points to the '\N' */ +#endif + char* p; + + GET_RE_DEBUG_FLAGS_DECL; PERL_ARGS_ASSERT_REG_NAMEDSEQ; + + GET_RE_DEBUG_FLAGS; + + /* The [^\n] meaning of \N ignores spaces and comments under the /x + * modifier. The other meaning does not */ + p = (RExC_flags & RXf_PMf_EXTENDED) + ? regwhite( pRExC_state, RExC_parse ) + : RExC_parse; + /* Disambiguate between \N meaning a named character versus \N meaning + * [^\n]. The former is assumed when it can't be the latter. */ + if (*p != '{' || regcurly(p)) { + RExC_parse = p; + if (valuep) { + /* no bare \N in a charclass */ + vFAIL("\\N in a character class must be a named character: \\N{...}"); + } + nextchar(pRExC_state); + ret = reg_node(pRExC_state, REG_ANY); + *flagp |= HASWIDTH|SIMPLE; + RExC_naughty++; + RExC_parse--; + Set_Node_Length(ret, 1); /* MJD */ + return ret; + } + + /* Here, we have decided it should be a named sequence */ + + /* The test above made sure that the next real character is a '{', but + * under the /x modifier, it could be separated by space (or a comment and + * \n) and this is not allowed (for consistency with \x{...} and the + * tokenizer handling of \N{NAME}). */ if (*RExC_parse != '{') { - vFAIL("Missing braces on \\N{}"); + vFAIL("Missing braces on \\N{}"); } - name = RExC_parse+1; - endbrace = strchr(RExC_parse, '}'); - if ( ! endbrace ) { - RExC_parse++; - vFAIL("Missing right brace on \\N{}"); - } - RExC_parse = endbrace + 1; - - - /* RExC_parse points at the beginning brace, - endbrace points at the last */ - if ( name[0]=='U' && name[1]=='+' ) { - /* its a "Unicode hex" notation {U+89AB} */ - I32 fl = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_DISALLOW_PREFIX - | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); - UV cp; - char string; - len = (STRLEN)(endbrace - name - 2); - cp = grok_hex(name + 2, &len, &fl, NULL); - if ( len != (STRLEN)(endbrace - name - 2) ) { - cp = 0xFFFD; - } - if (cp > 0xff) - RExC_utf8 = 1; - if ( valuep ) { - *valuep = cp; - return NULL; - } - string = (char)cp; - sv_str= newSVpvn(&string, 1); - } else { - /* fetch the charnames handler for this scope */ - HV * const table = GvHV(PL_hintgv); - SV **cvp= table ? - hv_fetchs(table, "charnames", FALSE) : - NULL; - SV *cv= cvp ? *cvp : NULL; - HE *he_str; - int count; - /* create an SV with the name as argument */ - sv_name = newSVpvn(name, endbrace - name); - - if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { - vFAIL2("Constant(\\N{%s}) unknown: " - "(possibly a missing \"use charnames ...\")", - SvPVX(sv_name)); - } - if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */ - vFAIL2("Constant(\\N{%s}): " - "$^H{charnames} is not defined",SvPVX(sv_name)); - } - - - - if (!RExC_charnames) { - /* make sure our cache is allocated */ - RExC_charnames = newHV(); - sv_2mortal((SV*)RExC_charnames); - } - /* see if we have looked this one up before */ - he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 ); - if ( he_str ) { - sv_str = HeVAL(he_str); - cached = 1; - } else { - dSP ; - ENTER ; - SAVETMPS ; - PUSHMARK(SP) ; - - XPUSHs(sv_name); - - PUTBACK ; - - count= call_sv(cv, G_SCALAR); - - if (count == 1) { /* XXXX is this right? dmq */ - sv_str = POPs; - SvREFCNT_inc_simple_void(sv_str); - } - - SPAGAIN ; - PUTBACK ; - FREETMPS ; - LEAVE ; - - if ( !sv_str || !SvOK(sv_str) ) { - vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} " - "did not return a defined value",SvPVX(sv_name)); - } - if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0)) - cached = 1; - } + RExC_parse++; /* Skip past the '{' */ + + if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */ + || ! (endbrace == RExC_parse /* nothing between the {} */ + || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */ + && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */ + { + if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */ + vFAIL("\\N{NAME} must be resolved by the lexer"); } - if (valuep) { - char *p = SvPV(sv_str, len); - if (len) { - STRLEN numlen = 1; - if ( SvUTF8(sv_str) ) { - *valuep = utf8_to_uvchr((U8*)p, &numlen); - if (*valuep > 0x7F) - RExC_utf8 = 1; - /* XXXX - We have to turn on utf8 for high bit chars otherwise - we get failures with - - "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i - "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i - - This is different from what \x{} would do with the same - codepoint, where the condition is > 0xFF. - - dmq - */ - - - } else { - *valuep = (UV)*p; - /* warn if we havent used the whole string? */ - } - if (numlen 0) { - const STRLEN unilen = reguni(pRExC_state, uvc, s); - s += unilen; - len += unilen; - /* In EBCDIC the numlen - * and unilen can differ. */ - foldbuf += numlen; - if (numlen >= foldlen) - break; - } - else - break; /* "Can't happen." */ - } - } else { - const STRLEN unilen = reguni(pRExC_state, uvc, s); - if (unilen > 0) { - s += unilen; - len += unilen; - } - } - } else { - len++; - REGC(*p, s++); - } - } - if (SIZE_ONLY) { - RExC_size += STR_SZ(len); - } else { - STR_LEN(ret) = len; - RExC_emit += STR_SZ(len); - } - Set_Node_Cur_Length(ret); /* MJD */ - RExC_parse--; - nextchar(pRExC_state); - } else { - ret = reg_node(pRExC_state,NOTHING); + + if (endbrace == RExC_parse) { /* empty: \N{} */ + if (! valuep) { + RExC_parse = endbrace + 1; + return reg_node(pRExC_state,NOTHING); + } + + if (SIZE_ONLY) { + ckWARNreg(RExC_parse, + "Ignoring zero length \\N{} in character class" + ); + RExC_parse = endbrace + 1; + } + *valuep = 0; + return (regnode *) &RExC_parse; /* Invalid regnode pointer */ } - if (!cached) { - SvREFCNT_dec(sv_str); + + RExC_utf8 = 1; /* named sequences imply Unicode semantics */ + RExC_parse += 2; /* Skip past the 'U+' */ + + if (valuep) { /* In a bracketed char 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. XXX Solution is to recharacterize as + [rest-of-class]|multi1|multi2... */ + + STRLEN length_of_hex; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES + | PERL_SCAN_DISALLOW_PREFIX + | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); + + char * endchar = strchr(RExC_parse, '.'); + if (endchar) { + ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class"); + } + else endchar = endbrace; + + length_of_hex = (STRLEN)(endchar - RExC_parse); + *valuep = grok_hex(RExC_parse, &length_of_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; + vFAIL("Invalid hexadecimal number in \\N{U+...}"); + } + + RExC_parse = endbrace + 1; + if (endchar == endbrace) return NULL; + + ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */ } - if (sv_name) { - SvREFCNT_dec(sv_name); + else { /* Not a char class */ + char *s; /* String to put in generated EXACT node */ + STRLEN len = 0; /* Its current length */ + char *endchar; /* Points to '.' or '}' ending cur char in the input + stream */ + + ret = reg_node(pRExC_state, + (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT)); + s= STRING(ret); + + /* Exact nodes can hold only a U8 length's of text = 255. Loop through + * the input which is of the form now 'c1.c2.c3...}' until find the + * ending brace or exeed length 255. The characters that exceed this + * limit are dropped. The limit could be relaxed should it become + * desirable by reparsing this as (?:\N{NAME}), so could generate + * multiple EXACT nodes, as is done for just regular input. But this + * is primarily a named character, and not intended to be a huge long + * string, so 255 bytes should be good enough */ + while (1) { + STRLEN length_of_hex; + I32 grok_flags = PERL_SCAN_ALLOW_UNDERSCORES + | PERL_SCAN_DISALLOW_PREFIX + | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); + UV cp; /* Ord of current character */ + + /* Code points are separated by dots. If none, there is only one + * code point, and is terminated by the brace */ + endchar = strchr(RExC_parse, '.'); + if (! endchar) endchar = endbrace; + + /* The values are Unicode even on EBCDIC machines */ + length_of_hex = (STRLEN)(endchar - RExC_parse); + cp = grok_hex(RExC_parse, &length_of_hex, &grok_flags, NULL); + 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+...}"); + } + + if (! FOLD) { /* Not folding, just append to the string */ + STRLEN unilen; + + /* Quit before adding this character if would exceed limit */ + if (len + UNISKIP(cp) > U8_MAX) break; + + unilen = reguni(pRExC_state, cp, s); + if (unilen > 0) { + s += unilen; + len += unilen; + } + } else { /* Folding, output the folded equivalent */ + STRLEN foldlen,numlen; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf; + cp = toFOLD_uni(cp, tmpbuf, &foldlen); + + /* Quit before exceeding size limit */ + if (len + foldlen > U8_MAX) break; + + for (foldbuf = tmpbuf; + foldlen; + foldlen -= numlen) + { + cp = utf8_to_uvchr(foldbuf, &numlen); + if (numlen > 0) { + const STRLEN unilen = reguni(pRExC_state, cp, s); + s += unilen; + len += unilen; + /* In EBCDIC the numlen and unilen can differ. */ + foldbuf += numlen; + if (numlen >= foldlen) + break; + } + else + break; /* "Can't happen." */ + } + } + + /* Point to the beginning of the next character in the sequence. */ + RExC_parse = endchar + 1; + + /* Quit if no more characters */ + if (RExC_parse >= endbrace) break; + } + + + if (SIZE_ONLY) { + if (RExC_parse < endbrace) { + ckWARNreg(RExC_parse - 1, + "Using just the first characters returned by \\N{}"); + } + + RExC_size += STR_SZ(len); + } else { + STR_LEN(ret) = len; + RExC_emit += STR_SZ(len); + } + + RExC_parse = endbrace + 1; + + *flagp |= HASWIDTH; /* Not SIMPLE, as that causes the engine to fail + with malformed in t/re/pat_advanced.t */ + RExC_parse --; + Set_Node_Cur_Length(ret); /* MJD */ + nextchar(pRExC_state); } - return ret; + return ret; } @@ -7147,12 +7184,12 @@ tryagain: } break; case 'N': - /* Handle \N{NAME} here and not below because it can be + /* Handle \N and \N{NAME} here and not below because it can be multicharacter. join_exact() will join them up later on. Also this makes sure that things like /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq*/ ++RExC_parse; - ret= reg_namedseq(pRExC_state, NULL); + ret= reg_namedseq(pRExC_state, NULL, flagp); break; case 'k': /* Handle \k and \k'NAME' */ parse_named_seq: @@ -7418,6 +7455,18 @@ tryagain: I32 flags = 0; STRLEN numlen = 3; ender = grok_oct(p, &numlen, &flags, NULL); + + /* An octal above 0xff is interpreted differently + * depending on if the re is in utf8 or not. If it + * is in utf8, the value will be itself, otherwise + * it is interpreted as modulo 0x100. It has been + * decided to discourage the use of octal above the + * single-byte range. For now, warn only when + * it ends up modulo */ + if (SIZE_ONLY && ender >= 0x100 + && ! UTF && ! PL_encoding) { + ckWARNregdep(p, "Use of octal value above 377 is deprecated"); + } p += numlen; } else { @@ -7431,8 +7480,8 @@ tryagain: { SV* enc = PL_encoding; ender = reg_recode((const char)(U8)ender, &enc); - if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) - vWARN(p, "Invalid escape in the specified encoding"); + if (!enc && SIZE_ONLY) + ckWARNreg(p, "Invalid escape in the specified encoding"); RExC_utf8 = 1; } break; @@ -7441,8 +7490,8 @@ tryagain: FAIL("Trailing \\"); /* FALL THROUGH */ default: - if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP)) - vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p)); + if (!SIZE_ONLY&& isALPHA(*p)) + ckWARN2reg(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p)); goto normal_default; } break; @@ -7734,10 +7783,9 @@ S_checkposixcc(pTHX_ RExC_state_t *pRExC_state) while (isALNUM(*s)) s++; if (*s && c == *s && s[1] == ']') { - if (ckWARN(WARN_REGEXP)) - vWARN3(s+2, - "POSIX syntax [%c %c] belongs inside character classes", - c, c); + ckWARN3reg(s+2, + "POSIX syntax [%c %c] belongs inside character classes", + c, c); /* [[=foo=]] and [[.foo.]] are still future. */ if (POSIXCC_NOTYET(c)) { @@ -7792,6 +7840,22 @@ case ANYOF_N##NAME: \ what = WORD; \ break +/* + We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test + so that it is possible to override the option here without having to + rebuild the entire core. as we are required to do if we change regcomp.h + which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined. +*/ +#if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS +#define BROKEN_UNICODE_CHARCLASS_MAPPINGS +#endif + +#ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS +#define POSIX_CC_UNI_NAME(CCNAME) CCNAME +#else +#define POSIX_CC_UNI_NAME(CCNAME) "Posix" CCNAME +#endif + /* parse a class specification and produce either an ANYOF node that matches the pattern or if the pattern matches a single char only and @@ -7923,7 +7987,7 @@ parseit: from earlier versions, OTOH that behaviour was broken as well. */ UV v; /* value is register so we cant & it /grrr */ - if (reg_namedseq(pRExC_state, &v)) { + if (reg_namedseq(pRExC_state, &v, NULL)) { goto parseit; } value= v; @@ -8017,16 +8081,16 @@ parseit: { SV* enc = PL_encoding; value = reg_recode((const char)(U8)value, &enc); - if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) - vWARN(RExC_parse, - "Invalid escape in the specified encoding"); + if (!enc && SIZE_ONLY) + ckWARNreg(RExC_parse, + "Invalid escape in the specified encoding"); break; } default: - if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP)) - vWARN2(RExC_parse, - "Unrecognized escape \\%c in character class passed through", - (int)value); + if (!SIZE_ONLY && isALPHA(value)) + ckWARN2reg(RExC_parse, + "Unrecognized escape \\%c in character class passed through", + (int)value); break; } } /* end of \blah */ @@ -8045,14 +8109,13 @@ parseit: /* a bad range like a-\d, a-[:digit:] ? */ if (range) { if (!SIZE_ONLY) { - if (ckWARN(WARN_REGEXP)) { - const int w = - RExC_parse >= rangebegin ? - RExC_parse - rangebegin : 0; - vWARN4(RExC_parse, + const int w = + RExC_parse >= rangebegin ? + RExC_parse - rangebegin : 0; + ckWARN4reg(RExC_parse, "False [] range \"%*.*s\"", w, w, rangebegin); - } + if (prevvalue < 256) { ANYOF_BITMAP_SET(ret, prevvalue); ANYOF_BITMAP_SET(ret, '-'); @@ -8080,18 +8143,24 @@ parseit: * A similar issue a little earlier when switching on value. * --jhi */ switch ((I32)namedclass) { + + case _C_C_T_(ALNUMC, isALNUMC(value), POSIX_CC_UNI_NAME("Alnum")); + case _C_C_T_(ALPHA, isALPHA(value), POSIX_CC_UNI_NAME("Alpha")); + case _C_C_T_(BLANK, isBLANK(value), POSIX_CC_UNI_NAME("Blank")); + case _C_C_T_(CNTRL, isCNTRL(value), POSIX_CC_UNI_NAME("Cntrl")); + case _C_C_T_(GRAPH, isGRAPH(value), POSIX_CC_UNI_NAME("Graph")); + case _C_C_T_(LOWER, isLOWER(value), POSIX_CC_UNI_NAME("Lower")); + case _C_C_T_(PRINT, isPRINT(value), POSIX_CC_UNI_NAME("Print")); + case _C_C_T_(PSXSPC, isPSXSPC(value), POSIX_CC_UNI_NAME("Space")); + case _C_C_T_(PUNCT, isPUNCT(value), POSIX_CC_UNI_NAME("Punct")); + case _C_C_T_(UPPER, isUPPER(value), POSIX_CC_UNI_NAME("Upper")); +#ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS case _C_C_T_(ALNUM, isALNUM(value), "Word"); - case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum"); - case _C_C_T_(ALPHA, isALPHA(value), "Alpha"); - case _C_C_T_(BLANK, isBLANK(value), "Blank"); - case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl"); - case _C_C_T_(GRAPH, isGRAPH(value), "Graph"); - case _C_C_T_(LOWER, isLOWER(value), "Lower"); - case _C_C_T_(PRINT, isPRINT(value), "Print"); - case _C_C_T_(PSXSPC, isPSXSPC(value), "Space"); - case _C_C_T_(PUNCT, isPUNCT(value), "Punct"); case _C_C_T_(SPACE, isSPACE(value), "SpacePerl"); - case _C_C_T_(UPPER, isUPPER(value), "Upper"); +#else + case _C_C_T_(SPACE, isSPACE(value), "PerlSpace"); + case _C_C_T_(ALNUM, isALNUM(value), "PerlWord"); +#endif case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit"); case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace"); case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace"); @@ -8138,7 +8207,7 @@ parseit: ANYOF_BITMAP_SET(ret, value); } yesno = '+'; - what = "Digit"; + what = POSIX_CC_UNI_NAME("Digit"); break; case ANYOF_NDIGIT: if (LOC) @@ -8151,7 +8220,7 @@ parseit: ANYOF_BITMAP_SET(ret, value); } yesno = '!'; - what = "Digit"; + what = POSIX_CC_UNI_NAME("Digit"); break; case ANYOF_MAX: /* this is to handle \p and \P */ @@ -8351,9 +8420,7 @@ parseit: *STRING(ret)= (char)value; STR_LEN(ret)= 1; RExC_emit += STR_SZ(1); - if (listsv) { - SvREFCNT_dec(listsv); - } + SvREFCNT_dec(listsv); return ret; } /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */ @@ -8390,8 +8457,8 @@ parseit: * used later (regexec.c:S_reginclass()). */ av_store(av, 0, listsv); av_store(av, 1, NULL); - av_store(av, 2, (SV*)unicode_alternate); - rv = newRV_noinc((SV*)av); + av_store(av, 2, MUTABLE_SV(unicode_alternate)); + rv = newRV_noinc(MUTABLE_SV(av)); n = add_data(pRExC_state, 1, "s"); RExC_rxi->data->data[n] = (void*)rv; ARG_SET(ret, n); @@ -8820,8 +8887,9 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, /* - regcurly - a little FSA that accepts {\d+,?\d*} */ -STATIC I32 -S_regcurly(register const char *s) +#ifndef PERL_IN_XSUB_RE +I32 +Perl_regcurly(register const char *s) { PERL_ARGS_ASSERT_REGCURLY; @@ -8839,7 +8907,7 @@ S_regcurly(register const char *s) return FALSE; return TRUE; } - +#endif /* - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form @@ -8962,6 +9030,17 @@ Perl_regdump(pTHX_ const regexp *r) /* - regprop - printable representation of opcode */ +#define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \ +STMT_START { \ + if (do_sep) { \ + Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \ + if (flags & ANYOF_INVERT) \ + /*make sure the invert info is in each */ \ + sv_catpvs(sv, "^"); \ + do_sep = 0; \ + } \ +} STMT_END + void Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) { @@ -8973,7 +9052,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) PERL_ARGS_ASSERT_REGPROP; - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */ /* It would be nice to FAIL() here, but this may be called from @@ -9061,7 +9140,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } else { AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]); - SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ]; + SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]); I32 *nums=(I32*)SvPVX(sv_dat); SV **name= av_fetch(list, nums[0], 0 ); I32 n; @@ -9079,7 +9158,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) else if (k == VERB) { if (!o->flags) Perl_sv_catpvf(aTHX_ sv, ":%"SVf, - SVfARG((SV*)progi->data->data[ ARG( o ) ])); + SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ])))); } else if (k == LOGICAL) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ else if (k == FOLDCHAR) @@ -9087,6 +9166,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) else if (k == ANYOF) { int i, rangestart = -1; const U8 flags = ANYOF_FLAGS(o); + int do_sep = 0; /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */ static const char * const anyofs[] = { @@ -9102,8 +9182,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) "[:^alpha:]", "[:ascii:]", "[:^ascii:]", - "[:ctrl:]", - "[:^ctrl:]", + "[:cntrl:]", + "[:^cntrl:]", "[:graph:]", "[:^graph:]", "[:lower:]", @@ -9129,6 +9209,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); if (flags & ANYOF_INVERT) sv_catpvs(sv, "^"); + + /* output what the standard cp 0-255 bitmap matches */ for (i = 0; i <= 256; i++) { if (i < 256 && ANYOF_BITMAP_TEST(o,i)) { if (rangestart == -1) @@ -9142,15 +9224,23 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) sv_catpvs(sv, "-"); put_byte(sv, i - 1); } + do_sep = 1; rangestart = -1; } } - + + EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags); + /* output any special charclass tests (used mostly under use locale) */ if (o->flags & ANYOF_CLASS) for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++) - if (ANYOF_CLASS_TEST(o,i)) + if (ANYOF_CLASS_TEST(o,i)) { sv_catpv(sv, anyofs[i]); - + do_sep = 1; + } + + EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags); + + /* output information about the unicode matching */ if (flags & ANYOF_UNICODE) sv_catpvs(sv, "{unicode}"); else if (flags & ANYOF_UNICODE_ALL) @@ -9163,7 +9253,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) if (lv) { if (sw) { U8 s[UTF8_MAXBYTES_CASE+1]; - + for (i = 0; i <= 256; i++) { /* just the first 256 */ uvchr_to_utf8(s, i); @@ -9294,26 +9384,19 @@ Perl_pregfree2(pTHX_ REGEXP *rx) ReREFCNT_dec(r->mother_re); } else { CALLREGFREE_PVT(rx); /* free the private data */ - if (RXp_PAREN_NAMES(r)) - SvREFCNT_dec(RXp_PAREN_NAMES(r)); + SvREFCNT_dec(RXp_PAREN_NAMES(r)); } if (r->substrs) { - if (r->anchored_substr) - SvREFCNT_dec(r->anchored_substr); - if (r->anchored_utf8) - SvREFCNT_dec(r->anchored_utf8); - if (r->float_substr) - SvREFCNT_dec(r->float_substr); - if (r->float_utf8) - SvREFCNT_dec(r->float_utf8); + SvREFCNT_dec(r->anchored_substr); + SvREFCNT_dec(r->anchored_utf8); + SvREFCNT_dec(r->float_substr); + SvREFCNT_dec(r->float_utf8); Safefree(r->substrs); } RX_MATCH_COPY_FREE(rx); #ifdef PERL_OLD_COPY_ON_WRITE - if (r->saved_copy) - SvREFCNT_dec(r->saved_copy); + SvREFCNT_dec(r->saved_copy); #endif - Safefree(r->swap); Safefree(r->offs); } @@ -9335,15 +9418,18 @@ Perl_pregfree2(pTHX_ REGEXP *rx) REGEXP * -Perl_reg_temp_copy (pTHX_ REGEXP *rx) +Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) { - REGEXP *ret_x = (REGEXP*) newSV_type(SVt_REGEXP); - struct regexp *ret = (struct regexp *)SvANY(ret_x); + struct regexp *ret; struct regexp *const r = (struct regexp *)SvANY(rx); register const I32 npar = r->nparens+1; PERL_ARGS_ASSERT_REG_TEMP_COPY; + if (!ret_x) + ret_x = (REGEXP*) newSV_type(SVt_REGEXP); + ret = (struct regexp *)SvANY(ret_x); + (void)ReREFCNT_inc(rx); /* We can take advantage of the existing "copied buffer" mechanism in SVs by pointing directly at the buffer, but flagging that the allocated @@ -9351,8 +9437,11 @@ Perl_reg_temp_copy (pTHX_ REGEXP *rx) a case of zero-ing that, rather than copying the current length. */ SvPV_set(ret_x, RX_WRAPPED(rx)); SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8); - StructCopy(&(r->xpv_cur), &(ret->xpv_cur), struct regexp_allocated); + memcpy(&(ret->xpv_cur), &(r->xpv_cur), + sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)); SvLEN_set(ret_x, 0); + SvSTASH_set(ret_x, NULL); + SvMAGIC_set(ret_x, NULL); Newx(ret->offs, npar, regexp_paren_pair); Copy(r->offs, ret->offs, npar, regexp_paren_pair); if (r->substrs) { @@ -9372,7 +9461,6 @@ Perl_reg_temp_copy (pTHX_ REGEXP *rx) ret->saved_copy = NULL; #endif ret->mother_re = rx; - ret->swap = NULL; return ret_x; } @@ -9427,7 +9515,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) case 's': case 'S': case 'u': - SvREFCNT_dec((SV*)ri->data->data[n]); + SvREFCNT_dec(MUTABLE_SV(ri->data->data[n])); break; case 'f': Safefree(ri->data->data[n]); @@ -9449,7 +9537,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) op_free((OP_4tree*)ri->data->data[n]); PAD_RESTORE_LOCAL(old_comppad); - SvREFCNT_dec((SV*)new_comppad); + SvREFCNT_dec(MUTABLE_SV(new_comppad)); new_comppad = NULL; break; case 'n': @@ -9596,7 +9684,20 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) ret->saved_copy = NULL; #endif - ret->mother_re = NULL; + if (ret->mother_re) { + if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) { + /* Our storage points directly to our mother regexp, but that's + 1: a buffer in a different thread + 2: something we no longer hold a reference on + so we need to copy it locally. */ + /* Note we need to sue SvCUR() on our mother_re, because it, in + turn, may well be pointing to its own mother_re. */ + SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re), + SvCUR(ret->mother_re)+1)); + SvLEN_set(dstr, SvCUR(ret->mother_re)+1); + } + ret->mother_re = NULL; + } ret->gofs = 0; } #endif /* PERL_IN_XSUB_RE */ @@ -9654,7 +9755,7 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) case 'S': case 'p': /* actually an AV, but the dup function is identical. */ case 'u': /* actually an HV, but the dup function is identical. */ - d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param); + d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param); break; case 'f': /* This is cheating. */ @@ -9949,7 +10050,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, #endif const regnode *nextbranch= NULL; I32 word_idx; - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);