X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/19f6321d25d193c964d4da055e9f739f63de1dc6..0f722b558ffdeebb2a4a1827ea54471c04bdd41d:/sv.c diff --git a/sv.c b/sv.c index b278656..c509b03 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 @@ -678,6 +678,7 @@ Perl_sv_free_arenas(pTHX) void* Perl_get_arena(pTHX_ int arena_size) { + dVAR; struct arena_desc* adesc; struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas; int curr; @@ -692,7 +693,7 @@ Perl_get_arena(pTHX_ int arena_size) newroot->set_size = ARENAS_PER_SET; newroot->next = *aroot; *aroot = newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ @@ -1031,7 +1032,7 @@ static const struct body_details bodies_by_type[] = { #define new_NOARENAZ(details) \ my_safecalloc((details)->body_size + (details)->offset) -#ifdef DEBUGGING +#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; #endif @@ -1047,7 +1048,9 @@ S_more_bodies (pTHX_ svtype sv_type) assert(bdp->arena_size); -#ifdef DEBUGGING +#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) + /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global + * variables like done_sanity_check. */ if (!done_sanity_check) { unsigned int i = SVt_LAST; @@ -1065,8 +1068,9 @@ S_more_bodies (pTHX_ svtype sv_type) /* computed count doesnt reflect the 1st slot reservation */ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", - start, end, bdp->arena_size, sv_type, body_size, - bdp->arena_size / body_size)); + start, end, + (int)bdp->arena_size, sv_type, (int)body_size, + (int)bdp->arena_size / (int)body_size)); *root = (void *)start; @@ -1088,8 +1092,8 @@ S_more_bodies (pTHX_ svtype sv_type) STMT_START { \ void ** const r3wt = &PL_body_roots[sv_type]; \ LOCK_SV_MUTEX; \ - xpv = *((void **)(r3wt)) \ - ? *((void **)(r3wt)) : more_bodies(sv_type); \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : more_bodies(sv_type)); \ *(r3wt) = *(void**)(xpv); \ UNLOCK_SV_MUTEX; \ } STMT_END @@ -1118,12 +1122,12 @@ You generally want to use the C macro wrapper. See also C. */ void -Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) +Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) { dVAR; void* old_body; void* new_body; - const U32 old_type = SvTYPE(sv); + const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; const struct body_details *const old_type_details = bodies_by_type + old_type; @@ -1273,13 +1277,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) assert(SvPVX_const(sv) == 0); } - /* Could put this in the else clause below, as PVMG must have SvPVX - 0 already (the assertion above) */ - SvPV_set(sv, NULL); - if (old_type >= SVt_PVMG) { SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + sv->sv_u.svu_array = NULL; /* or svu_hash */ } break; @@ -1446,10 +1448,10 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) return s; } else #endif - s = saferealloc(s, newlen); + s = (char*)saferealloc(s, newlen); } else { - s = safemalloc(newlen); + s = (char*)safemalloc(newlen); if (SvPVX_const(sv) && SvCUR(sv)) { Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); } @@ -1494,6 +1496,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), OP_DESC(PL_op)); + default: NOOP; } (void)SvIOK_only(sv); /* validate number */ SvIV_set(sv, i); @@ -1594,6 +1597,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), OP_NAME(PL_op)); + default: NOOP; } SvNV_set(sv, num); (void)SvNOK_only(sv); /* validate number */ @@ -1751,7 +1755,9 @@ S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) SvFLAGS(gv) |= wasfake; assert(SvPOK(buffer)); - *len = SvCUR(buffer); + if (len) { + *len = SvCUR(buffer); + } return SvPVX(buffer); } @@ -1843,6 +1849,7 @@ STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { dVAR; + PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); @@ -2063,7 +2070,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 { @@ -2078,7 +2085,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); @@ -2123,7 +2130,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } else { if (isGV_with_GP(sv)) - return PTR2IV(glob_2number((GV *)sv)); + return glob_2number((GV *)sv); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2535,87 +2542,6 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts - * a regexp to its stringified form. - */ - -static char * -S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { - dVAR; - const regexp * const re = (regexp *)mg->mg_obj; - - if (!mg->mg_ptr) { - const char *fptr = "msix"; - char reflags[6]; - char ch; - int left = 0; - int right = 4; - bool need_newline = 0; - U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); - - while((ch = *fptr++)) { - if(reganch & 1) { - reflags[left++] = ch; - } - else { - reflags[right--] = ch; - } - reganch >>= 1; - } - if(left != 4) { - reflags[left] = '-'; - left = 5; - } - - mg->mg_len = re->prelen + 4 + left; - /* - * If /x was used, we have to worry about a regex ending with a - * comment later being embedded within another regex. If so, we don't - * want this regex's "commentization" to leak out to the right part of - * the enclosing regex, we must cap it with a newline. - * - * So, if /x was used, we scan backwards from the end of the regex. If - * we find a '#' before we find a newline, we need to add a newline - * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), - * we don't need to add anything. -jfriedl - */ - if (PMf_EXTENDED & re->reganch) { - const char *endptr = re->precomp + re->prelen; - while (endptr >= re->precomp) { - const char c = *(endptr--); - if (c == '\n') - break; /* don't need another */ - if (c == '#') { - /* we end while in a comment, so we need a newline */ - mg->mg_len++; /* save space for it */ - need_newline = 1; /* note to add it */ - break; - } - } - } - - Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); - mg->mg_ptr[0] = '('; - mg->mg_ptr[1] = '?'; - Copy(reflags, mg->mg_ptr+2, left, char); - *(mg->mg_ptr+left+2) = ':'; - Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); - if (need_newline) - mg->mg_ptr[mg->mg_len - 2] = '\n'; - mg->mg_ptr[mg->mg_len - 1] = ')'; - mg->mg_ptr[mg->mg_len] = 0; - } - PL_reginterp_cnt += re->program[0].next_off; - - if (re->reganch & ROPT_UTF8) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - if (lp) - *lp = mg->mg_len; - return mg->mg_ptr; -} - /* =for apidoc sv_2pv_flags @@ -2656,8 +2582,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) STRLEN len; if (SvIOKp(sv)) { - len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv)) - : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv)); + len = SvIsUV(sv) + ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) + : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); } else { Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); len = strlen(tbuf); @@ -2679,7 +2606,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = SvGROW_mutable(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); - return memcpy(s, tbuf, len + 1); + return (char*)memcpy(s, tbuf, len + 1); } } if (SvROK(sv)) { @@ -2719,35 +2646,93 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } { - SV *tsv; + STRLEN len; + char *retval; + char *buffer; MAGIC *mg; const SV *const referent = (SV*)SvRV(sv); if (!referent) { - tsv = sv_2mortal(newSVpvs("NULLREF")); + len = 7; + retval = buffer = savepvn("NULLREF", len); } else if (SvTYPE(referent) == SVt_PVMG && ((SvFLAGS(referent) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(referent, PERL_MAGIC_qr))) { - return stringify_regexp(sv, mg, lp); + && (mg = mg_find(referent, PERL_MAGIC_qr))) + { + char *str = NULL; + I32 haseval = 0; + U32 flags = 0; + (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); + if (flags & 1) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + PL_reginterp_cnt += haseval; + return str; } else { const char *const typestr = sv_reftype(referent, 0); + const STRLEN typelen = strlen(typestr); + UV addr = PTR2UV(referent); + const char *stashname = NULL; + STRLEN stashnamelen = 0; /* hush, gcc */ + const char *buffer_end; - tsv = sv_newmortal(); if (SvOBJECT(referent)) { - const char *const name = HvNAME_get(SvSTASH(referent)); - Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", - name ? name : "__ANON__" , typestr, - PTR2UV(referent)); + const HEK *const name = HvNAME_HEK(SvSTASH(referent)); + + if (name) { + stashname = HEK_KEY(name); + stashnamelen = HEK_LEN(name); + + if (HEK_UTF8(name)) { + SvUTF8_on(sv); + } else { + SvUTF8_off(sv); + } + } else { + stashname = "__ANON__"; + stashnamelen = 8; + } + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; } - else - Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, - PTR2UV(referent)); + + Newx(buffer, len, char); + buffer_end = retval = buffer + len; + + /* Working backwards */ + *--retval = '\0'; + *--retval = ')'; + do { + *--retval = PL_hexdigit[addr & 15]; + } while (addr >>= 4); + *--retval = 'x'; + *--retval = '0'; + *--retval = '('; + + retval -= typelen; + memcpy(retval, typestr, typelen); + + if (stashname) { + *--retval = '='; + retval -= stashnamelen; + memcpy(retval, stashname, stashnamelen); + } + /* retval may not neccesarily have reached the start of the + buffer here. */ + assert (retval >= buffer); + + len = buffer_end - retval - 1; /* -1 for that \0 */ } if (lp) - *lp = SvCUR(tsv); - return SvPVX(tsv); + *lp = len; + SAVEFREEPV(buffer); + return retval; } } if (SvREADONLY(sv) && !SvOK(sv)) { @@ -2791,7 +2776,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) - (void)strcpy(s,"0"); + my_strlcpy(s, "0", SvLEN(sv)); else #endif /*apollo*/ { @@ -2800,7 +2785,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) errno = olderrno; #ifdef FIXNEGATIVEZERO if (*s == '-' && s[1] == '0' && !s[2]) - strcpy(s,"0"); + my_strlcpy(s, "0", SvLEN(s)); #endif while (*s) s++; #ifdef hcx @@ -3091,13 +3076,13 @@ flag off so that it looks like octets again. void Perl_sv_utf8_encode(pTHX_ register SV *sv) { - (void) sv_utf8_upgrade(sv); if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) { Perl_croak(aTHX_ PL_no_modify); } + (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); } @@ -3294,7 +3279,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 @@ -3308,9 +3293,10 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { || sv_cmp(cv_const_sv(cv), cv_const_sv((CV*)sref))))) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - CvCONST(cv) - ? "Constant subroutine %s::%s redefined" - : "Subroutine %s::%s redefined", + (const char *) + (CvCONST(cv) + ? "Constant subroutine %s::%s redefined" + : "Subroutine %s::%s redefined"), HvNAME_get(GvSTASH((GV*)dstr)), GvENAME((GV*)dstr)); } @@ -3343,13 +3329,22 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) dVAR; register U32 sflags; register int dtype; - register int stype; + register svtype stype; if (sstr == dstr) return; + + if (SvIS_FREED(dstr)) { + Perl_croak(aTHX_ "panic: attempt to copy value %" SVf + " to a freed scalar %p", sstr, dstr); + } SV_CHECK_THINKFIRST_COW_DROP(dstr); if (!sstr) sstr = &PL_sv_undef; + if (SvIS_FREED(sstr)) { + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr, + dstr); + } stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -3467,7 +3462,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVBM: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); - if ((int)SvTYPE(sstr) != stype) { + if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); if (stype == SVt_PVGV && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); @@ -3478,7 +3473,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (stype == SVt_PVLV) SvUPGRADE(dstr, SVt_PVNV); else - SvUPGRADE(dstr, (U32)stype); + SvUPGRADE(dstr, (svtype)stype); } /* dstr may have been upgraded. */ @@ -3515,7 +3510,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } (void)SvOK_off(dstr); SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); - SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & SVf_ROK; assert(!(sflags & SVp_NOK)); assert(!(sflags & SVp_IOK)); assert(!(sflags & SVf_NOK)); @@ -3544,6 +3539,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) * possible small lose on short strings, but a big win on long ones. * It might even be a win on short strings if SvPVX_const(dstr) * has to be allocated and SvPVX_const(sstr) has to be freed. + * Likewise if we can set up COW rather than doing an actual copy, we + * drop to the else clause, as the swipe code and the COW setup code + * have much in common. */ /* Whichever path we take through the next code, we want this true, @@ -3551,10 +3549,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvPOK_only(dstr); if ( - /* We're not already COW */ - ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) + /* If we're already COW then this clause is not true, and if COW + is allowed then we drop down to the else and make dest COW + with us. If caller hasn't said that we're allowed to COW + shared hash keys then we don't do the COW setup, even if the + source scalar is a shared hash key scalar. */ + (((flags & SV_COW_SHARED_HASH_KEYS) + ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY) + : 1 /* If making a COW copy is forbidden then the behaviour we + desire is as if the source SV isn't actually already + COW, even if it is. So we act as if the source flags + are not COW, rather than actually testing them. */ + ) #ifndef PERL_OLD_COPY_ON_WRITE - /* or we are, but dstr isn't a suitable target. */ + /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic + when PERL_OLD_COPY_ON_WRITE is defined a little wrong. + Conceptually PERL_OLD_COPY_ON_WRITE being defined should + override SV_COW_SHARED_HASH_KEYS, because it means "always COW" + but in turn, it's somewhat dead code, never expected to go + live, but more kept as a placeholder on how to do it better + in a newer implementation. */ + /* If we are COW and dstr is a suitable target then we drop down + into the else and make dest a COW of us. */ || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS #endif ) @@ -3668,10 +3684,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); { - const MAGIC * const smg = SvVOK(sstr); + const MAGIC * const smg = SvVSTRING_mg(sstr); if (smg) { sv_magic(dstr, NULL, PERL_MAGIC_vstring, smg->mg_ptr, smg->mg_len); @@ -3681,8 +3696,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else if (sflags & (SVp_IOK|SVp_NOK)) { (void)SvOK_off(dstr); - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); if (sflags & SVp_IOK) { /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ SvIV_set(dstr, SvIVX(sstr)); @@ -3702,7 +3716,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_off(sstr); gv_efullname3(dstr, (GV *)sstr, "*"); SvFLAGS(sstr) |= wasfake; - SvFLAGS(dstr) |= sflags & SVf_AMAGIC; } else (void)SvOK_off(dstr); @@ -3928,8 +3941,10 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) if (SvPVX_const(sv)) SvPV_free(sv); +#ifdef DEBUGGING if (flags & SV_HAS_TRAILING_NUL) assert(ptr[len] == '\0'); +#endif allocate = (flags & SV_HAS_TRAILING_NUL) ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); @@ -3939,13 +3954,13 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) } else { #ifdef DEBUGGING /* Force a move to shake out bugs in callers. */ - char *new_ptr = safemalloc(allocate); + char *new_ptr = (char*)safemalloc(allocate); Copy(ptr, new_ptr, len, char); PoisonFree(ptr,len,char); Safefree(ptr); ptr = new_ptr; #else - ptr = saferealloc (ptr, allocate); + ptr = (char*) saferealloc (ptr, allocate); #endif } SvPV_set(sv, ptr); @@ -4471,6 +4486,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_regdata: vtable = &PL_vtbl_regdata; break; + case PERL_MAGIC_regdata_names: + vtable = &PL_vtbl_regdata_names; + break; case PERL_MAGIC_regdatum: vtable = &PL_vtbl_regdatum; break; @@ -4637,7 +4655,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) Weaken a reference: set the C flag on this RV; give the referred-to SV C magic if it hasn't already; and push a back-reference to this RV onto the array of backreferences -associated with that magic. +associated with that magic. If the RV is magical, set magic will be +called after the RV is cleared. =cut */ @@ -4790,6 +4809,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) SvRV_set(referrer, 0); SvOK_off(referrer); SvWEAKREF_off(referrer); + SvSETMAGIC(referrer); } else if (SvTYPE(referrer) == SVt_PVGV || SvTYPE(referrer) == SVt_PVLV) { /* You lookin' at me? */ @@ -5070,10 +5090,8 @@ Perl_sv_clear(pTHX_ register SV *sv) } } if (type >= SVt_PVMG) { - HV *ourstash; - if ((type == SVt_PVMG || type == SVt_PVGV) && - (ourstash = OURSTASH(sv))) { - SvREFCNT_dec(ourstash); + if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) { + SvREFCNT_dec(OURSTASH(sv)); } else if (SvMAGIC(sv)) mg_free(sv); if (type == SVt_PVMG && SvPAD_TYPED(sv)) @@ -5340,9 +5358,9 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf - " real %"UVf" for %"SVf, - (UV) ulen, (UV) real, sv); + Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) ulen, (UV) real, (void*)sv); } } } @@ -5366,13 +5384,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) { @@ -5387,7 +5403,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; @@ -5395,7 +5411,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--) { @@ -5446,12 +5462,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); } } @@ -5464,13 +5480,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); @@ -5482,7 +5498,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; @@ -5491,7 +5507,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) { @@ -5500,9 +5516,9 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf - " real %"UVf" for %"SVf, - (UV) boffset, (UV) real_boffset, sv); + Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) boffset, (UV) real_boffset, (void*)sv); } } boffset = real_boffset; @@ -5546,16 +5562,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; @@ -5616,26 +5632,15 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, if (PL_utf8cache < 0) { const U8 *start = (const U8 *) SvPVX_const(sv); - const U8 *const end = start + byte; - STRLEN realutf8 = 0; - - while (start < end) { - start += UTF8SKIP(start); - realutf8++; - } - - /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on - surrogates. FIXME - is it inconsistent that b2u warns, but u2b - doesn't? I don't know whether this difference was introduced with - the caching code in 5.8.1. */ + const STRLEN realutf8 = utf8_length(start, start + byte); if (realutf8 != utf8) { /* Need to turn the assertions off otherwise we may recurse infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf - " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, sv); + Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf + " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv); } } @@ -5738,29 +5743,6 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, ASSERT_UTF8_CACHE(cache); } -/* If we don't know the character offset of the end of a region, our only - option is to walk forwards to the target byte offset. */ -static STRLEN -S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target) -{ - STRLEN len = 0; - while (s < target) { - STRLEN n = 1; - - /* Call utf8n_to_uvchr() to validate the sequence - * (unless a simple non-UTF character) */ - if (!UTF8_IS_INVARIANT(*s)) - utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); - if (n > 0) { - s += n; - len++; - } - else - break; - } - return len; -} - /* We already know all of the way, now we may be able to walk back. The same assumption is made as in S_sv_pos_u2b_midway(), namely that walking backward is half the speed of walking forward. */ @@ -5772,7 +5754,7 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, STRLEN backw = end - target; if (forw < 2 * backw) { - return S_sv_pos_b2u_forwards(aTHX_ s, target); + return utf8_length(s, target); } while (end > target) { @@ -5845,8 +5827,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, s + blen, mg->mg_len - cache[0]); } else { - len = cache[0] - + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send); + len = cache[0] + utf8_length(s + cache[1], send); } } else if (cache[3] < byte) { @@ -5872,7 +5853,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) } } if (!found || PL_utf8cache < 0) { - const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send); + const STRLEN real_len = utf8_length(s, send); if (found && PL_utf8cache < 0) { if (len != real_len) { @@ -5880,9 +5861,9 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf - " real %"UVf" for %"SVf, - (UV) len, (UV) real_len, sv); + Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) len, (UV) real_len, (void*)sv); } } len = real_len; @@ -5918,8 +5899,16 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) pv1 = ""; cur1 = 0; } - else + else { + /* if pv1 and pv2 are the same, second SvPV_const call may + * invalidate pv1, so we may need to make a copy */ + if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { + pv1 = SvPV_const(sv1, cur1); + sv1 = sv_2mortal(newSVpvn(pv1, cur1)); + if (SvUTF8(sv2)) SvUTF8_on(sv1); + } pv1 = SvPV_const(sv1, cur1); + } if (!sv2){ pv2 = ""; @@ -6528,7 +6517,7 @@ screamer2: * * - jik 9/25/96 */ - if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) goto screamer2; } @@ -6915,7 +6904,7 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) register SV *sv; new_SV(sv); - sv_setpvn(sv,s,len ? len : strlen(s)); + sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); return sv; } @@ -6978,12 +6967,15 @@ Perl_newSVhek(pTHX_ const HEK *hek) SvUTF8_on (sv); Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ return sv; - } else if (flags & HVhek_REHASH) { + } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) { /* We don't have a pointer to the hv, so we have to replicate the flag into every HEK. This hv is using custom a hasing algorithm. Hence we can't return a shared string scalar, as that would contain the (wrong) hash value, and might get passed - into an hv routine with a regular hash */ + into an hv routine with a regular hash. + Similarly, a hash that isn't using shared hash keys has to have + the flag in every key so that we know not to try to call + share_hek_kek on it. */ SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); if (HEK_UTF8(hek)) @@ -7365,7 +7357,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv); break; } return io; @@ -7457,7 +7449,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - sv); + (void*)sv); } return GvCVu(gv); } @@ -7609,7 +7601,7 @@ Returns a string describing what the SV is a reference to. =cut */ -char * +const char * Perl_sv_reftype(pTHX_ const SV *sv, int ob) { /* The fact that I don't need to downcast to char * everywhere, only in ?: @@ -8586,7 +8578,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (*q) { case ' ': case '+': - plus = *q++; + if (plus == '+' && *q == ' ') /* '+' over ' ' */ + q++; + else + plus = *q++; continue; case '-': @@ -8723,14 +8718,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else i = (ewix ? ewix <= svmax : svix < svmax) ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; - precis = (i < 0) ? 0 : i; + precis = i; + has_precis = !(i < 0); } else { precis = 0; while (isDIGIT(*q)) precis = precis * 10 + (*q++ - '0'); + has_precis = TRUE; } - has_precis = TRUE; } /* SIZE */ @@ -8846,13 +8842,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else { eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) { + I32 old_precis = precis; if (has_precis && precis < elen) { I32 p = precis; sv_pos_u2b(argsv, &p, 0); /* sticks at end */ precis = p; } if (width) { /* fudge width (can't fudge elen) */ - width += elen - sv_len_utf8(argsv); + if (has_precis && precis < elen) + width += precis - old_precis; + else + width += elen - sv_len_utf8(argsv); } is_utf8 = TRUE; } @@ -8949,6 +8949,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV base = 10; goto uns_integer; + case 'B': case 'b': base = 2; goto uns_integer; @@ -9011,18 +9012,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV integer: { char *ptr = ebuf + sizeof ebuf; + bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ + zeros = 0; + switch (base) { unsigned dig; case 16: - if (!uv) - alt = FALSE; - p = (char*)((c == 'X') - ? "0123456789ABCDEF" : "0123456789abcdef"); + p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); do { dig = uv & 15; *--ptr = p[dig]; } while (uv >>= 4); - if (alt) { + if (tempalt) { esignbuf[esignlen++] = '0'; esignbuf[esignlen++] = c; /* 'x' or 'X' */ } @@ -9036,15 +9037,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--ptr = '0'; break; case 2: - if (!uv) - alt = FALSE; do { dig = uv & 1; *--ptr = '0' + dig; } while (uv >>= 1); - if (alt) { + if (tempalt) { esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = 'b'; + esignbuf[esignlen++] = c; } break; default: /* it had better be ten or less */ @@ -9059,8 +9058,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (has_precis) { if (precis > elen) zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') + else if (precis == 0 && elen == 1 && *eptr == '0' + && !(base == 8 && alt)) /* "%#.0o" prints "0" */ elen = 0; + + /* a precision nullifies the 0 flag. */ + if (fill == '0') + fill = ' '; } } break; @@ -9262,8 +9266,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * --jhi */ #if defined(HAS_LONG_DOUBLE) elen = ((intsize == 'q') - ? my_sprintf(PL_efloatbuf, ptr, nv) - : my_sprintf(PL_efloatbuf, ptr, (double)nv)); + ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) + : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); #else elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif @@ -9314,7 +9318,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpvs(msg, "end of string"); - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -9334,27 +9338,29 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV continue; /* not "break" */ } - /* calculate width before utf8_upgrade changes it */ + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) + sv_utf8_upgrade(sv); + } + else { + const STRLEN old_elen = elen; + SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + sv_utf8_upgrade(nsv); + eptr = SvPVX_const(nsv); + elen = SvCUR(nsv); + + if (width) { /* fudge width (can't fudge elen) */ + width += elen - old_elen; + } + is_utf8 = TRUE; + } + } + have = esignlen + zeros + elen; if (have < zeros) Perl_croak_nocontext(PL_memory_wrap); - if (is_utf8 != has_utf8) { - if (is_utf8) { - if (SvCUR(sv)) - sv_utf8_upgrade(sv); - } - else { - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); - sv_utf8_upgrade(nsv); - eptr = SvPVX_const(nsv); - elen = SvCUR(nsv); - } - SvGROW(sv, SvCUR(sv) + elen + 1); - p = SvEND(sv); - *p = '\0'; - } - need = (have > width ? have : width); gap = need - have; @@ -9436,8 +9442,8 @@ ptr_table_* functions. /* 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. */ + that currently av_dup, gv_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) @@ -9460,115 +9466,7 @@ ptr_table_* functions. REGEXP * Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) { - dVAR; - REGEXP *ret; - int i, len, npar; - struct reg_substr_datum *s; - - if (!r) - return (REGEXP *)NULL; - - if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) - return ret; - - len = r->offsets[0]; - npar = r->nparens+1; - - Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); - Copy(r->program, ret->program, len+1, regnode); - - Newx(ret->startp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - Newx(ret->endp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - - Newx(ret->substrs, 1, struct reg_substr_data); - for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { - s->min_offset = r->substrs->data[i].min_offset; - s->max_offset = r->substrs->data[i].max_offset; - s->substr = sv_dup_inc(r->substrs->data[i].substr, param); - s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param); - } - - ret->regstclass = NULL; - if (r->data) { - struct reg_data *d; - const int count = r->data->count; - int i; - - Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), - char, struct reg_data); - Newx(d->what, count, U8); - - d->count = count; - for (i = 0; i < count; i++) { - d->what[i] = r->data->what[i]; - switch (d->what[i]) { - /* legal options are one of: sfpont - see also regcomp.h and pregfree() */ - case 's': - d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); - break; - case 'p': - d->data[i] = av_dup_inc((AV *)r->data->data[i], param); - break; - case 'f': - /* This is cheating. */ - Newx(d->data[i], 1, struct regnode_charclass_class); - StructCopy(r->data->data[i], d->data[i], - struct regnode_charclass_class); - ret->regstclass = (regnode*)d->data[i]; - break; - case 'o': - /* Compiled op trees are readonly, and can thus be - shared without duplication. */ - OP_REFCNT_LOCK; - d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); - OP_REFCNT_UNLOCK; - break; - case 'n': - d->data[i] = r->data->data[i]; - break; - case 't': - d->data[i] = r->data->data[i]; - OP_REFCNT_LOCK; - ((reg_trie_data*)d->data[i])->refcount++; - OP_REFCNT_UNLOCK; - break; - default: - Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); - } - } - - ret->data = d; - } - else - ret->data = NULL; - - Newx(ret->offsets, 2*len+1, U32); - Copy(r->offsets, ret->offsets, 2*len+1, U32); - - ret->precomp = SAVEPVN(r->precomp, r->prelen); - ret->refcnt = r->refcnt; - ret->minlen = r->minlen; - ret->prelen = r->prelen; - ret->nparens = r->nparens; - ret->lastparen = r->lastparen; - ret->lastcloseparen = r->lastcloseparen; - ret->reganch = r->reganch; - - ret->sublen = r->sublen; - - if (RX_MATCH_COPIED(ret)) - ret->subbeg = SAVEPVN(r->subbeg, r->sublen); - else - ret->subbeg = NULL; -#ifdef PERL_OLD_COPY_ON_WRITE - ret->saved_copy = NULL; -#endif - - ptr_table_store(PL_ptr_table, r, ret); - return ret; + return CALLREGDUPE(r,param); } /* duplicate a file handle */ @@ -9635,7 +9533,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) ret->gp_cv = cv_dup_inc(gp->gp_cv, param); ret->gp_cvgen = gp->gp_cvgen; ret->gp_line = gp->gp_line; - ret->gp_file = gp->gp_file; /* points to COP.cop_file */ + ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); return ret; } @@ -9986,7 +9884,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: @@ -10031,9 +9929,8 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) missing by always going for the destination. FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { - HV *ourstash; - if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) { - OURSTASH_set(dstr, hv_dup_inc(ourstash, param)); + if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { + OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param)); } else if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) @@ -10097,7 +9994,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) */ } } @@ -10113,7 +10010,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) src_ary = AvARRAY((AV*)sstr); Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPV_set(dstr, (char*)dst_ary); + AvARRAY((AV*)dstr) = dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { while (items-- > 0) @@ -10129,60 +10026,54 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else { - SvPV_set(dstr, NULL); + AvARRAY((AV*)dstr) = NULL; AvALLOC((AV*)dstr) = (SV**)NULL; } break; case SVt_PVHV: - { - HEK *hvname = NULL; - - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(sstr); - XPVHV * const dxhv = (XPVHV*)SvANY(dstr); - XPVHV * const sxhv = (XPVHV*)SvANY(sstr); - char *darray; - Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), - char); - HvARRAY(dstr) = (HE**)darray; - while (i <= sxhv->xhv_max) { - const HE *source = HvARRAY(sstr)[i]; - HvARRAY(dstr)[i] = source - ? he_dup(source, sharekeys, param) : 0; - ++i; - } - if (SvOOK(sstr)) { - struct xpvhv_aux * const saux = HvAUX(sstr); - struct xpvhv_aux * const daux = HvAUX(dstr); - /* This flag isn't copied. */ - /* SvOOK_on(hv) attacks the IV flags. */ - SvFLAGS(dstr) |= SVf_OOK; - - hvname = saux->xhv_name; - daux->xhv_name - = hvname ? hek_dup(hvname, param) : hvname; - - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param) : 0; - daux->xhv_backreferences = saux->xhv_backreferences + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(sstr); + XPVHV * const dxhv = (XPVHV*)SvANY(dstr); + XPVHV * const sxhv = (XPVHV*)SvANY(sstr); + char *darray; + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dstr) = (HE**)darray; + while (i <= sxhv->xhv_max) { + const HE * const source = HvARRAY(sstr)[i]; + HvARRAY(dstr)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(sstr)) { + HEK *hvname; + const struct xpvhv_aux * const saux = HvAUX(sstr); + struct xpvhv_aux * const daux = HvAUX(dstr); + /* This flag isn't copied. */ + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(dstr) |= SVf_OOK; + + hvname = saux->xhv_name; + daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; + + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + (bool)!!HvSHAREKEYS(sstr), param) : 0; + daux->xhv_backreferences = + saux->xhv_backreferences ? (AV*) SvREFCNT_inc( - sv_dup((SV*)saux-> - xhv_backreferences, - param)) + sv_dup((SV*)saux->xhv_backreferences, param)) : 0; - } + /* Record stashes for possible cloning in Perl_clone(). */ + if (hvname) + av_push(param->stashes, dstr); } - else { - SvPV_set(dstr, NULL); - } - /* Record stashes for possible cloning in Perl_clone(). */ - if(hvname) - av_push(param->stashes, dstr); } + else + HvARRAY((HV*)dstr) = NULL; break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10268,6 +10159,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, + cx->blk_sub.oldcomppad); break; case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; @@ -10280,9 +10173,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_LOOP: ncx->blk_loop.label = cx->blk_loop.label; ncx->blk_loop.resetsp = cx->blk_loop.resetsp; - ncx->blk_loop.redo_op = cx->blk_loop.redo_op; - ncx->blk_loop.next_op = cx->blk_loop.next_op; - ncx->blk_loop.last_op = cx->blk_loop.last_op; + ncx->blk_loop.my_op = cx->blk_loop.my_op; ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata : gv_dup((GV*)cx->blk_loop.iterdata, param)); @@ -10408,6 +10299,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) long longval; GP *gp; IV iv; + I32 i; char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHX_ void*); @@ -10415,13 +10307,20 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newxz(nss, max, ANY); while (ix > 0) { - I32 i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - switch (i) { + const I32 type = POPINT(ss,ix); + TOPINT(nss,ix) = type; + switch (type) { + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ + case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; @@ -10440,10 +10339,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = POPPTR(ss,ix); + sv = (SV*) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); + /* fall through */ + case SAVEt_COMPPAD: + case SAVEt_NSTAB: + sv = (SV*) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_INT: /* int reference */ ptr = POPPTR(ss,ix); @@ -10454,6 +10356,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_LONG: /* long reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* fall through */ + case SAVEt_CLEARSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; break; @@ -10493,28 +10397,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); break; - case SAVEt_NSTAB: - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); - break; case SAVEt_GP: /* scalar reference */ gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv, param); - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup(c); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; break; - case SAVEt_FREESV: - case SAVEt_MORTALIZESV: - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { @@ -10543,15 +10432,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); break; - case SAVEt_CLEARSV: - longval = POPLONG(ss,ix); - TOPLONG(nss,ix) = longval; - break; case SAVEt_DELETE: hv = (HV*)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); + /* fall through */ + case SAVEt_STACK_POS: /* Position on Perl stack */ i = POPINT(ss,ix); TOPINT(nss,ix) = i; break; @@ -10577,10 +10464,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = i; ix -= i; break; - case SAVEt_STACK_POS: /* Position on Perl stack */ - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; case SAVEt_AELEM: /* array element */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); @@ -10589,14 +10472,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) av = (AV*)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; - case SAVEt_HELEM: /* hash element */ - 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); - hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - break; case SAVEt_OP: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = ptr; @@ -10616,10 +10491,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = hv_dup_inc(hv, param); } break; - case SAVEt_COMPPAD: - av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av, param); - break; case SAVEt_PADSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; @@ -10661,13 +10532,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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); + = (I32*) any_dup(old_state->re_state_regstartp, proto_perl); new_state->re_state_regendp - = any_dup(old_state->re_state_regendp, proto_perl); + = (I32*) any_dup(old_state->re_state_regendp, proto_perl); new_state->re_state_reglastparen - = any_dup(old_state->re_state_reglastparen, proto_perl); + = (U32*) any_dup(old_state->re_state_reglastparen, + proto_perl); new_state->re_state_reglastcloseparen - = any_dup(old_state->re_state_reglastcloseparen, + = (U32*)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); @@ -10687,11 +10559,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = 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); + = (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); + = (PMOP*) 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); + = (PMOP*) 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 @@ -10705,7 +10580,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); break; default: - Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i); + Perl_croak(aTHX_ + "panic: ss_dup inconsistency (%"IVdf")", (IV) type); } } @@ -10923,7 +10799,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); @@ -10934,7 +10810,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); @@ -10958,11 +10834,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); 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); - if (PL_compiling.cop_hints) { + if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; - PL_compiling.cop_hints->refcounted_he_refcnt++; + PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); @@ -11030,6 +10904,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + + /* RE engine related */ + Zero(&PL_reg_state, 1, struct re_save_state); + PL_reginterp_cnt = 0; + PL_regmatch_slab = NULL; + /* Clone the regex array */ PL_regex_padav = newAV(); { @@ -11086,6 +10966,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); + PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); + PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); PL_endav = av_dup_inc(proto_perl->Iendav, param); PL_checkav = av_dup_inc(proto_perl->Icheckav, param); PL_initav = av_dup_inc(proto_perl->Iinitav, param); @@ -11374,7 +11256,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap['M'] = 0; /* reinits on demand */ + PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */ PL_bitcount = NULL; /* reinits on demand */ if (proto_perl->Ipsig_pend) { @@ -11528,15 +11410,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ - /* RE engine - function pointers */ - PL_regcompp = proto_perl->Tregcompp; - PL_regexecp = proto_perl->Tregexecp; - 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_regmatch_slab = NULL; + /* Pluggable optimizer */ PL_peepp = proto_perl->Tpeepp; @@ -11743,16 +11617,17 @@ STATIC I32 S_find_array_subscript(pTHX_ AV *av, SV* val) { dVAR; - SV** svp; - I32 i; if (!av || SvMAGICAL(av) || !AvARRAY(av) || (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) return -1; - svp = AvARRAY(av); - for (i=AvFILLp(av); i>=0; i--) { - if (svp[i] == val && svp[i] != &PL_sv_undef) - return i; + if (val != &PL_sv_undef) { + SV ** const svp = AvARRAY(av); + I32 i; + + for (i=AvFILLp(av); i>=0; i--) + if (svp[i] == val) + return i; } return -1; }