X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regcomp.c;h=28c12d18aa55b0f9b4dfe3f29e9ade9f6dee7627;hb=ac27d13b824657b726428f3a6a1d5b3a01df569e;hp=775049db3d4f2624efea9ad043394e0883b6a84b;hpb=84679df57ca0626f7fb35fc3038e2e142b97f8a4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regcomp.c b/regcomp.c index 775049d..28c12d1 100644 --- a/regcomp.c +++ b/regcomp.c @@ -102,6 +102,7 @@ typedef struct RExC_state_t { U32 flags; /* are we folding, multilining? */ char *precomp; /* uncompiled string. */ + REGEXP *rx_sv; /* The SV that is the regexp. */ regexp *rx; /* perl core regexp structure */ regexp_internal *rxi; /* internal data for regexp object pprivate field */ char *start; /* Start of input for compile */ @@ -149,6 +150,7 @@ typedef struct RExC_state_t { #define RExC_flags (pRExC_state->flags) #define RExC_precomp (pRExC_state->precomp) +#define RExC_rx_sv (pRExC_state->rx_sv) #define RExC_rx (pRExC_state->rx) #define RExC_rxi (pRExC_state->rxi) #define RExC_start (pRExC_state->start) @@ -389,7 +391,7 @@ static const scan_data_t zero_scan_data = IV len = RExC_end - RExC_precomp; \ \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \ if (len > RegexLengthToShowInErrorMessages) { \ /* chop 10 shorter than the max, to ensure meaning of "..." */ \ len = RegexLengthToShowInErrorMessages - 10; \ @@ -420,7 +422,7 @@ static const scan_data_t zero_scan_data = */ #define vFAIL(m) STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \ Simple_vFAIL(m); \ } STMT_END @@ -438,7 +440,7 @@ static const scan_data_t zero_scan_data = */ #define vFAIL2(m,a1) STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \ Simple_vFAIL2(m, a1); \ } STMT_END @@ -457,7 +459,7 @@ static const scan_data_t zero_scan_data = */ #define vFAIL3(m,a1,a2) STMT_START { \ if (!SIZE_ONLY) \ - SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \ + SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \ Simple_vFAIL3(m, a1, a2); \ } STMT_END @@ -1230,10 +1232,9 @@ is the recommended Unicode-aware way of saying /* store the word for dumping */ \ SV* tmp; \ if (OP(noper) != NOTHING) \ - tmp = newSVpvn(STRING(noper), STR_LEN(noper)); \ + tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \ else \ - tmp = newSVpvn( "", 0 ); \ - if ( UTF ) SvUTF8_on( tmp ); \ + tmp = newSVpvn_utf8( "", 0, UTF ); \ av_push( trie_words, tmp ); \ }); \ \ @@ -3318,9 +3319,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, l -= old; /* Get the added string: */ - last_str = newSVpvn(s + old, l); - if (UTF) - SvUTF8_on(last_str); + last_str = newSVpvn_utf8(s + old, l, UTF); if (deltanext == 0 && pos_before == b) { /* What was added is a constant string */ if (mincount > 1) { @@ -4152,10 +4151,11 @@ Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags) #endif REGEXP * -Perl_re_compile(pTHX_ const SV * const pattern, const U32 pm_flags) +Perl_re_compile(pTHX_ const SV * const pattern, U32 pm_flags) { dVAR; - register REGEXP *r; + REGEXP *rx; + struct regexp *r; register regexp_internal *ri; STRLEN plen; char* exp = SvPV((SV*)pattern, plen); @@ -4175,7 +4175,7 @@ Perl_re_compile(pTHX_ const SV * const pattern, const U32 pm_flags) GET_RE_DEBUG_FLAGS_DECL; DEBUG_r(if (!PL_colorset) reginitcolors()); - RExC_utf8 = RExC_orig_utf8 = pm_flags & RXf_UTF8; + RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern); DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); @@ -4264,7 +4264,8 @@ redo_first_pass: /* Allocate space and zero-initialize. Note, the two step process of zeroing when in debug mode, thus anything assigned has to happen after that */ - Newxz(r, 1, regexp); + rx = (REGEXP*) newSV_type(SVt_REGEXP); + r = (struct regexp*)SvANY(rx); Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char, regexp_internal); if ( r == NULL || ri == NULL ) @@ -4280,7 +4281,6 @@ redo_first_pass: /* non-zero initialization begins here */ RXi_SET( r, ri ); r->engine= RE_ENGINE_PTR; - r->refcnt = 1; r->extflags = pm_flags; { bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY); @@ -4290,12 +4290,14 @@ redo_first_pass: >> RXf_PMf_STD_PMMOD_SHIFT); const char *fptr = STD_PAT_MODS; /*"msix"*/ char *p; - RXp_WRAPLEN(r) = plen + has_minus + has_p + has_runon + const STRLEN wraplen = plen + has_minus + has_p + has_runon + (sizeof(STD_PAT_MODS) - 1) + (sizeof("(?:)") - 1); - Newx(RXp_WRAPPED(r), RXp_WRAPLEN(r) + 1, char ); - p = RXp_WRAPPED(r); + p = sv_grow((SV *)rx, wraplen + 1); + SvCUR_set(rx, wraplen); + SvPOK_on(rx); + SvFLAGS(rx) |= SvUTF8(pattern); *p++='('; *p++='?'; if (has_p) *p++ = KEEPCOPY_PAT_MOD; /*'p'*/ @@ -4319,8 +4321,8 @@ redo_first_pass: *p++ = ':'; Copy(RExC_precomp, p, plen, char); - assert ((RXp_WRAPPED(r) - p) < 16); - r->pre_prefix = p - RXp_WRAPPED(r); + assert ((RX_WRAPPED(rx) - p) < 16); + r->pre_prefix = p - RX_WRAPPED(rx); p += plen; if (has_runon) *p++ = '\n'; @@ -4347,6 +4349,7 @@ redo_first_pass: (UV)((2*RExC_size+1) * sizeof(U32)))); #endif SetProgLen(ri,RExC_size); + RExC_rx_sv = rx; RExC_rx = r; RExC_rxi = ri; @@ -4364,7 +4367,7 @@ redo_first_pass: RExC_rx->seen_evals = RExC_seen_evals; REGC((U8)REG_MAGIC, (char*) RExC_emit++); if (reg(pRExC_state, 0, &flags,1) == NULL) { - ReREFCNT_dec(r); + ReREFCNT_dec(rx); return(NULL); } /* XXXX To minimize changes to RE engine we always allocate @@ -4408,7 +4411,7 @@ reStudy: /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ if (UTF) - r->extflags |= RXf_UTF8; /* Unicode in it? */ + SvUTF8_on(rx); /* Unicode in it? */ ri->regstclass = NULL; if (RExC_naughty >= 10) /* Probably an expensive pattern. */ r->intflags |= PREGf_NAUGHTY; @@ -4790,22 +4793,22 @@ reStudy: if (RExC_seen & REG_SEEN_CUTGROUP) r->intflags |= PREGf_CUTGROUP_SEEN; if (RExC_paren_names) - r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names); + RXp_PAREN_NAMES(r) = (HV*)SvREFCNT_inc(RExC_paren_names); else - r->paren_names = NULL; + RXp_PAREN_NAMES(r) = NULL; #ifdef STUPID_PATTERN_CHECKS - if (RX_PRELEN(r) == 0) + if (RX_PRELEN(rx) == 0) r->extflags |= RXf_NULL; - if (r->extflags & RXf_SPLIT && RX_PRELEN(r) == 1 && RXp_PRECOMP(r)[0] == ' ') + if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ') /* XXX: this should happen BEFORE we compile */ r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); - else if (RX_PRELEN(r) == 3 && memEQ("\\s+", RXp_PRECOMP(r), 3)) + else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3)) r->extflags |= RXf_WHITE; - else if (RX_PRELEN(r) == 1 && RXp_PRECOMP(r)[0] == '^') + else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^') r->extflags |= RXf_START_ONLY; #else - if (r->extflags & RXf_SPLIT && RXp_PRELEN(r) == 1 && RXp_PRECOMP(r)[0] == ' ') + if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ') /* XXX: this should happen BEFORE we compile */ r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); else { @@ -4856,7 +4859,7 @@ reStudy: PerlIO_printf(Perl_debug_log, "\n"); }); #endif - return(r); + return rx; } #undef RE_ENGINE_PTR @@ -4904,15 +4907,17 @@ Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, } SV* -Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags) +Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv, + const U32 flags) { AV *retarray = NULL; SV *ret; + struct regexp *const rx = (struct regexp *)SvANY(r); if (flags & RXapif_ALL) retarray=newAV(); - if (rx && rx->paren_names) { - HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 ); + if (rx && RXp_PAREN_NAMES(rx)) { + HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 ); if (he_str) { IV i; SV* sv_dat=HeVAL(he_str); @@ -4923,7 +4928,7 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 && rx->offs[nums[i]].end != -1) { ret = newSVpvs(""); - CALLREG_NUMBUF_FETCH(rx,nums[i],ret); + CALLREG_NUMBUF_FETCH(r,nums[i],ret); if (!retarray) return ret; } else { @@ -4942,14 +4947,15 @@ Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 } bool -Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, +Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key, const U32 flags) { - if (rx && rx->paren_names) { + struct regexp *const rx = (struct regexp *)SvANY(r); + if (rx && RXp_PAREN_NAMES(rx)) { if (flags & RXapif_ALL) { - return hv_exists_ent(rx->paren_names, key, 0); + return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0); } else { - SV *sv = CALLREG_NAMED_BUFF_FETCH(rx, key, flags); + SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags); if (sv) { SvREFCNT_dec(sv); return TRUE; @@ -4963,22 +4969,24 @@ Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key, } SV* -Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags) +Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags) { - if ( rx && rx->paren_names ) { - (void)hv_iterinit(rx->paren_names); + struct regexp *const rx = (struct regexp *)SvANY(r); + if ( rx && RXp_PAREN_NAMES(rx) ) { + (void)hv_iterinit(RXp_PAREN_NAMES(rx)); - return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXapif_FIRSTKEY); + return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY); } else { return FALSE; } } SV* -Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags) +Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags) { - if (rx && rx->paren_names) { - HV *hv = rx->paren_names; + struct regexp *const rx = (struct regexp *)SvANY(r); + if (rx && RXp_PAREN_NAMES(rx)) { + HV *hv = RXp_PAREN_NAMES(rx); HE *temphe; while ( (temphe = hv_iternext_flags(hv,0)) ) { IV i; @@ -4995,9 +5003,7 @@ Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags) } } if (parno || flags & RXapif_ALL) { - STRLEN len; - char *pv = HePV(temphe, len); - return newSVpvn(pv,len); + return newSVhek(HeKEY_hek(temphe)); } } } @@ -5005,17 +5011,18 @@ Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags) } SV* -Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags) +Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags) { SV *ret; AV *av; I32 length; + struct regexp *const rx = (struct regexp *)SvANY(r); - if (rx && rx->paren_names) { + if (rx && RXp_PAREN_NAMES(rx)) { if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) { - return newSViv(HvTOTALKEYS(rx->paren_names)); + return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx))); } else if (flags & RXapif_ONE) { - ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); + ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES)); av = (AV*)SvRV(ret); length = av_len(av); return newSViv(length + 1); @@ -5028,12 +5035,13 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags) } SV* -Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags) +Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags) { + struct regexp *const rx = (struct regexp *)SvANY(r); AV *av = newAV(); - if (rx && rx->paren_names) { - HV *hv= rx->paren_names; + if (rx && RXp_PAREN_NAMES(rx)) { + HV *hv= RXp_PAREN_NAMES(rx); HE *temphe; (void)hv_iterinit(hv); while ( (temphe = hv_iternext_flags(hv,0)) ) { @@ -5051,9 +5059,7 @@ Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags) } } if (parno || flags & RXapif_ALL) { - STRLEN len; - char *pv = HePV(temphe, len); - av_push(av, newSVpvn(pv,len)); + av_push(av, newSVhek(HeKEY_hek(temphe))); } } } @@ -5062,8 +5068,10 @@ Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags) } void -Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) +Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, + SV * const sv) { + struct regexp *const rx = (struct regexp *)SvANY(r); char *s = NULL; I32 i = 0; I32 s1, t1; @@ -5149,9 +5157,10 @@ Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, } I32 -Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv, +Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv, const I32 paren) { + struct regexp *const rx = (struct regexp *)SvANY(r); I32 i; I32 s1, t1; @@ -5210,7 +5219,10 @@ SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx) { PERL_UNUSED_ARG(rx); - return NULL; + if (0) + return NULL; + else + return newSVpvs("Regexp"); } /* Scans the name of a named buffer from the pattern. @@ -5242,10 +5254,9 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) { } if ( flags ) { - SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start, - (int)(RExC_parse - name_start))); - if (UTF) - SvUTF8_on(sv_name); + SV* sv_name + = newSVpvn_flags(name_start, (int)(RExC_parse - name_start), + SVs_TEMP | (UTF ? SVf_UTF8 : 0)); if ( flags == REG_RSN_RETURN_NAME) return sv_name; else if (flags==REG_RSN_RETURN_DATA) { @@ -6737,7 +6748,7 @@ STATIC UV S_reg_recode(pTHX_ const char value, SV **encp) { STRLEN numlen = 1; - SV * const sv = sv_2mortal(newSVpvn(&value, numlen)); + SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP); const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv); const STRLEN newlen = SvCUR(sv); UV uv = UNICODE_REPLACEMENT; @@ -8179,8 +8190,8 @@ parseit: if (!unicode_alternate) unicode_alternate = newAV(); - sv = newSVpvn((char*)foldbuf, foldlen); - SvUTF8_on(sv); + sv = newSVpvn_utf8((char*)foldbuf, foldlen, + TRUE); av_push(unicode_alternate, sv); } } @@ -8913,7 +8924,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ - if ( prog->paren_names ) { + if ( RXp_PAREN_NAMES(prog) ) { if ( k != REF || OP(o) < NREF) { AV *list= (AV *)progi->data->data[progi->name_list_idx]; SV **name= av_fetch(list, ARG(o), 0 ); @@ -9095,9 +9106,10 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } SV * -Perl_re_intuit_string(pTHX_ REGEXP * const prog) +Perl_re_intuit_string(pTHX_ REGEXP * const r) { /* Assume that RE_INTUIT is set */ dVAR; + struct regexp *const prog = (struct regexp *)SvANY(r); GET_RE_DEBUG_FLAGS_DECL; PERL_UNUSED_CONTEXT; @@ -9136,18 +9148,22 @@ Perl_re_intuit_string(pTHX_ REGEXP * const prog) void Perl_pregfree(pTHX_ REGEXP *r) { + SvREFCNT_dec(r); +} + +void +Perl_pregfree2(pTHX_ REGEXP *rx) +{ dVAR; + struct regexp *const r = (struct regexp *)SvANY(rx); GET_RE_DEBUG_FLAGS_DECL; - if (!r || (--r->refcnt > 0)) - return; if (r->mother_re) { ReREFCNT_dec(r->mother_re); } else { - CALLREGFREE_PVT(r); /* free the private data */ - if (r->paren_names) - SvREFCNT_dec(r->paren_names); - Safefree(RXp_WRAPPED(r)); + CALLREGFREE_PVT(rx); /* free the private data */ + if (RXp_PAREN_NAMES(r)) + SvREFCNT_dec(RXp_PAREN_NAMES(r)); } if (r->substrs) { if (r->anchored_substr) @@ -9160,14 +9176,13 @@ Perl_pregfree(pTHX_ REGEXP *r) SvREFCNT_dec(r->float_utf8); Safefree(r->substrs); } - RX_MATCH_COPY_FREE(r); + RX_MATCH_COPY_FREE(rx); #ifdef PERL_OLD_COPY_ON_WRITE if (r->saved_copy) SvREFCNT_dec(r->saved_copy); #endif Safefree(r->swap); Safefree(r->offs); - Safefree(r); } /* reg_temp_copy() @@ -9188,15 +9203,22 @@ Perl_pregfree(pTHX_ REGEXP *r) REGEXP * -Perl_reg_temp_copy (pTHX_ REGEXP *r) { - regexp *ret; +Perl_reg_temp_copy (pTHX_ REGEXP *rx) { + REGEXP *ret_x = (REGEXP*) newSV_type(SVt_REGEXP); + struct regexp *ret = (struct regexp *)SvANY(ret_x); + struct regexp *const r = (struct regexp *)SvANY(rx); register const I32 npar = r->nparens+1; - (void)ReREFCNT_inc(r); - Newx(ret, 1, regexp); - StructCopy(r, ret, regexp); + (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 + space in the copy is zero. As we've just done a struct copy, it's now + 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); + SvLEN_set(ret_x, 0); Newx(ret->offs, npar, regexp_paren_pair); Copy(r->offs, ret->offs, npar, regexp_paren_pair); - ret->refcnt = 1; if (r->substrs) { Newx(ret->substrs, 1, struct reg_substr_data); StructCopy(r->substrs, ret->substrs, struct reg_substr_data); @@ -9209,14 +9231,14 @@ Perl_reg_temp_copy (pTHX_ REGEXP *r) { /* check_substr and check_utf8, if non-NULL, point to either their anchored or float namesakes, and don't hold a second reference. */ } - RX_MATCH_COPIED_off(ret); + RX_MATCH_COPIED_off(ret_x); #ifdef PERL_OLD_COPY_ON_WRITE ret->saved_copy = NULL; #endif - ret->mother_re = r; + ret->mother_re = rx; ret->swap = NULL; - return ret; + return ret_x; } #endif @@ -9233,9 +9255,10 @@ Perl_reg_temp_copy (pTHX_ REGEXP *r) { */ void -Perl_regfree_internal(pTHX_ REGEXP * const r) +Perl_regfree_internal(pTHX_ REGEXP * const rx) { dVAR; + struct regexp *const r = (struct regexp *)SvANY(rx); RXi_GET_DECL(r,ri); GET_RE_DEBUG_FLAGS_DECL; @@ -9244,8 +9267,8 @@ Perl_regfree_internal(pTHX_ REGEXP * const r) reginitcolors(); { SV *dsv= sv_newmortal(); - RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8), - dsv, RXp_PRECOMP(r), RXp_PRELEN(r), 60); + RE_PV_QUOTED_DECL(s, RX_UTF8(rx), + dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60); PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", PL_colors[4],PL_colors[5],s); } @@ -9366,23 +9389,15 @@ Perl_regfree_internal(pTHX_ REGEXP * const r) */ #if defined(USE_ITHREADS) #ifndef PERL_IN_XSUB_RE -regexp * -Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) +void +Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) { dVAR; - regexp *ret; I32 npar; - - if (!r) - return (REGEXP *)NULL; - - if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) - return ret; - + const struct regexp *r = (const struct regexp *)SvANY(sstr); + struct regexp *ret = (struct regexp *)SvANY(dstr); npar = r->nparens+1; - Newx(ret, 1, regexp); - StructCopy(r, ret, regexp); Newx(ret->offs, npar, regexp_paren_pair); Copy(r->offs, ret->offs, npar, regexp_paren_pair); if(ret->swap) { @@ -9394,7 +9409,9 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) /* Do it this way to avoid reading from *r after the StructCopy(). That way, if any of the sv_dup_inc()s dislodge *r from the L1 cache, it doesn't matter. */ - const bool anchored = r->check_substr == r->anchored_substr; + const bool anchored = r->check_substr + ? r->check_substr == r->anchored_substr + : r->check_utf8 == r->anchored_utf8; Newx(ret->substrs, 1, struct reg_substr_data); StructCopy(r->substrs, ret->substrs, struct reg_substr_data); @@ -9417,16 +9434,21 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) ret->check_substr = ret->float_substr; ret->check_utf8 = ret->float_utf8; } + } else if (ret->check_utf8) { + if (anchored) { + ret->check_utf8 = ret->anchored_utf8; + } else { + ret->check_utf8 = ret->float_utf8; + } } } - RXp_WRAPPED(ret) = SAVEPVN(RXp_WRAPPED(ret), RXp_WRAPLEN(ret)+1); - ret->paren_names = hv_dup_inc(ret->paren_names, param); + RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param); if (ret->pprivate) - RXi_SET(ret,CALLREGDUPE_PVT(ret,param)); + RXi_SET(ret,CALLREGDUPE_PVT(dstr,param)); - if (RX_MATCH_COPIED(ret)) + if (RX_MATCH_COPIED(dstr)) ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); else ret->subbeg = NULL; @@ -9436,10 +9458,6 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) ret->mother_re = NULL; ret->gofs = 0; - ret->seen_evals = 0; - - ptr_table_store(PL_ptr_table, r, ret); - return ret; } #endif /* PERL_IN_XSUB_RE */ @@ -9458,9 +9476,10 @@ Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) */ void * -Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param) +Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) { dVAR; + struct regexp *const r = (struct regexp *)SvANY(rx); regexp_internal *reti; int len, npar; RXi_GET_DECL(r,ri); @@ -9550,48 +9569,8 @@ Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param) #endif /* USE_ITHREADS */ -/* - reg_stringify() - - converts a regexp embedded in a MAGIC struct to its stringified form, - caching the converted form in the struct and returns the cached - string. - - If lp is nonnull then it is used to return the length of the - resulting string - - If flags is nonnull and the returned string contains UTF8 then - (*flags & 1) will be true. - - If haseval is nonnull then it is used to return whether the pattern - contains evals. - - Normally called via macro: - - CALLREG_STRINGIFY(mg,&len,&utf8); - - And internally with - - CALLREG_AS_STR(mg,&lp,&flags,&haseval) - - See sv_2pv_flags() in sv.c for an example of internal usage. - - */ #ifndef PERL_IN_XSUB_RE -char * -Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) { - dVAR; - const REGEXP * const re = (REGEXP *)mg->mg_obj; - if (haseval) - *haseval = RX_SEEN_EVALS(re); - if (flags) - *flags = ((RX_EXTFLAGS(re) & RXf_UTF8) ? 1 : 0); - if (lp) - *lp = RX_WRAPLEN(re); - return RX_WRAPPED(re); -} - /* - regnext - dig the "next" pointer out of a node */