X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cca0492ec62cab786a01ea96c47e549fe0aa8c61..7432779b54fc5210793c84f9b87b6968ef4c5f51:/sv.c diff --git a/sv.c b/sv.c index 9cfddc1..087606b 100644 --- a/sv.c +++ b/sv.c @@ -33,11 +33,11 @@ #include "regcomp.h" #ifndef HAS_C99 -# if __STDC_VERSION__ >= 199901L && !defined(VMS) +# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(VMS) # define HAS_C99 1 # endif #endif -#if HAS_C99 +#ifdef HAS_C99 # include #endif @@ -52,7 +52,7 @@ #define V_Gconvert(x,n,t,b) \ { \ - char *rc = Gconvert(x,n,t,b); \ + char *rc = (char *)Gconvert(x,n,t,b); \ PERL_UNUSED_VAR(rc); \ } @@ -2300,8 +2300,7 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) { dVAR; - if (!sv) - return 0; + PERL_ARGS_ASSERT_SV_2IV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM); @@ -2396,8 +2395,7 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) { dVAR; - if (!sv) - return 0; + PERL_ARGS_ASSERT_SV_2UV_FLAGS; if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) mg_get(sv); @@ -2478,8 +2476,9 @@ NV Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) { dVAR; - if (!sv) - return 0.0; + + PERL_ARGS_ASSERT_SV_2NV_FLAGS; + assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { @@ -2782,11 +2781,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) dVAR; char *s; - if (!sv) { - if (lp) - *lp = 0; - return (char *)""; - } + PERL_ARGS_ASSERT_SV_2PV_FLAGS; + assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) @@ -2961,31 +2957,19 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) V_Gconvert(SvNVX(sv), NV_DIG, 0, s); SvPOK_on(sv); #else - /* Gconvert always uses the current locale. That's the right thing - * to do if we're supposed to be using locales. But otherwise, we - * want the result to be based on the C locale, so we need to - * change to the C locale during the Gconvert and then change back. - * But if we're already in the C locale (PL_numeric_standard is - * TRUE in that case), no need to do any changing */ - if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) { + { + DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); V_Gconvert(SvNVX(sv), NV_DIG, 0, s); /* If the radix character is UTF-8, and actually is in the * output, turn on the UTF-8 flag for the scalar */ - if (! PL_numeric_standard + if (PL_numeric_local && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) && instr(s, SvPVX_const(PL_numeric_radix_sv))) { SvUTF8_on(sv); } - } - else { - char *loc = savepv(setlocale(LC_NUMERIC, NULL)); - setlocale(LC_NUMERIC, "C"); - V_Gconvert(SvNVX(sv), NV_DIG, 0, s); - setlocale(LC_NUMERIC, loc); - Safefree(loc); - + RESTORE_LC_NUMERIC(); } /* We don't call SvPOK_on(), because it may come to pass that the @@ -3235,35 +3219,39 @@ Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes are invariant in UTF-8. If C has C bit set, will C on C if appropriate, else not. -Returns the number of bytes in the converted string -C and -C are implemented in terms of this function. + +If C has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV +will expand when converted to UTF-8, and skips the extra work of checking for +that. Typically this flag is used by a routine that has already parsed the +string and found such characters, and passes this information on so that the +work doesn't have to be repeated. + +Returns the number of bytes in the converted string. This is not a general purpose byte encoding to Unicode interface: use the Encode extension for that. -=cut +=for apidoc sv_utf8_upgrade_flags_grow + +Like sv_utf8_upgrade_flags, but has an additional parameter C, which is +the number of unused bytes the string of 'sv' is guaranteed to have free after +it upon return. This allows the caller to reserve extra space that it intends +to fill, to avoid extra grows. + +C, C, and C +are implemented in terms of this function. -The grow version is currently not externally documented. It adds a parameter, -extra, which is the number of unused bytes the string of 'sv' is guaranteed to -have free after it upon return. This allows the caller to reserve extra space -that it intends to fill, to avoid extra grows. +Returns the number of bytes in the converted string (not including the spares). -Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE, -which can be used to tell this function to not first check to see if there are -any characters that are different in UTF-8 (variant characters) which would -force it to allocate a new string to sv, but to assume there are. Typically -this flag is used by a routine that has already parsed the string to find that -there are such characters, and passes this information on so that the work -doesn't have to be repeated. +=cut (One might think that the calling routine could pass in the position of the -first such variant, so it wouldn't have to be found again. But that is not the -case, because typically when the caller is likely to use this flag, it won't be -calling this routine unless it finds something that won't fit into a byte. -Otherwise it tries to not upgrade and just use bytes. But some things that -do fit into a byte are variants in utf8, and the caller may not have been -keeping track of these.) +first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't +have to be found again. But that is not the case, because typically when the +caller is likely to use this flag, it won't be calling this routine unless it +finds something that won't fit into a byte. Otherwise it tries to not upgrade +and just use bytes. But some things that do fit into a byte are variants in +utf8, and the caller may not have been keeping track of these.) If the routine itself changes the string, it adds a trailing NUL. Such a NUL isn't guaranteed due to having other routines do the work in some input cases, @@ -3725,8 +3713,6 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } SvUPGRADE(dstr, SVt_PVGV); (void)SvOK_off(dstr); - /* We have to turn this on here, even though we turn it off - below, as GvSTASH will fail an assertion otherwise. */ isGV_with_GP_on(dstr); } GvSTASH(dstr) = GvSTASH(sstr); @@ -3787,12 +3773,11 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) ); } } + + SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr)); } gp_free(MUTABLE_GV(dstr)); - isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */ - (void)SvOK_off(dstr); - isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ GvGP_set(dstr, gp_ref(GvGP(sstr))); if (SvTAINTED(sstr)) @@ -4045,6 +4030,48 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) # define GE_COWBUF_THRESHOLD(len) 1 #endif +#ifdef PERL_DEBUG_READONLY_COW +# include + +# ifndef PERL_MEMORY_DEBUG_HEADER_SIZE +# define PERL_MEMORY_DEBUG_HEADER_SIZE 0 +# endif + +void +Perl_sv_buf_to_ro(pTHX_ SV *sv) +{ + struct perl_memory_debug_header * const header = + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + const MEM_SIZE len = header->size; + PERL_ARGS_ASSERT_SV_BUF_TO_RO; +# ifdef PERL_TRACK_MEMPOOL + if (!header->readonly) header->readonly = 1; +# endif + if (mprotect(header, len, PROT_READ)) + Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", + header, len, errno); +} + +static void +S_sv_buf_to_rw(pTHX_ SV *sv) +{ + struct perl_memory_debug_header * const header = + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + const MEM_SIZE len = header->size; + PERL_ARGS_ASSERT_SV_BUF_TO_RW; + if (mprotect(header, len, PROT_READ|PROT_WRITE)) + Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", + header, len, errno); +# ifdef PERL_TRACK_MEMPOOL + header->readonly = 0; +# endif +} + +#else +# define sv_buf_to_ro(sv) NOOP +# define sv_buf_to_rw(sv) NOOP +#endif + void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) { @@ -4287,8 +4314,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) reset_isa = TRUE; } - if (GvGP(dstr)) + if (GvGP(dstr)) { + SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr)); gp_free(MUTABLE_GV(dstr)); + } GvGP_set(dstr, gp_ref(GvGP(gv))); if (reset_isa) { @@ -4309,18 +4338,50 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); } else if (sflags & SVp_POK) { - bool isSwipe = 0; const STRLEN cur = SvCUR(sstr); const STRLEN len = SvLEN(sstr); /* - * Check to see if we can just swipe the string. If so, it's a - * 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. + * We have three basic ways to copy the string: + * + * 1. Swipe + * 2. Copy-on-write + * 3. Actual copy + * + * Which we choose is based on various factors. The following + * things are listed in order of speed, fastest to slowest: + * - Swipe + * - Copying a short string + * - Copy-on-write bookkeeping + * - malloc + * - Copying a long string + * + * We swipe the string (steal the string buffer) if the SV on the + * rhs is about to be freed anyway (TEMP and refcnt==1). This is a + * big win on long strings. It should be a win on short strings if + * SvPVX_const(dstr) has to be allocated. If not, it should not + * slow things down, as SvPVX_const(sstr) would have been freed + * soon anyway. + * + * We also steal the buffer from a PADTMP (operator target) if it + * is ‘long enough’. For short strings, a swipe does not help + * here, as it causes more malloc calls the next time the target + * is used. Benchmarks show that even if SvPVX_const(dstr) has to + * be allocated it is still not worth swiping PADTMPs for short + * strings, as the savings here are small. + * + * If the rhs is already flagged as a copy-on-write string and COW + * is possible here, we use copy-on-write and make both SVs share + * the string buffer. + * + * If the rhs is not flagged as copy-on-write, then we see whether + * it is worth upgrading it to such. If the lhs already has a buf- + * fer big enough and the string is short, we skip it and fall back + * to method 3, since memcpy is faster for short strings than the + * later bookkeeping overhead that copy-on-write entails. + * + * If there is no buffer on the left, or the buffer is too small, + * then we use copy-on-write. */ /* Whichever path we take through the next code, we want this true, @@ -4328,86 +4389,70 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) (void)SvPOK_only(dstr); if ( - /* 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_IsCOW) -#ifdef PERL_NEW_COPY_ON_WRITE - || (len && - ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur) - /* If this is a regular (non-hek) COW, only so many COW - "copies" are possible. */ - || CowREFCNT(sstr) == SV_COW_REFCNT_MAX)) -#endif - : 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_ANY_COW - /* 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) & SVf_BREAK) -#endif - ) - && - !(isSwipe = -#ifdef PERL_NEW_COPY_ON_WRITE + ( /* Either ... */ /* slated for free anyway (and not COW)? */ - (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP && -#else - (sflags & SVs_TEMP) && /* slated for free anyway? */ -#endif + (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP + /* or a swipable TARG */ + || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW)) + == SVs_PADTMP + /* whose buffer is worth stealing */ + && GE_COWBUF_THRESHOLD(cur) + ) + ) && !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ (!(flags & SV_NOSTEAL)) && /* and we're allowed to steal temps */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ len) /* and really is a string */ -#ifdef PERL_ANY_COW - && ((flags & SV_COW_SHARED_HASH_KEYS) - ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS -# ifdef PERL_OLD_COPY_ON_WRITE + { /* Passes the swipe test. */ + if (SvPVX_const(dstr)) /* we know that dtype >= SVt_PV */ + SvPV_free(dstr); + SvPV_set(dstr, SvPVX_mutable(sstr)); + SvLEN_set(dstr, SvLEN(sstr)); + SvCUR_set(dstr, SvCUR(sstr)); + + SvTEMP_off(dstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ + SvPV_set(sstr, NULL); + SvLEN_set(sstr, 0); + SvCUR_set(sstr, 0); + SvTEMP_off(sstr); + } + else if (flags & SV_COW_SHARED_HASH_KEYS + && +#ifdef PERL_OLD_COPY_ON_WRITE + ( sflags & SVf_IsCOW + || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS && SvTYPE(sstr) >= SVt_PVIV && len -# else + ) + ) +#elif defined(PERL_NEW_COPY_ON_WRITE) + (sflags & SVf_IsCOW + ? (!len || + ( (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1) + /* If this is a regular (non-hek) COW, only so + many COW "copies" are possible. */ + && CowREFCNT(sstr) != SV_COW_REFCNT_MAX )) + : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS && !(SvFLAGS(dstr) & SVf_BREAK) - && !(sflags & SVf_IsCOW) && GE_COW_THRESHOLD(cur) && cur+1 < len && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1) -# endif )) - : 1) +#else + sflags & SVf_IsCOW + && !(SvFLAGS(dstr) & SVf_BREAK) #endif ) { - /* Failed the swipe test, and it's not a shared hash key either. - Have to copy the string. */ - SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */ - Move(SvPVX_const(sstr),SvPVX(dstr),cur,char); - SvCUR_set(dstr, cur); - *SvEND(dstr) = '\0'; - } else { - /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always - be true in here. */ /* Either it's a shared hash key, or it's suitable for - copy-on-write or we can swipe the string. */ + copy-on-write. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); sv_dump(sstr); sv_dump(dstr); } #ifdef PERL_ANY_COW - if (!isSwipe) { - if (!(sflags & SVf_IsCOW)) { + if (!(sflags & SVf_IsCOW)) { SvIsCOW_on(sstr); # ifdef PERL_OLD_COPY_ON_WRITE /* Make the source SV into a loop of 1. @@ -4416,18 +4461,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) # else CowREFCNT(sstr) = 0; # endif - } } #endif - /* Initial code is common. */ if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ SvPV_free(dstr); } - if (!isSwipe) { - /* making another shared SV. */ #ifdef PERL_ANY_COW - if (len) { + if (len) { # ifdef PERL_OLD_COPY_ON_WRITE assert (SvTYPE(dstr) >= SVt_PVIV); /* SvIsCOW_normal */ @@ -4435,12 +4476,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); SV_COW_NEXT_SV_SET(sstr, dstr); # else + if (sflags & SVf_IsCOW) { + sv_buf_to_rw(sstr); + } CowREFCNT(sstr)++; # endif SvPV_set(dstr, SvPVX_mutable(sstr)); - } else + sv_buf_to_ro(sstr); + } else #endif - { + { /* SvIsCOW_shared_hash */ DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); @@ -4448,24 +4493,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) assert (SvTYPE(dstr) >= SVt_PV); SvPV_set(dstr, HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); - } - SvLEN_set(dstr, len); - SvCUR_set(dstr, cur); - SvIsCOW_on(dstr); - } - else - { /* Passes the swipe test. */ - SvPV_set(dstr, SvPVX_mutable(sstr)); - SvLEN_set(dstr, SvLEN(sstr)); - SvCUR_set(dstr, SvCUR(sstr)); - - SvTEMP_off(dstr); - (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ - SvPV_set(sstr, NULL); - SvLEN_set(sstr, 0); - SvCUR_set(sstr, 0); - SvTEMP_off(sstr); - } + } + SvLEN_set(dstr, len); + SvCUR_set(dstr, cur); + SvIsCOW_on(dstr); + } else { + /* Failed the swipe test, and we cannot do copy-on-write either. + Have to copy the string. */ + SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */ + Move(SvPVX_const(sstr),SvPVX(dstr),cur,char); + SvCUR_set(dstr, cur); + *SvEND(dstr) = '\0'; } if (sflags & SVp_NOK) { SvNV_set(dstr, SvNVX(sstr)); @@ -4538,6 +4576,9 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); char *new_pv; +#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE) + const bool already = cBOOL(SvIsCOW(sstr)); +#endif PERL_ARGS_ASSERT_SV_SETSV_COW; @@ -4598,9 +4639,13 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) # ifdef PERL_OLD_COPY_ON_WRITE SV_COW_NEXT_SV_SET(sstr, dstr); # else +# ifdef PERL_DEBUG_READONLY_COW + if (already) sv_buf_to_rw(sstr); +# endif CowREFCNT(sstr)++; # endif new_pv = SvPVX_mutable(sstr); + sv_buf_to_ro(sstr); common_exit: SvPV_set(dstr, new_pv); @@ -4875,6 +4920,7 @@ S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after) in the loop.) Hence other SV is no longer copy on write either. */ SvIsCOW_off(after); + sv_buf_to_rw(after); } else { /* We need to follow the pointers around the loop. */ SV *next; @@ -4908,6 +4954,10 @@ the C parameter gets passed to C when unreffing. C calls this function with flags set to 0. +This function is expected to be used to signal to perl that this SV is +about to be written to, and any extra book-keeping needs to be taken care +of. Hence, it croaks on read-only values. + =cut */ @@ -4939,7 +4989,7 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) # ifdef PERL_NEW_COPY_ON_WRITE if (len && CowREFCNT(sv) == 0) /* We own the buffer ourselves. */ - NOOP; + sv_buf_to_rw(sv); else # endif { @@ -4947,7 +4997,11 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) /* This SV doesn't own the buffer, so need to Newx() a new one: */ # ifdef PERL_NEW_COPY_ON_WRITE /* Must do this first, since the macro uses SvPVX. */ - if (len) CowREFCNT(sv)--; + if (len) { + sv_buf_to_rw(sv); + CowREFCNT(sv)--; + sv_buf_to_ro(sv); + } # endif SvPV_set(sv, NULL); SvLEN_set(sv, 0); @@ -6428,7 +6482,9 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); # else if (CowREFCNT(sv)) { + sv_buf_to_rw(sv); CowREFCNT(sv)--; + sv_buf_to_ro(sv); SvLEN_set(sv, 0); } # endif @@ -7733,6 +7789,8 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, raw_compare: /*FALLTHROUGH*/ +#else + PERL_UNUSED_ARG(flags); #endif /* USE_LOCALE_COLLATE */ return sv_cmp(sv1, sv2); @@ -8008,7 +8066,13 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { const Off_t offset = PerlIO_tell(fp); if (offset != (Off_t) -1 && st.st_size + append > offset) { - (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); +#ifdef PERL_NEW_COPY_ON_WRITE + /* Add an extra byte for the sake of copy-on-write's + * buffer reference count. */ + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); +#else + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); +#endif } } rsptr = NULL; @@ -9438,7 +9502,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) if (lp) *lp = len; - if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ + if (SvTYPE(sv) < SVt_PV || + s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ if (SvROK(sv)) sv_unref(sv); SvUPGRADE(sv, SVt_PV); /* Never FALSE */ @@ -9514,6 +9579,14 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) return SvPV_nolen_const(sv_ref(NULL, sv, ob)); } else { + /* WARNING - There is code, for instance in mg.c, that assumes that + * the only reason that sv_reftype(sv,0) would return a string starting + * with 'L' or 'S' is that it is a LVALUE or a SCALAR. + * Yes this a dodgy way to do type checking, but it saves practically reimplementing + * this routine inside other subs, and it saves time. + * Do not change this assumption without searching for "dodgy type check" in + * the code. + * - Yves */ switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: @@ -9878,6 +9951,7 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) if (!(flags & SV_COW_DROP_PV)) gv_efullname3(temp, MUTABLE_GV(sv), "*"); + SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); if (GvGP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) && HvNAME_get(stash)) @@ -10166,7 +10240,7 @@ Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT; va_start(args, pat); - sv_vcatpvf(sv, pat, &args); + sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); va_end(args); } @@ -10184,7 +10258,8 @@ Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT; va_start(args, pat); - sv_vcatpvf_mg(sv, pat, &args); + sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); + SvSETMAGIC(sv); va_end(args); } #endif @@ -10210,7 +10285,7 @@ Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) PERL_ARGS_ASSERT_SV_CATPVF; va_start(args, pat); - sv_vcatpvf(sv, pat, &args); + sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); va_end(args); } @@ -10230,7 +10305,7 @@ Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) { PERL_ARGS_ASSERT_SV_VCATPVF; - sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); + sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); } /* @@ -10249,7 +10324,8 @@ Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) PERL_ARGS_ASSERT_SV_CATPVF_MG; va_start(args, pat); - sv_vcatpvf_mg(sv, pat, &args); + sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC); + SvSETMAGIC(sv); va_end(args); } @@ -10416,9 +10492,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p char ebuf[IV_DIG * 4 + NV_DIG + 32]; /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ -#ifdef USE_LOCALE_NUMERIC - SV* oldlocale = NULL; -#endif + + DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -10471,6 +10546,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p a Configure test for this. */ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { /* 0, point, slack */ + STORE_LC_NUMERIC_SET_TO_NEEDED(); V_Gconvert(nv, (int)digits, 0, ebuf); sv_catpv_nomg(sv, ebuf); if (*ebuf) /* May return an empty string for digits==0 */ @@ -10856,7 +10932,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': case 'z': case 't': -#if HAS_C99 +#ifdef HAS_C99 case 'j': #endif intsize = *q++; @@ -10964,9 +11040,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /*FALLTHROUGH*/ case 'd': case 'i': -#if vdNUMBER - format_vd: -#endif if (vectorize) { STRLEN ulen; if (!veclen) @@ -10992,7 +11065,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'z': iv = va_arg(*args, SSize_t); break; case 't': iv = va_arg(*args, ptrdiff_t); break; default: iv = va_arg(*args, int); break; -#if HAS_C99 +#ifdef HAS_C99 case 'j': iv = va_arg(*args, intmax_t); break; #endif case 'q': @@ -11089,7 +11162,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': uv = va_arg(*args, UV); break; case 'z': uv = va_arg(*args, Size_t); break; case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ -#if HAS_C99 +#ifdef HAS_C99 case 'j': uv = va_arg(*args, uintmax_t); break; #endif default: uv = va_arg(*args, unsigned); break; @@ -11331,6 +11404,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* See earlier comment about buggy Gconvert when digits, aka precis is 0 */ if ( c == 'g' && precis) { + STORE_LC_NUMERIC_SET_TO_NEEDED(); V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); /* May return an empty string for digits==0 */ if (*PL_efloatbuf) { @@ -11380,20 +11454,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * where printf() taints but print($float) doesn't. * --jhi */ -#ifdef USE_LOCALE_NUMERIC - if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) { - - /* We use a mortal SV, so that any failures (such as if - * warnings are made fatal) won't leak */ - char *oldlocale_string = setlocale(LC_NUMERIC, NULL); - oldlocale = newSVpvn_flags(oldlocale_string, - strlen(oldlocale_string), - SVs_TEMP); - PL_numeric_standard = TRUE; - setlocale(LC_NUMERIC, "C"); - } -#endif + STORE_LC_NUMERIC_SET_TO_NEEDED(); + /* hopefully the above makes ptr a very constrained format + * that is safe to use, even though it's not literal */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); #if defined(HAS_LONG_DOUBLE) elen = ((intsize == 'q') ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) @@ -11401,11 +11466,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #else elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif + GCC_DIAG_RESTORE; } float_converted: eptr = PL_efloatbuf; #ifdef USE_LOCALE_NUMERIC + /* If the decimal point character in the string is UTF-8, make the + * output utf8 */ if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) && instr(eptr, SvPVX_const(PL_numeric_radix_sv))) { @@ -11430,7 +11498,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': *(va_arg(*args, IV*)) = i; break; case 'z': *(va_arg(*args, SSize_t*)) = i; break; case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; -#if HAS_C99 +#ifdef HAS_C99 case 'j': *(va_arg(*args, intmax_t*)) = i; break; #endif case 'q': @@ -11570,13 +11638,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } SvTAINT(sv); -#ifdef USE_LOCALE_NUMERIC /* Done outside loop, so don't have to save/restore + RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore each iteration. */ - if (oldlocale) { - setlocale(LC_NUMERIC, SvPVX(oldlocale)); - PL_numeric_standard = FALSE; - } -#endif } /* ========================================================================= @@ -11772,7 +11835,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) { DIR *ret; -#ifdef HAS_FCHDIR +#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) int rc = 0; DIR *pwd; const Direntry_t *dirent; @@ -11793,7 +11856,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) if (ret) return ret; -#ifdef HAS_FCHDIR +#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) PERL_UNUSED_ARG(param); @@ -12038,7 +12101,9 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) return tblent ? tblent->newval : NULL; } -/* add a new entry to a pointer-mapping table */ +/* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is + * the key; 'newsv' is the value. The names "old" and "new" are specific to + * the core's typical use of ptr_tables in thread cloning. */ void Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) @@ -12551,6 +12616,11 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_name_count = saux->xhv_name_count; daux->xhv_fill_lazy = saux->xhv_fill_lazy; + daux->xhv_aux_flags = saux->xhv_aux_flags; +#ifdef PERL_HASH_RANDOMIZE_KEYS + daux->xhv_rand = saux->xhv_rand; + daux->xhv_last_rand = saux->xhv_last_rand; +#endif daux->xhv_riter = saux->xhv_riter; daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, @@ -13313,7 +13383,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargc = proto_perl->Iorigargc; PL_origargv = proto_perl->Iorigargv; -#if !NO_TAINT_SUPPORT +#ifndef NO_TAINT_SUPPORT /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; PL_taint_warn = proto_perl->Itaint_warn; @@ -13421,6 +13491,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Did the locale setup indicate UTF-8? */ PL_utf8locale = proto_perl->Iutf8locale; + PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale; /* Unicode features (see perlrun/-C) */ PL_unicode = proto_perl->Iunicode; @@ -13489,11 +13560,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statbuf = proto_perl->Istatbuf; PL_statcache = proto_perl->Istatcache; -#ifdef HAS_TIMES - PL_timesbuf = proto_perl->Itimesbuf; -#endif - -#if !NO_TAINT_SUPPORT +#ifndef NO_TAINT_SUPPORT PL_tainted = proto_perl->Itainted; #else PL_tainted = FALSE; @@ -13751,15 +13818,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); - PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param); + PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param); /* utf8 character class swashes */ for (i = 0; i < POSIX_SWASH_COUNT; i++) { PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param); } for (i = 0; i < POSIX_CC_COUNT; i++) { - PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param); - PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param); PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); } PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); @@ -13882,7 +13947,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. */ - while(av_len(param->stashes) != -1) { + while(av_tindex(param->stashes) != -1) { HV* const stash = MUTABLE_HV(av_shift(param->stashes)); GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); if (cloner && GvCV(cloner)) { @@ -14085,14 +14150,19 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) STRLEN len; const char *s; dSP; + SV *nsv = sv; ENTER; PUSHSTACK; SAVETMPS; + if (SvPADTMP(nsv)) { + nsv = sv_newmortal(); + SvSetSV_nosteal(nsv, sv); + } save_re_context(); PUSHMARK(sp); EXTEND(SP, 3); PUSHs(encoding); - PUSHs(sv); + PUSHs(nsv); /* NI-S 2002/07/09 Passing sv_yes is wrong - it needs to be or'ed set of constants @@ -14448,12 +14518,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); if (!av || SvRMAGICAL(av)) break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); + svp = av_fetch(av, (I8)obase->op_private, FALSE); if (!svp || *svp != uninit_sv) break; } return varname(NULL, '$', obase->op_targ, - NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); case OP_AELEMFAST: { gv = cGVOPx_gv(obase); @@ -14464,12 +14534,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, AV *const av = GvAV(gv); if (!av || SvRMAGICAL(av)) break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); + svp = av_fetch(av, (I8)obase->op_private, FALSE); if (!svp || *svp != uninit_sv) break; } return varname(gv, '$', 0, - NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); } break; @@ -14814,14 +14884,21 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) if (varname) sv_insert(varname, 0, 0, " ", 1); } + /* PL_warn_uninit_sv is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* diag_listed_as: Use of uninitialized value%s */ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv, SVfARG(varname ? varname : &PL_sv_no), " in ", OP_DESC(PL_op)); + GCC_DIAG_RESTORE; } - else + else { + /* PL_warn_uninit is constant */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "", ""); + GCC_DIAG_RESTORE; + } } /*