X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7b52d6569c115e4522e1cbe14cfd730e60c84bf1..ec610f8a9f2738d8a59ee84a3ec7ed858addea85:/sv.c diff --git a/sv.c b/sv.c index d936dfc..f2f86d0 100644 --- a/sv.c +++ b/sv.c @@ -1425,6 +1425,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) no route from NV to PVIV, NOK can never be true */ assert(!SvNOKp(sv)); assert(!SvNOK(sv)); + /* FALLTHROUGH */ case SVt_PVIO: case SVt_PVFM: case SVt_PVGV: @@ -1616,7 +1617,9 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) /* Don't round up on the first allocation, as odds are pretty good that * the initial request is accurate as to what is really needed */ if (SvLEN(sv)) { - newlen = PERL_STRLEN_ROUNDUP(newlen); + STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen); + if (rounded > newlen) + newlen = rounded; } #endif if (SvLEN(sv) && s) { @@ -1936,6 +1939,7 @@ Perl_looks_like_number(pTHX_ SV *const sv) { const char *sbegin; STRLEN len; + int numtype; PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; @@ -1944,7 +1948,8 @@ Perl_looks_like_number(pTHX_ SV *const sv) } else return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); - return grok_number(sbegin, len, NULL); + numtype = grok_number(sbegin, len, NULL); + return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype; } STATIC bool @@ -2105,6 +2110,10 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv /* If numtype is infnan, set the NV of the sv accordingly. * If numtype is anything else, try setting the NV using Atof(PV). */ +#ifdef USING_MSVC6 +# pragma warning(push) +# pragma warning(disable:4756;disable:4056) +#endif static void S_sv_setnv(pTHX_ SV* sv, int numtype) { @@ -2129,6 +2138,9 @@ S_sv_setnv(pTHX_ SV* sv, int numtype) SvPOK_on(sv); /* PV is okay, though. */ } } +#ifdef USING_MSVC6 +# pragma warning(pop) +#endif STATIC bool S_sv_2iuv_common(pTHX_ SV *const sv) @@ -2249,7 +2261,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) sv_upgrade(sv, SVt_PVNV); if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) { - if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_NAN))) + if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING))) not_a_number(sv); S_sv_setnv(aTHX_ sv, numtype); return FALSE; @@ -3148,7 +3160,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) #else { bool local_radix; - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_TO_NEEDED(); local_radix = PL_numeric_local && @@ -3250,14 +3263,6 @@ include SV_GMAGIC. */ void -Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) -{ - PERL_ARGS_ASSERT_SV_COPYPV; - - sv_copypv_flags(dsv, ssv, 0); -} - -void Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) { STRLEN len; @@ -5945,14 +5950,13 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) /* =for apidoc sv_get_backrefs -If the sv is the target of a weakrefence then return -the backrefs structure associated with the sv, otherwise -return NULL. +If the sv is the target of a weak reference then it returns the back +references structure associated with the sv; otherwise return NULL. -When returning a non-null result the type of the return -is relevant. If it is an AV then the contents of the AV -are the weakrefs which point at this item. If it is any -other type then the item itself is the weakref. +When returning a non-null result the type of the return is relevant. If it +is an AV then the elements of the AV are the weak reference RVs which +point at this item. If it is any other type then the item itself is the +weak reference. See also Perl_sv_add_backref(), Perl_sv_del_backref(), Perl_sv_kill_backrefs() @@ -5961,7 +5965,7 @@ Perl_sv_kill_backrefs() */ SV * -Perl_sv_get_backrefs(pTHX_ SV *const sv) +Perl_sv_get_backrefs(SV *const sv) { SV *backrefs= NULL; @@ -6302,8 +6306,6 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l PERL_ARGS_ASSERT_SV_INSERT_FLAGS; - if (!bigstr) - Perl_croak(aTHX_ "Can't modify nonexistent substring"); SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { @@ -6517,7 +6519,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) SV* iter_sv = NULL; SV* next_sv = NULL; SV *sv = orig_sv; - STRLEN hash_index; + STRLEN hash_index = 0; /* initialise to make Coverity et al happy. + Not strictly necessary */ PERL_ARGS_ASSERT_SV_CLEAR; @@ -6608,17 +6611,19 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_last_swash_hv = NULL; } if (HvTOTALKEYS((HV*)sv) > 0) { - const char *name; + const HEK *hek; /* this statement should match the one at the beginning of * hv_undef_flags() */ if ( PL_phase != PERL_PHASE_DESTRUCT - && (name = HvNAME((HV*)sv))) + && (hek = HvNAME_HEK((HV*)sv))) { if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", - SVfARG(sv))); + DEBUG_o(Perl_deb(aTHX_ + "sv_clear clearing PL_stashcache for '%"HEKf + "'\n", + HEKfARG(hek))); (void)hv_deletehek(PL_stashcache, - HvNAME_HEK((HV*)sv), G_DISCARD); + hek, G_DISCARD); } hv_name_set((HV*)sv, NULL, 0, 0); } @@ -6669,6 +6674,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); if (isREGEXP(sv)) goto freeregexp; + /* FALLTHROUGH */ case SVt_PVGV: if (isGV_with_GP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) @@ -6693,6 +6699,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_statgv = NULL; else if ((const GV *)sv == PL_stderrgv) PL_stderrgv = NULL; + /* FALLTHROUGH */ case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -10840,34 +10847,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); } -#if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \ - DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \ - DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN -# define DOUBLE_LITTLE_ENDIAN -#endif - -#ifdef HAS_LONG_DOUBLEKIND - -# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN -# define LONGDOUBLE_LITTLE_ENDIAN -# endif - -# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN -# define LONGDOUBLE_BIG_ENDIAN -# endif - -# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN -# define LONGDOUBLE_X86_80_BIT -# endif - -# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN -# define LONGDOUBLE_DOUBLEDOUBLE +#ifdef LONGDOUBLE_DOUBLEDOUBLE /* The first double can be as large as 2**1023, or '1' x '0' x 1023. * The second double can be as small as 2**-1074, or '0' x 1073 . '1'. * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point @@ -10877,10 +10857,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * of dynamically growing buffer might be better, start at just 16 bytes * (for example) and grow only when necessary. Or maybe just by looking * at the exponents of the two doubles? */ -# define DOUBLEDOUBLE_MAXBITS 2098 -# endif - -#endif /* HAS_LONG_DOUBLE */ +# define DOUBLEDOUBLE_MAXBITS 2098 +#endif /* vhex will contain the values (0..15) of the hex digits ("nybbles" * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits @@ -11227,7 +11205,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ bool hexfp = FALSE; /* hexadecimal floating point? */ - DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -11386,6 +11364,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifndef FV_ISFINITE # define FV_ISFINITE(x) Perl_isfinite((NV)(x)) #endif + NV nv; STRLEN have; STRLEN need; STRLEN gap; @@ -12129,19 +12108,25 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef USE_QUADMATH fv = intsize == 'q' ? va_arg(*args, NV) : va_arg(*args, double); + nv = fv; #elif LONG_DOUBLESIZE > DOUBLESIZE - if (intsize == 'q') + if (intsize == 'q') { fv = va_arg(*args, long double); - else - NV_TO_FV(va_arg(*args, double), fv); + nv = fv; + } else { + nv = va_arg(*args, double); + NV_TO_FV(nv, fv); + } #else - fv = va_arg(*args, double); + nv = va_arg(*args, double); + fv = nv; #endif } else { if (!infnan) SvGETMAGIC(argsv); - NV_TO_FV(SvNV_nomg(argsv), fv); + nv = SvNV_nomg(argsv); + NV_TO_FV(nv, fv); } need = 0; @@ -12288,7 +12273,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto float_converted; } } else if ( c == 'f' && !precis ) { - if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen))) + if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) break; } } @@ -12316,10 +12301,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * should be output as 0x0.0000000000001p-1022 to * match its internal structure. */ - /* Note: fv can be (and often is) long double. - * Here it is explicitly cast to NV. */ - vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL); - S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend); + vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL); + S_hextract(aTHX_ nv, &exponent, vhex, vend); #if NVSIZE > DOUBLESIZE # ifdef HEXTRACT_HAS_IMPLICIT_BIT @@ -12477,7 +12460,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } else { - elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize, plus); + elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus); if (elen) { /* Not affecting infnan output: precision, alt, fill. */ if (elen < width) { @@ -12553,7 +12536,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (!qfmt) Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr); elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, - qfmt, fv); + qfmt, nv); if ((IV)elen == -1) Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt); if (qfmt != ptr) @@ -13657,7 +13640,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) } items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { - *dst_ary++ = &PL_sv_undef; + *dst_ary++ = NULL; } } else { @@ -13898,17 +13881,22 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_LOOP_LAZYSV: ncx->blk_loop.state_u.lazysv.end = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); - /* We are taking advantage of av_dup_inc and sv_dup_inc - actually being the same function, and order equivalence of - the two unions. + /* Fallthrough: duplicate lazysv.cur by using the ary.ary + duplication code instead. + We are taking advantage of (1) av_dup_inc and sv_dup_inc + actually being the same function, and (2) order + equivalence of the two unions. We can assert the later [but only at run time :-(] */ assert ((void *) &ncx->blk_loop.state_u.ary.ary == (void *) &ncx->blk_loop.state_u.lazysv.cur); + /* FALLTHROUGH */ case CXt_LOOP_FOR: ncx->blk_loop.state_u.ary.ary = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); + /* FALLTHROUGH */ case CXt_LOOP_LAZYIV: case CXt_LOOP_PLAIN: + /* code common to all CXt_LOOP_* types */ if (CxPADLOOP(ncx)) { ncx->blk_loop.itervar_u.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, @@ -14459,6 +14447,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # ifdef DEBUG_LEAKING_SCALARS PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000; # endif +# ifdef PERL_TRACE_OPS + Zero(PL_op_exec_cnt, OP_max+2, UV); +# endif #else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); #endif /* DEBUGGING */ @@ -14965,9 +14956,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, for (i = 0; i < POSIX_CC_COUNT; i++) { PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); } + PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param); + PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param); + PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param); PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); - PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); - PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); @@ -15296,6 +15288,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) nsv = sv_newmortal(); SvSetSV_nosteal(nsv, sv); } + save_re_context(); PUSHMARK(sp); EXTEND(SP, 3); PUSHs(encoding); @@ -15361,11 +15354,12 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, PERL_ARGS_ASSERT_SV_CAT_DECODE; - if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { + if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) { SV *offsv; dSP; ENTER; SAVETMPS; + save_re_context(); PUSHMARK(sp); EXTEND(SP, 6); PUSHs(encoding); @@ -16236,11 +16230,5 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */