X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0dc4a61d58c3a71942ef87b50b9cb593f0ae899b..7432779b54fc5210793c84f9b87b6968ef4c5f51:/sv.c diff --git a/sv.c b/sv.c index 632d1dc..087606b 100644 --- a/sv.c +++ b/sv.c @@ -33,21 +33,30 @@ #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 -#define FCALL *f - #ifdef __Lynx__ /* Missing proto on LynxOS */ char *gconvert(double, int, int, char *); #endif +/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to), + * has a mandatory return value, even though that value is just the same + * as the buf arg */ + +#define V_Gconvert(x,n,t,b) \ +{ \ + char *rc = (char *)Gconvert(x,n,t,b); \ + PERL_UNUSED_VAR(rc); \ +} + + #ifdef PERL_UTF8_CACHE_ASSERT /* if adding more checks watch out for the following tests: * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t @@ -419,7 +428,7 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) && (sv->sv_flags & mask) == flags && SvREFCNT(sv)) { - (FCALL)(aTHX_ sv); + (*f)(aTHX_ sv); ++visited; } } @@ -772,19 +781,19 @@ is "not there", because you'll be overwriting the last members of the preceding structure in memory.) We calculate the correction using the STRUCT_OFFSET macro on the first -member present. If the allocated structure is smaller (no initial NV +member present. If the allocated structure is smaller (no initial NV actually allocated) then the net effect is to subtract the size of the NV from the pointer, to return a new pointer as if an initial NV were actually -allocated. (We were using structures named *_allocated for this, but +allocated. (We were using structures named *_allocated for this, but this turned out to be a subtle bug, because a structure without an NV could have a lower alignment constraint, but the compiler is allowed to optimised accesses based on the alignment constraint of the actual pointer to the full structure, for example, using a single 64 bit load instruction because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) -This is the same trick as was used for NV and IV bodies. Ironically it +This is the same trick as was used for NV and IV bodies. Ironically it doesn't need to be used for NV bodies any more, because NV is now at -the start of the structure. IV bodies don't need it either, because +the start of the structure. IV bodies don't need it either, because they are no longer allocated. In turn, the new_body_* allocators call S_new_body(), which invokes @@ -1479,13 +1488,6 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) PERL_ARGS_ASSERT_SV_GROW; -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, - "Allocation too large: %"UVxf"\n", (UV)newlen); - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ if (SvROK(sv)) sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { @@ -1497,10 +1499,6 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) - newlen = 0xFFFF; -#endif } else { @@ -1749,10 +1747,12 @@ S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { const char * const end = s + SvCUR(sv); for ( ; s < end && d < limit; s++ ) { int ch = *s & 0xFF; - if (ch & 128 && !isPRINT_LC(ch)) { + if (! isASCII(ch) && !isPRINT_LC(ch)) { *d++ = 'M'; *d++ = '-'; - ch &= 127; + + /* Map to ASCII "equivalent" of Latin1 */ + ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); } if (ch == '\n') { *d++ = '\\'; @@ -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)) @@ -2958,34 +2954,22 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) /* some Xenix systems wipe out errno here */ #ifndef USE_LOCALE_NUMERIC - Gconvert(SvNVX(sv), NV_DIG, 0, s); + 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) { - Gconvert(SvNVX(sv), NV_DIG, 0, s); + { + 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"); - 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 @@ -2996,10 +2980,6 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) RESTORE_ERRNO; while (*s) s++; } -#ifdef hcx - if (s[-1] == '.') - *--s = '\0'; -#endif } else if (isGV_with_GP(sv)) { GV *const gv = MUTABLE_GV(sv); @@ -3167,12 +3147,13 @@ contain SV_GMAGIC, then it does an mg_get() first. */ bool -Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags) +Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) { dVAR; PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; + restart: if(flags & SV_GMAGIC) SvGETMAGIC(sv); if (!SvOK(sv)) @@ -3180,8 +3161,30 @@ Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags) if (SvROK(sv)) { if (SvAMAGIC(sv)) { SV * const tmpsv = AMG_CALLunary(sv, bool__amg); - if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return cBOOL(SvTRUE(tmpsv)); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { + bool svb; + sv = tmpsv; + if(SvGMAGICAL(sv)) { + flags = SV_GMAGIC; + goto restart; /* call sv_2bool */ + } + /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */ + else if(!SvOK(sv)) { + svb = 0; + } + else if(SvPOK(sv)) { + svb = SvPVXtrue(sv); + } + else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) { + svb = (SvIOK(sv) && SvIVX(sv) != 0) + || (SvNOK(sv) && SvNVX(sv) != 0.0); + } + else { + flags = 0; + goto restart; /* call sv_2bool_nomg */ + } + return cBOOL(svb); + } } return SvRV(sv) != 0; } @@ -3216,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. -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. +C, C, and C +are implemented in terms of this function. -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. +Returns the number of bytes in the converted string (not including the spares). + +=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, @@ -3314,7 +3321,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr while (t < e) { const U8 ch = *t++; - if (NATIVE_IS_INVARIANT(ch)) continue; + if (NATIVE_BYTE_IS_INVARIANT(ch)) continue; t--; /* t already incremented; re-point to first variant */ two_byte_count = 1; @@ -3449,7 +3456,7 @@ must_be_utf8: while (d < e) { const U8 chr = *d++; - if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++; + if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++; } /* The string will expand by just the number of bytes that @@ -3469,7 +3476,7 @@ must_be_utf8: e--; while (e >= t) { - if (NATIVE_IS_INVARIANT(*e)) { + if (NATIVE_BYTE_IS_INVARIANT(*e)) { *d-- = *e; } else { *d-- = UTF8_EIGHT_BIT_LO(*e); @@ -3654,9 +3661,10 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) Copies the contents of the source SV C into the destination SV C. The source SV may be destroyed if it is mortal, so don't use this -function if the source SV needs to be reused. Does not handle 'set' magic. -Loosely speaking, it performs a copy-by-value, obliterating any previous -content of the destination. +function if the source SV needs to be reused. Does not handle 'set' magic on +destination SV. Calls 'get' magic on source SV. Loosely speaking, it +performs a copy-by-value, obliterating any previous content of the +destination. You probably want to use one of the assortment of wrappers, such as C, C, C and @@ -3671,7 +3679,7 @@ Loosely speaking, it performs a copy-by-value, obliterating any previous content of the destination. If the C parameter has the C bit set, will C on C if appropriate, else not. If the C -parameter has the C bit set then the +parameter has the C bit set then the buffers of temps will not be stolen. and C are implemented in terms of this function. @@ -3705,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); @@ -3767,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)) @@ -4025,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) { @@ -4267,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) { @@ -4289,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, @@ -4308,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. @@ -4396,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 */ @@ -4415,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")); @@ -4428,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)); @@ -4518,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; @@ -4578,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); @@ -4855,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; @@ -4888,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 */ @@ -4919,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 { @@ -4927,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); @@ -5694,12 +5768,10 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) if (SvTYPE(tsv) == SVt_PVHV) { svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } else { - if (! ((mg = - (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL)))) - { - sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0); - mg = mg_find(tsv, PERL_MAGIC_backref); - } + if (SvMAGICAL(tsv)) + mg = mg_find(tsv, PERL_MAGIC_backref); + if (!mg) + mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0); svp = &(mg->mg_obj); } @@ -5709,32 +5781,32 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) || (*svp && SvTYPE(*svp) != SVt_PVAV) ) { /* create array */ + if (mg) + mg->mg_flags |= MGf_REFCOUNTED; av = newAV(); AvREAL_off(av); - SvREFCNT_inc_simple_void(av); + SvREFCNT_inc_simple_void_NN(av); /* av now has a refcnt of 2; see discussion above */ + av_extend(av, *svp ? 2 : 1); if (*svp) { /* move single existing backref to the array */ - av_extend(av, 1); AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ } *svp = (SV*)av; - if (mg) - mg->mg_flags |= MGf_REFCOUNTED; } - else + else { av = MUTABLE_AV(*svp); - - if (!av) { - /* optimisation: store single backref directly in HvAUX or mg_obj */ - *svp = sv; - return; + if (!av) { + /* optimisation: store single backref directly in HvAUX or mg_obj */ + *svp = sv; + return; + } + assert(SvTYPE(av) == SVt_PVAV); + if (AvFILLp(av) >= AvMAX(av)) { + av_extend(av, AvFILLp(av)+1); + } } /* push new backref */ - assert(SvTYPE(av) == SVt_PVAV); - if (AvFILLp(av) >= AvMAX(av)) { - av_extend(av, AvFILLp(av)+1); - } AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ } @@ -6295,8 +6367,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if (PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", sv)); - (void)hv_delete(PL_stashcache, name, - HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, + HvNAME_HEK((HV*)sv), G_DISCARD); } hv_name_set((HV*)sv, NULL, 0, 0); } @@ -6410,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 @@ -7715,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); @@ -7926,8 +8002,8 @@ S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) =for apidoc sv_gets Get a line from the filehandle and store it into the SV, optionally -appending to the currently-stored string. If C is not 0, the -line is appended to the SV instead of overwriting it. C should +appending to the currently-stored string. If C is not 0, the +line is appended to the SV instead of overwriting it. C should be set to the byte offset that the appended string should start at in the SV (typically, C is a suitable choice). @@ -7942,9 +8018,9 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) STRLEN rslen; STDCHAR rslast; STDCHAR *bp; - I32 cnt; - I32 i = 0; - I32 rspara = 0; + SSize_t cnt; + int i = 0; + int rspara = 0; PERL_ARGS_ASSERT_SV_GETS; @@ -7990,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; @@ -8089,8 +8171,9 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%" + UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: @@ -8124,13 +8207,13 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) cannot_be_shortbuffered: DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", - PTR2UV(ptr),(long)cnt)); + "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n", + PTR2UV(ptr),cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* This used to call 'filbuf' in stdio form, but as that behaves like @@ -8139,14 +8222,15 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) i = PerlIO_getc(fp); /* get more characters */ DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n", + PTR2UV(ptr),cnt)); if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; @@ -8170,11 +8254,12 @@ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", - PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf + "\n", + PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ @@ -9417,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 */ @@ -9493,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: @@ -9617,7 +9711,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name) Creates a new SV for the existing RV, C, to point to. If C is not an RV then it will be upgraded to one. If C is non-null then the new SV will be blessed in the specified package. The new SV is returned and its -reference count is 1. The reference count 1 is owned by C. +reference count is 1. The reference count 1 is owned by C. =cut */ @@ -9659,6 +9753,19 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) return sv; } +SV * +Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible) +{ + SV * const lv = newSV_type(SVt_PVLV); + PERL_ARGS_ASSERT_NEWSVAVDEFELEM; + LvTYPE(lv) = 'y'; + sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); + LvTARG(lv) = SvREFCNT_inc_simple_NN(av); + LvSTARGOFF(lv) = ix; + LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX; + return lv; +} + /* =for apidoc sv_setref_pv @@ -9796,6 +9903,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) { dVAR; SV *tmpRef; + HV *oldstash = NULL; PERL_ARGS_ASSERT_SV_BLESS; @@ -9807,12 +9915,13 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) if (SvREADONLY(tmpRef)) Perl_croak_no_modify(); if (SvOBJECT(tmpRef)) { - SvREFCNT_dec(SvSTASH(tmpRef)); + oldstash = SvSTASH(tmpRef); } } SvOBJECT_on(tmpRef); SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); + SvREFCNT_dec(oldstash); if(SvSMAGICAL(tmpRef)) if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) @@ -9842,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)) @@ -10130,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); } @@ -10148,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 @@ -10174,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); } @@ -10194,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); } /* @@ -10213,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); } @@ -10381,6 +10493,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; + PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -10432,7 +10546,8 @@ 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 */ - Gconvert(nv, (int)digits, 0, ebuf); + 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 */ return; @@ -10785,10 +10900,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p q++; break; #endif -#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) +#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) case 'L': /* Ld */ /*FALLTHROUGH*/ -#ifdef HAS_QUAD +#if IVSIZE >= 8 case 'q': /* qd */ #endif intsize = 'q'; @@ -10797,7 +10912,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #endif case 'l': ++q; -#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) +#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) if (*q == 'l') { /* lld, llf */ intsize = 'q'; ++q; @@ -10817,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++; @@ -10856,7 +10971,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto unknown; uv = (args) ? va_arg(*args, int) : SvIV(argsv); if ((uv > 255 || - (!NATIVE_IS_INVARIANT(uv) && SvUTF8(sv))) + (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { eptr = (char*)utf8buf; elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; @@ -10925,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) @@ -10953,11 +11065,11 @@ 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': -#ifdef HAS_QUAD +#if IVSIZE >= 8 iv = va_arg(*args, Quad_t); break; #else goto unknown; @@ -10973,7 +11085,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': default: iv = tiv; break; case 'q': -#ifdef HAS_QUAD +#if IVSIZE >= 8 iv = (Quad_t)tiv; break; #else goto unknown; @@ -11050,12 +11162,12 @@ 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; case 'q': -#ifdef HAS_QUAD +#if IVSIZE >= 8 uv = va_arg(*args, Uquad_t); break; #else goto unknown; @@ -11071,7 +11183,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': default: uv = tuv; break; case 'q': -#ifdef HAS_QUAD +#if IVSIZE >= 8 uv = (Uquad_t)tuv; break; #else goto unknown; @@ -11292,7 +11404,8 @@ 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) { - Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); + 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) { elen = strlen(PL_efloatbuf); @@ -11340,6 +11453,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* No taint. Otherwise we are in the strange situation * where printf() taints but print($float) doesn't. * --jhi */ + + 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) @@ -11347,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))) { @@ -11376,11 +11498,11 @@ 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': -#ifdef HAS_QUAD +#if IVSIZE >= 8 *(va_arg(*args, Quad_t*)) = i; break; #else goto unknown; @@ -11515,6 +11637,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } SvTAINT(sv); + + RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore + each iteration. */ } /* ========================================================================= @@ -11710,7 +11835,8 @@ 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; char smallbuf[256]; @@ -11730,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); @@ -11747,7 +11873,9 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) /* Now we should have two dir handles pointing to the same dir. */ /* Be nice to the calling code and chdir back to where we were. */ - fchdir(my_dirfd(pwd)); /* If this fails, then what? */ + rc = fchdir(my_dirfd(pwd)); + /* XXX If this fails, then what? */ + PERL_UNUSED_VAR(rc); /* We have no need of the pwd handle any more. */ PerlDir_close(pwd); @@ -11973,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) @@ -12486,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, @@ -13248,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; @@ -13356,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; @@ -13393,6 +13529,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_last_swash_slen = 0; PL_srand_called = proto_perl->Isrand_called; + Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); if (flags & CLONEf_COPY_STACKS) { /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ @@ -13423,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; @@ -13514,9 +13647,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PerlIO_clone(aTHX_ proto_perl, param); #endif - PL_envgv = gv_dup(proto_perl->Ienvgv, param); - PL_incgv = gv_dup(proto_perl->Iincgv, param); - PL_hintgv = gv_dup(proto_perl->Ihintgv, param); + PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param); + PL_incgv = gv_dup_inc(proto_perl->Iincgv, param); + PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param); PL_origfilename = SAVEPV(proto_perl->Iorigfilename); PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); @@ -13558,20 +13691,20 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stdingv = gv_dup(proto_perl->Istdingv, param); PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); PL_defgv = gv_dup(proto_perl->Idefgv, param); - PL_argvgv = gv_dup(proto_perl->Iargvgv, param); + PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param); PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); /* shortcuts to regexp stuff */ - PL_replgv = gv_dup(proto_perl->Ireplgv, param); + PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param); /* shortcuts to misc objects */ PL_errgv = gv_dup(proto_perl->Ierrgv, param); /* shortcuts to debugging objects */ - PL_DBgv = gv_dup(proto_perl->IDBgv, param); - PL_DBline = gv_dup(proto_perl->IDBline, param); - PL_DBsub = gv_dup(proto_perl->IDBsub, param); + PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param); + PL_DBline = gv_dup_inc(proto_perl->IDBline, param); + PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param); PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); @@ -13680,20 +13813,18 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* !USE_LOCALE_NUMERIC */ /* Unicode inversion lists */ - PL_ASCII = sv_dup_inc(proto_perl->IASCII, param); PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); + PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); 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); @@ -13794,8 +13925,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_errors = sv_dup_inc(proto_perl->Ierrors, param); PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); - PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); - PL_secondgv = gv_dup(proto_perl->Isecondgv, param); + PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param); + PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param); PL_stashcache = newHV(); @@ -13816,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)) { @@ -14019,13 +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 @@ -14048,6 +14185,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) SvCUR_set(sv, len); } FREETMPS; + POPSTACK; LEAVE; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { /* clear pos and any utf8 cache */ @@ -14380,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); @@ -14396,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; @@ -14746,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; + } } /*