X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=30b118b9efeb9e2df51244b0931acc9900e8cc30;hb=658aef798ab992aed2b708fed0d12323ab3b1fcb;hp=3eb5c328b9b3184854d184a8e116a5cc9f844d33;hpb=9b2c10f1c598e1e6a0db9d0b301c9559b079b129;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 3eb5c32..30b118b 100644 --- a/sv.c +++ b/sv.c @@ -35,13 +35,13 @@ * lib/utf8.t lib/Unicode/Collate/t/index.t * --jhi */ -#define ASSERT_UTF8_CACHE(cache) \ +# define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ assert((cache)[2] <= (cache)[3]); \ assert((cache)[3] <= (cache)[1]);} \ } STMT_END #else -#define ASSERT_UTF8_CACHE(cache) NOOP +# define ASSERT_UTF8_CACHE(cache) NOOP #endif #ifdef PERL_OLD_COPY_ON_WRITE @@ -1717,8 +1717,29 @@ Perl_looks_like_number(pTHX_ SV *sv) return grok_number(sbegin, len, NULL); } +STATIC bool +S_glob_2number(pTHX_ GV * const gv) +{ + const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; + SV *const buffer = sv_newmortal(); + + /* FAKE globs can get coerced, so need to turn this off temporarily if it + is on. */ + SvFAKE_off(gv); + gv_efullname3(buffer, gv, "*"); + SvFLAGS(gv) |= wasfake; + + /* We know that all GVs stringify to something that is not-a-number, + so no need to test that. */ + if (ckWARN(WARN_NUMERIC)) + not_a_number(buffer); + /* We just want something true to return, so that S_sv_2iuv_common + can tail call us and return true. */ + return TRUE; +} + STATIC char * -S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) +S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) { const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; SV *const buffer = sv_newmortal(); @@ -1729,17 +1750,9 @@ S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - if (want_number) { - /* We know that all GVs stringify to something that is not-a-number, - so no need to test that. */ - if (ckWARN(WARN_NUMERIC)) - not_a_number(buffer); - /* We just want something true to return, so that S_sv_2iuv_common - can tail call us and return true. */ - return (char *) 1; - } else { - return SvPV(buffer, *len); - } + assert(SvPOK(buffer)); + *len = SvCUR(buffer); + return SvPVX(buffer); } /* Actually, ISO C leaves conversion of UV to IV undefined, but @@ -2050,7 +2063,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */ + NOOP; /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { @@ -2065,7 +2078,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */ + NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ } } SvIsUV_on(sv); @@ -2109,9 +2122,8 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } } else { - if (isGV_with_GP(sv)) { - return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); - } + if (isGV_with_GP(sv)) + return glob_2number((GV *)sv); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2461,7 +2473,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else { if (isGV_with_GP(sv)) { - glob_2inpuv((GV *)sv, NULL, TRUE); + glob_2number((GV *)sv); return 0.0; } @@ -2797,9 +2809,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (isGV_with_GP(sv)) { - return glob_2inpuv((GV *)sv, lp, FALSE); - } + if (isGV_with_GP(sv)) + return glob_2pv((GV *)sv, lp); if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -3283,7 +3294,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { it was a const and its value changed. */ if (CvCONST(cv) && CvCONST((CV*)sref) && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { - /*EMPTY*/ + NOOP; /* They are 2 constant subroutines generated from the same constant. This probably means that they are really the "same" proxy subroutine @@ -3305,8 +3316,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } } if (!intro) - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX_const(sref) : NULL); + cv_ckproto_len(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX_const(sref) : NULL, + SvPOK(sref) ? SvCUR(sref) : 0); } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); @@ -3881,21 +3893,27 @@ Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) } /* -=for apidoc sv_usepvn - -Tells an SV to use C to find its string value. Normally the string is -stored inside the SV but sv_usepvn allows the SV to use an outside string. -The C should point to memory that was allocated by C. The -string length, C, must be supplied. This function will realloc the -memory pointed to by C, so that pointer should not be freed or used by -the programmer after giving it to sv_usepvn. Does not handle 'set' magic. -See C. +=for apidoc sv_usepvn_flags + +Tells an SV to use C to find its string value. Normally the +string is stored inside the SV but sv_usepvn allows the SV to use an +outside string. The C should point to memory that was allocated +by C. The string length, C, must be supplied. By default +this function will realloc (i.e. move) the memory pointed to by C, +so that pointer should not be freed or used by the programmer after +giving it to sv_usepvn, and neither should any pointers from "behind" +that pointer (e.g. ptr + 1) be used. + +If C & SV_SMAGIC is true, will call SvSETMAGIC. If C & +SV_HAS_TRAILING_NUL is true, then C must be NUL, and the realloc +will be skipped. (i.e. the buffer is actually at least 1 byte longer than +C, and already meets the requirements for storing in C) =cut */ void -Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) { dVAR; STRLEN allocate; @@ -3903,34 +3921,43 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); return; } if (SvPVX_const(sv)) SvPV_free(sv); - allocate = PERL_STRLEN_ROUNDUP(len + 1); - ptr = saferealloc (ptr, allocate); + if (flags & SV_HAS_TRAILING_NUL) + assert(ptr[len] == '\0'); + + allocate = (flags & SV_HAS_TRAILING_NUL) + ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + if (flags & SV_HAS_TRAILING_NUL) { + /* It's long enough - do nothing. + Specfically Perl_newCONSTSUB is relying on this. */ + } else { +#ifdef DEBUGGING + /* Force a move to shake out bugs in callers. */ + char *new_ptr = safemalloc(allocate); + Copy(ptr, new_ptr, len, char); + PoisonFree(ptr,len,char); + Safefree(ptr); + ptr = new_ptr; +#else + ptr = saferealloc (ptr, allocate); +#endif + } SvPV_set(sv, ptr); SvCUR_set(sv, len); SvLEN_set(sv, allocate); - *SvEND(sv) = '\0'; + if (!(flags & SV_HAS_TRAILING_NUL)) { + *SvEND(sv) = '\0'; + } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); -} - -/* -=for apidoc sv_usepvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) -{ - sv_usepvn(sv,ptr,len); - SvSETMAGIC(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); } #ifdef PERL_OLD_COPY_ON_WRITE @@ -5339,13 +5366,11 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) /* Walk forwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, +S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, STRLEN uoffset) { const U8 *s = start; - PERL_UNUSED_CONTEXT; - while (s < send && uoffset--) s += UTF8SKIP(s); if (s > send) { @@ -5360,7 +5385,7 @@ S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, whether to walk forwards or backwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, +S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, STRLEN uoffset, STRLEN uend) { STRLEN backw = uend - uoffset; @@ -5368,7 +5393,7 @@ S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, /* The assumption is that going forwards is twice the speed of going forward (that's where the 2 * backw comes from). (The real figure of course depends on the UTF-8 data.) */ - return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset); + return sv_pos_u2b_forwards(start, send, uoffset); } while (backw--) { @@ -5419,12 +5444,12 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if ((*mgp)->mg_len != -1) { /* And we know the end too. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); } } @@ -5437,13 +5462,13 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, } boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[1], uoffset - uoffset0, cache[0] - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[3], uoffset - uoffset0, cache[2] - uoffset0); @@ -5455,7 +5480,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, /* In fact, offset0 is either 0, or less than offset, so don't need to worry about the other possibility. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); found = TRUE; @@ -5464,7 +5489,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if (!found || PL_utf8cache < 0) { const STRLEN real_boffset - = boffset0 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + = boffset0 + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); if (found && PL_utf8cache < 0) { @@ -5519,16 +5544,16 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - STRLEN boffset = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, + const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); *offsetp = (I32) boffset; if (lenp) { /* Convert the relative offset to absolute. */ - STRLEN uoffset2 = uoffset + (STRLEN) *lenp; - STRLEN boffset2 - = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, uoffset2, + const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN boffset2 + = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; @@ -6188,7 +6213,6 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) register I32 cnt; I32 i = 0; I32 rspara = 0; - I32 recsize; if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); @@ -6229,9 +6253,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) } else if (RsSNARF(PL_rs)) { /* If it is a regular disk file use size from stat() as estimate - of amount we are going to read - may result in malloc-ing - more memory than we realy need if layers bellow reduce - size we read (e.g. CRLF or a gzip layer) + of amount we are going to read -- may result in mallocing + more memory than we really need if the layers below reduce + the size we read (e.g. CRLF or a gzip layer). */ Stat_t st; if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { @@ -6246,9 +6270,10 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) else if (RsRECORD(PL_rs)) { I32 bytesread; char *buffer; + U32 recsize; /* Grab the size of the record we're getting */ - recsize = SvIV(SvRV(PL_rs)); + recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; /* Go yank in */ #ifdef VMS @@ -6501,7 +6526,7 @@ screamer2: * * - jik 9/25/96 */ - if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) goto screamer2; } @@ -6964,9 +6989,23 @@ Perl_newSVhek(pTHX_ const HEK *hek) return sv; } /* This will be overwhelminly the most common case. */ - return newSVpvn_share(HEK_KEY(hek), - (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), - HEK_HASH(hek)); + { + /* Inline most of newSVpvn_share(), because share_hek_hek() is far + more efficient than sharepvn(). */ + SV *sv; + + new_SV(sv); + sv_upgrade(sv, SVt_PV); + SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); + SvLEN_set(sv, 0); + SvREADONLY_on(sv); + SvFAKE_on(sv); + SvPOK_on(sv); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + return sv; + } } } @@ -6990,6 +7029,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) dVAR; register SV *sv; bool is_utf8 = FALSE; + const char *const orig_src = src; + if (len < 0) { STRLEN tmplen = -len; is_utf8 = TRUE; @@ -7009,6 +7050,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) SvPOK_on(sv); if (is_utf8) SvUTF8_on(sv); + if (src != orig_src) + Safefree(src); return sv; } @@ -7688,9 +7731,11 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) sv_clear(rv); SvFLAGS(rv) = 0; SvREFCNT(rv) = refcnt; - } - if (SvTYPE(rv) < SVt_RV) + sv_upgrade(rv, SVt_RV); + } else if (SvROK(rv)) { + SvREFCNT_dec(SvRV(rv)); + } else if (SvTYPE(rv) < SVt_RV) sv_upgrade(rv, SVt_RV); else if (SvTYPE(rv) > SVt_RV) { SvPV_free(rv); @@ -9388,6 +9433,9 @@ ptr_table_* functions. #endif +/* Certain cases in Perl_ss_dup have been merged, by relying on the fact + that currently av_dup and hv_dup are the same as sv_dup. If this changes, + please unmerge ss_dup. */ #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) #define av_dup(s,t) (AV*)sv_dup((SV*)s,t) @@ -9936,7 +9984,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { - /*EMPTY*/; /* Do sharing here, and fall through */ + NOOP; /* Do sharing here, and fall through */ } case SVt_PVIO: case SVt_PVFM: @@ -10047,7 +10095,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) if (IoDIRP(dstr)) { IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); } else { - /*EMPTY*/; + NOOP; /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ } } @@ -10369,23 +10417,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = i; switch (i) { case SAVEt_ITEM: /* normal string */ + case SAVEt_SV: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; - case SAVEt_SV: /* scalar reference */ - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv, param); - break; - case SAVEt_GENERIC_PVREF: /* generic char* */ - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup(c); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - break; case SAVEt_SHARED_PVREF: /* char* in shared space */ c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = savesharedpv(c); @@ -10399,15 +10436,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ break; - case SAVEt_AV: /* array reference */ - av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av, param); - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); - break; case SAVEt_HV: /* hash reference */ - hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); + case SAVEt_AV: /* array reference */ + sv = POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup(gv, param); break; @@ -10426,6 +10458,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_I32: /* I32 reference */ case SAVEt_I16: /* I16 reference */ case SAVEt_I8: /* I8 reference */ + case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); i = POPINT(ss,ix); @@ -10437,6 +10470,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) iv = POPIV(ss,ix); TOPIV(nss,ix) = iv; break; + case SAVEt_HPTR: /* HV* reference */ + case SAVEt_APTR: /* AV* reference */ case SAVEt_SPTR: /* SV* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); @@ -10449,24 +10484,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); break; + case SAVEt_GENERIC_PVREF: /* generic char* */ case SAVEt_PPTR: /* char* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); break; - case SAVEt_HPTR: /* HV* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup(hv, param); - break; - case SAVEt_APTR: /* AV* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av, param); - break; case SAVEt_NSTAB: gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup(gv, param); @@ -10579,7 +10603,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) i = POPINT(ss,ix); TOPINT(nss,ix) = i; ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = Perl_refcounted_he_dup(aTHX_ ptr, param); + if (ptr) { + HINTS_REFCNT_LOCK; + ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } + TOPPTR(nss,ix) = ptr; if (i & HINT_LOCALIZE_HH) { hv = (HV*)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); @@ -10611,8 +10640,70 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; + case SAVEt_RE_STATE: + { + const struct re_save_state *const old_state + = (struct re_save_state *) + (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); + struct re_save_state *const new_state + = (struct re_save_state *) + (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); + + Copy(old_state, new_state, 1, struct re_save_state); + ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; + + new_state->re_state_bostr + = pv_dup(old_state->re_state_bostr); + new_state->re_state_reginput + = pv_dup(old_state->re_state_reginput); + new_state->re_state_regeol + = pv_dup(old_state->re_state_regeol); + new_state->re_state_regstartp + = any_dup(old_state->re_state_regstartp, proto_perl); + new_state->re_state_regendp + = any_dup(old_state->re_state_regendp, proto_perl); + new_state->re_state_reglastparen + = any_dup(old_state->re_state_reglastparen, proto_perl); + new_state->re_state_reglastcloseparen + = any_dup(old_state->re_state_reglastcloseparen, + proto_perl); + /* XXX This just has to be broken. The old save_re_context + code did SAVEGENERICPV(PL_reg_start_tmp); + PL_reg_start_tmp is char **. + Look above to what the dup code does for + SAVEt_GENERIC_PVREF + It can never have worked. + So this is merely a faithful copy of the exiting bug: */ + new_state->re_state_reg_start_tmp + = (char **) pv_dup((char *) + old_state->re_state_reg_start_tmp); + /* I assume that it only ever "worked" because no-one called + (pseudo)fork while the regexp engine had re-entered itself. + */ +#ifdef PERL_OLD_COPY_ON_WRITE + new_state->re_state_nrs + = sv_dup(old_state->re_state_nrs, param); +#endif + new_state->re_state_reg_magic + = any_dup(old_state->re_state_reg_magic, proto_perl); + new_state->re_state_reg_oldcurpm + = any_dup(old_state->re_state_reg_oldcurpm, proto_perl); + new_state->re_state_reg_curpm + = any_dup(old_state->re_state_reg_curpm, proto_perl); + new_state->re_state_reg_oldsaved + = pv_dup(old_state->re_state_reg_oldsaved); + new_state->re_state_reg_poscache + = pv_dup(old_state->re_state_reg_poscache); + new_state->re_state_reg_starttry + = pv_dup(old_state->re_state_reg_starttry); + break; + } + case SAVEt_COMPILE_WARNINGS: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); + break; default: - Perl_croak(aTHX_ "panic: ss_dup inconsistency"); + Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i); } } @@ -10830,7 +10921,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); + SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); SvCUR_set(&PL_sv_no, 0); SvLEN_set(&PL_sv_no, 1); SvIV_set(&PL_sv_no, 0); @@ -10841,7 +10932,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); + SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); SvCUR_set(&PL_sv_yes, 1); SvLEN_set(&PL_sv_yes, 2); SvIV_set(&PL_sv_yes, 1); @@ -10864,12 +10955,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); - if (!specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); if (!specialCopIO(PL_compiling.cop_io)) PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param); - PL_compiling.cop_hints - = Perl_refcounted_he_dup(aTHX_ PL_compiling.cop_hints, param); + if (PL_compiling.cop_hints) { + HINTS_REFCNT_LOCK; + PL_compiling.cop_hints->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ @@ -11430,46 +11523,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_watchok = NULL; PL_regdummy = proto_perl->Tregdummy; - PL_regprecomp = NULL; - PL_regnpar = 0; - PL_regsize = 0; PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ - PL_reginput = NULL; - PL_regbol = NULL; - PL_regeol = NULL; - PL_regstartp = (I32*)NULL; - PL_regendp = (I32*)NULL; - PL_reglastparen = (U32*)NULL; - PL_reglastcloseparen = (U32*)NULL; - PL_regtill = NULL; - PL_reg_start_tmp = (char**)NULL; - PL_reg_start_tmpl = 0; - PL_regdata = (struct reg_data*)NULL; - PL_bostr = NULL; - PL_reg_flags = 0; - PL_reg_eval_set = 0; - PL_regnarrate = 0; - PL_regprogram = (regnode*)NULL; - PL_regindent = 0; - PL_reg_call_cc = (struct re_cc_state*)NULL; - PL_reg_re = (regexp*)NULL; - PL_reg_ganch = NULL; - PL_reg_sv = NULL; - PL_reg_match_utf8 = FALSE; - PL_reg_magic = (MAGIC*)NULL; - PL_reg_oldpos = 0; - PL_reg_oldcurpm = (PMOP*)NULL; - PL_reg_curpm = (PMOP*)NULL; - PL_reg_oldsaved = NULL; - PL_reg_oldsavedlen = 0; -#ifdef PERL_OLD_COPY_ON_WRITE - PL_nrs = NULL; -#endif - PL_reg_maxiter = 0; - PL_reg_leftiter = 0; - PL_reg_poscache = NULL; - PL_reg_poscache_size= 0; /* RE engine - function pointers */ PL_regcompp = proto_perl->Tregcompp; @@ -11477,9 +11532,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regint_start = proto_perl->Tregint_start; PL_regint_string = proto_perl->Tregint_string; PL_regfree = proto_perl->Tregfree; - + Zero(&PL_reg_state, 1, struct re_save_state); PL_reginterp_cnt = 0; - PL_reg_starttry = 0; + PL_regmatch_slab = NULL; /* Pluggable optimizer */ PL_peepp = proto_perl->Tpeepp; @@ -11837,7 +11892,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) subscript_type = FUV_SUBSCRIPT_HASH; } else { - index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + index = find_array_subscript((AV*)sv, uninit_sv); if (index >= 0) subscript_type = FUV_SUBSCRIPT_ARRAY; } @@ -12051,13 +12106,14 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) * or are optimized away, then it's unambiguous */ o2 = NULL; for (kid=o; kid; kid = kid->op_sibling) { - if (kid && - ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (kid->op_type == OP_PUSHMARK) + if (kid) { + const OPCODE type = kid->op_type; + if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (type == OP_PUSHMARK) ) - ) continue; + } if (o2) { /* more than one found */ o2 = NULL; break;