X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/67bc2cb00d7feb8647dda25e729ba4ceb738fb6f..314d39ceeccf6c9ed18a761b1261137e0e8bdc75:/sv.c diff --git a/sv.c b/sv.c index 79b528b..065a292 100644 --- a/sv.c +++ b/sv.c @@ -1032,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 @@ -1048,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; @@ -1066,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; @@ -1119,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; @@ -1495,6 +1498,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); @@ -1595,6 +1599,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 */ @@ -1752,7 +1757,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); } @@ -2658,13 +2665,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvIOKp(sv)) { len = SvIsUV(sv) -#ifdef USE_SNPRINTF - ? snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) - : snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); -#else - ? my_sprintf(tbuf, "%"UVuf, (UV)SvUVX(sv)) - : my_sprintf(tbuf, "%"IVdf, (IV)SvIVX(sv)); -#endif /* #ifdef USE_SNPRINTF */ + ? 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); @@ -2798,7 +2800,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*/ { @@ -2807,7 +2809,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 @@ -3098,13 +3100,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); } @@ -3350,7 +3352,7 @@ 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; @@ -3485,7 +3487,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. */ @@ -3678,7 +3680,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 |SVf_AMAGIC); { - 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); @@ -3935,8 +3937,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); @@ -4644,7 +4648,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 */ @@ -4797,6 +4802,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? */ @@ -9017,18 +9023,19 @@ 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"); do { dig = uv & 15; *--ptr = p[dig]; } while (uv >>= 4); - if (alt) { + if (tempalt) { esignbuf[esignlen++] = '0'; esignbuf[esignlen++] = c; /* 'x' or 'X' */ } @@ -9042,13 +9049,11 @@ 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'; } @@ -9268,13 +9273,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') -# ifdef USE_SNPRINTF - ? snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) - : snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); -# else - ? my_sprintf(PL_efloatbuf, ptr, nv) - : my_sprintf(PL_efloatbuf, ptr, (double)nv)); -# endif /* #ifdef USE_SNPRINTF */ + ? 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 @@ -9345,27 +9345,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; @@ -9546,6 +9548,17 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) ((reg_trie_data*)d->data[i])->refcount++; OP_REFCNT_UNLOCK; break; + case 'T': + d->data[i] = r->data->data[i]; + OP_REFCNT_LOCK; + ((reg_ac_data*)d->data[i])->refcount++; + OP_REFCNT_UNLOCK; + /* Trie stclasses are readonly and can thus be shared + * without duplication. We free the stclass in pregfree + * when the corresponding reg_ac_data struct is freed. + */ + ret->regstclass= r->regstclass; + break; default: Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); } @@ -10144,55 +10157,49 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } 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 + SvPV_set(dstr, NULL); break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10278,6 +10285,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; @@ -10968,11 +10977,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); @@ -11753,16 +11760,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; }