X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/368ac47cccd4ffca6e83a26289c152a32c2ea385..a8def808210e08cea0b7889fea7c5146b21af4ed:/sv.c diff --git a/sv.c b/sv.c index 83de536..0a853bc 100644 --- a/sv.c +++ b/sv.c @@ -2086,10 +2086,6 @@ 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) { @@ -2118,9 +2114,6 @@ 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) @@ -2519,6 +2512,8 @@ Return the unsigned integer value of an SV, doing any necessary string conversion. If C has the C bit set, does an C first. Normally used via the C and C macros. +=for apidoc Amnh||SV_GMAGIC + =cut */ @@ -3322,18 +3317,19 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) +Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) { - PERL_ARGS_ASSERT_SV_2PVBYTE; + PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS; - SvGETMAGIC(sv); + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) || isGV_with_GP(sv) || SvROK(sv)) { SV *sv2 = sv_newmortal(); sv_copypv_nomg(sv2,sv); sv = sv2; } - sv_utf8_downgrade(sv,0); + sv_utf8_downgrade_nomg(sv,0); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3349,15 +3345,18 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) +Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) { - PERL_ARGS_ASSERT_SV_2PVUTF8; + PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS; + if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) + mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) - || isGV_with_GP(sv) || SvROK(sv)) - sv = sv_mortalcopy(sv); - else - SvGETMAGIC(sv); + || isGV_with_GP(sv) || SvROK(sv)) { + SV *sv2 = sv_newmortal(); + sv_copypv_nomg(sv2,sv); + sv = sv2; + } sv_utf8_upgrade_nomg(sv); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); } @@ -3649,19 +3648,30 @@ true, croaks. This is not a general purpose Unicode to byte encoding interface: use the C extension for that. +This function process get magic on C. + +=for apidoc sv_utf8_downgrade_nomg + +Like C, but does not process get magic on C. + +=for apidoc sv_utf8_downgrade_flags + +Like C, but with additional C. +If C has C bit set, processes get magic on C. + =cut */ bool -Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) +Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags) { - PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; + PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS; if (SvPOKp(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { U8 *s; STRLEN len; - int mg_flags = SV_GMAGIC; + U32 mg_flags = flags & SV_GMAGIC; if (SvIsCOW(sv)) { S_sv_uncow(aTHX_ sv, 0); @@ -3671,7 +3681,7 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, - SV_GMAGIC|SV_CONST_RETURN); + mg_flags|SV_CONST_RETURN); mg_flags = 0; /* sv_pos_b2u does get magic */ } if ((mg = mg_find(sv, PERL_MAGIC_utf8))) @@ -3811,6 +3821,8 @@ C. This is the primary function for copying scalars, and most other copy-ish functions and macros use this underneath. +=for apidoc Amnh||SV_NOSTEAL + =cut */ @@ -5100,6 +5112,9 @@ and the realloc will be skipped (i.e. the buffer is actually at least 1 byte longer than C, and already meets the requirements for storing in C). +=for apidoc Amnh||SV_SMAGIC +=for apidoc Amnh||SV_HAS_TRAILING_NUL + =cut */ @@ -5266,6 +5281,8 @@ 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. +=for apidoc Amnh||SV_COW_DROP_PV + =cut */ @@ -6637,9 +6654,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_del_backref(MUTABLE_SV(stash), sv); goto freescalar; case SVt_PVHV: - if (PL_last_swash_hv == (const HV *)sv) { - PL_last_swash_hv = NULL; - } if (HvTOTALKEYS((HV*)sv) > 0) { const HEK *hek; /* this statement should match the one at the beginning of @@ -9295,6 +9309,9 @@ C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +=for apidoc Amnh||SVf_UTF8 +=for apidoc Amnh||SVs_TEMP + =cut */ @@ -10604,6 +10621,8 @@ C to force the reference count to be decremented different from one or the reference being a readonly SV). See C>. +=for apidoc Amnh||SV_IMMEDIATE_UNREF + =cut */ @@ -10715,7 +10734,12 @@ Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) { PERL_ARGS_ASSERT_SV_SETPVIV_MG; + GCC_DIAG_IGNORE_STMT(-Wdeprecated-declarations); + sv_setpviv(sv, iv); + + GCC_DIAG_RESTORE_STMT; + SvSETMAGIC(sv); } @@ -11562,7 +11586,9 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, * The rest of the args have the same meaning as the local vars of the * same name within Perl_sv_vcatpvfn_flags(). * - * It assumes the caller has already done STORE_LC_NUMERIC_SET_TO_NEEDED(); + * The caller's determination of IN_LC(LC_NUMERIC), passed as in_lc_numeric, + * is used to ensure we do the right thing when we need to access the locale's + * numeric radix. * * It requires the caller to make buf large enough. */ @@ -11571,7 +11597,7 @@ static STRLEN S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, const NV nv, const vcatpvfn_long_double_t fv, bool has_precis, STRLEN precis, STRLEN width, - bool alt, char plus, bool left, bool fill) + bool alt, char plus, bool left, bool fill, bool in_lc_numeric) { /* Hexadecimal floating point. */ char* p = buf; @@ -11778,17 +11804,19 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, if (hexradix) { #ifndef USE_LOCALE_NUMERIC - *p++ = '.'; + *p++ = '.'; #else - if (IN_LC(LC_NUMERIC)) { - STRLEN n; + if (in_lc_numeric) { + STRLEN n; + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, { const char* r = SvPV(PL_numeric_radix_sv, n); Copy(r, p, n, char); - p += n; - } - else { - *p++ = '.'; - } + }); + p += n; + } + else { + *p++ = '.'; + } #endif } @@ -11894,9 +11922,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p char ebuf[IV_DIG * 4 + NV_DIG + 32]; bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ #ifdef USE_LOCALE_NUMERIC - DECLARATION_FOR_LC_NUMERIC_MANIPULATION; - bool lc_numeric_set = FALSE; /* called STORE_LC_NUMERIC_SET_TO_NEEDED? */ + bool have_in_lc_numeric = FALSE; #endif + /* we never change this unless USE_LOCALE_NUMERIC */ + bool in_lc_numeric = FALSE; PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -12159,15 +12188,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* the asterisk specified a width */ { int i = 0; - SV *sv = NULL; + SV *width_sv = NULL; if (args) i = va_arg(*args, int); else { ix = ix ? ix - 1 : svix++; - sv = (ix < sv_count) ? svargs[ix] + width_sv = (ix < sv_count) ? svargs[ix] : (arg_missing = TRUE, (SV*)NULL); } - width = S_sprintf_arg_num_val(aTHX_ args, i, sv, &left); + width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left); } } else if (*q == 'v') { @@ -12214,17 +12243,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p { int i = 0; - SV *sv = NULL; + SV *width_sv = NULL; bool neg = FALSE; if (args) i = va_arg(*args, int); else { ix = ix ? ix - 1 : svix++; - sv = (ix < sv_count) ? svargs[ix] + width_sv = (ix < sv_count) ? svargs[ix] : (arg_missing = TRUE, (SV*)NULL); } - precis = S_sprintf_arg_num_val(aTHX_ args, i, sv, &neg); + precis = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &neg); has_precis = !neg; /* ignore negative precision */ if (!has_precis) @@ -12967,33 +12996,31 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * below, or implicitly, via an snprintf() variant. * Note also things like ps_AF.utf8 which has * "\N{ARABIC DECIMAL SEPARATOR} as a radix point */ - if (!lc_numeric_set) { - /* only set once and reuse in-locale value on subsequent - * iterations. - * XXX what happens if we die in an eval? - */ - STORE_LC_NUMERIC_SET_TO_NEEDED(); - lc_numeric_set = TRUE; + if (! have_in_lc_numeric) { + in_lc_numeric = IN_LC(LC_NUMERIC); + have_in_lc_numeric = TRUE; } - if (IN_LC(LC_NUMERIC)) { - /* this can't wrap unless PL_numeric_radix_sv is a string - * consuming virtually all the 32-bit or 64-bit address - * space - */ - float_need += (SvCUR(PL_numeric_radix_sv) - 1); - - /* floating-point formats only get utf8 if the radix point - * is utf8. All other characters in the string are < 128 - * and so can be safely appended to both a non-utf8 and utf8 - * string as-is. - * Note that this will convert the output to utf8 even if - * the radix point didn't get output. - */ - if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) { - sv_utf8_upgrade(sv); - has_utf8 = TRUE; - } + if (in_lc_numeric) { + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, { + /* this can't wrap unless PL_numeric_radix_sv is a string + * consuming virtually all the 32-bit or 64-bit address + * space + */ + float_need += (SvCUR(PL_numeric_radix_sv) - 1); + + /* floating-point formats only get utf8 if the radix point + * is utf8. All other characters in the string are < 128 + * and so can be safely appended to both a non-utf8 and utf8 + * string as-is. + * Note that this will convert the output to utf8 even if + * the radix point didn't get output. + */ + if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) { + sv_utf8_upgrade(sv); + has_utf8 = TRUE; + } + }); } #endif @@ -13068,7 +13095,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p && !fill && intsize != 'q' ) { - SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis); + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, + SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis) + ); elen = strlen(ebuf); eptr = ebuf; goto float_concat; @@ -13113,7 +13142,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (UNLIKELY(hexfp)) { elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c, nv, fv, has_precis, precis, width, - alt, plus, left, fill); + alt, plus, left, fill, in_lc_numeric); } else { char *ptr = ebuf + sizeof ebuf; @@ -13166,25 +13195,26 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); #ifdef USE_QUADMATH { - const char* qfmt = quadmath_format_single(ptr); - if (!qfmt) + if (!quadmath_format_valid(ptr)) Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr); - elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, - qfmt, nv); + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, + elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, + ptr, nv); + ); if ((IV)elen == -1) { - if (qfmt != ptr) - SAVEFREEPV(qfmt); - Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", ptr); } - if (qfmt != ptr) - Safefree(qfmt); } #elif defined(HAS_LONG_DOUBLE) - elen = ((intsize == 'q') - ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) - : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv)); + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, + elen = ((intsize == 'q') + ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) + : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv)) + ); #else - elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv); + WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, + elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) + ); #endif GCC_DIAG_RESTORE_STMT; } @@ -13246,7 +13276,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Perl_croak_nocontext( "Missing argument for %%n in %s", PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); - sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)len); + sv_setuv_mg(argsv, has_utf8 + ? (UV)utf8_length((U8*)SvPVX(sv), (U8*)SvEND(sv)) + : (UV)len); } goto done_valid_conversion; } @@ -13405,17 +13437,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } - SvTAINT(sv); - -#ifdef USE_LOCALE_NUMERIC - - if (lc_numeric_set) { - RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to - save/restore each iteration. */ + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* while we shouldn't set the cache, it may have been previously + set in the caller, so clear it */ + MAGIC *mg = mg_find(sv, PERL_MAGIC_utf8); + if (mg) + magic_setutf8(sv,mg); /* clear UTF8 cache */ } - -#endif - + SvTAINT(sv); } /* ========================================================================= @@ -14655,6 +14684,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) nsi->si_stack = av_dup_inc(si->si_stack, param); nsi->si_cxix = si->si_cxix; + nsi->si_cxsubix = si->si_cxsubix; nsi->si_cxmax = si->si_cxmax; nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); nsi->si_type = si->si_type; @@ -15054,16 +15084,15 @@ C - C keeps a ptr_table with the pointer of the old variable as a key and the new variable as a value, this allows it to check if something has been cloned and not -clone it again but rather just use the value and increase the -refcount. If C is not set then C will kill -the ptr_table using the function -C, -reason to keep it around is if you want to dup some of your own -variable who are outside the graph perl scans, an example of this -code is in F create. +clone it again, but rather just use the value and increase the +refcount. +If C is not set then C will kill the ptr_table +using the function S>. +A reason to keep it around is if you want to dup some of your own +variables which are outside the graph that perl scans. C - -This is a win32 thing, it is ignored on unix, it tells perls +This is a win32 thing, it is ignored on unix, it tells perl's win32host code (which is c++) to clone itself, this is needed on win32 if you want to run two threads at the same time, if you just want to do some stuff in a separate perl interpreter @@ -15288,6 +15317,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_sighandlerp = proto_perl->Isighandlerp; + PL_sighandler1p = proto_perl->Isighandler1p; + PL_sighandler3p = proto_perl->Isighandler3p; PL_runops = proto_perl->Irunops; @@ -15350,13 +15381,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_globhook = proto_perl->Iglobhook; - /* swatch cache */ - PL_last_swash_hv = NULL; /* reinits on demand */ - PL_last_swash_klen = 0; - PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = (U8*)NULL; - 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); @@ -15658,8 +15682,50 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_setlocale_buf = NULL; PL_setlocale_bufsize = 0; - /* utf8 character class swashes */ + /* Unicode inversion lists */ + + PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); + PL_Assigned_invlist = sv_dup_inc(proto_perl->IAssigned_invlist, param); + PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param); + PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param); + PL_InMultiCharFold = sv_dup_inc(proto_perl->IInMultiCharFold, param); + PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); + PL_LB_invlist = sv_dup_inc(proto_perl->ILB_invlist, param); + PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param); + PL_SCX_invlist = sv_dup_inc(proto_perl->ISCX_invlist, param); + PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); + PL_in_some_fold = sv_dup_inc(proto_perl->Iin_some_fold, param); + PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); + PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); + PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param); + PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param); + PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); + PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); + PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param); + for (i = 0; i < POSIX_CC_COUNT; i++) { + PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); + if (i != _CC_CASED && i != _CC_VERTSPACE) { + PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param); + } + } + PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA]; + PL_Posix_ptrs[_CC_VERTSPACE] = NULL; + + 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); + PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); + PL_utf8_tosimplefold = sv_dup_inc(proto_perl->Iutf8_tosimplefold, param); + PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param); + PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); + PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param); + PL_CCC_non0_non230 = sv_dup_inc(proto_perl->ICCC_non0_non230, param); + PL_Private_Use = sv_dup_inc(proto_perl->IPrivate_Use, param); + +#if 0 PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param); +#endif if (proto_perl->Ipsig_pend) { Newxz(PL_psig_pend, SIG_SIZE, int); @@ -16662,8 +16728,11 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if (agg_targ) sv = PAD_SV(agg_targ); - else if (agg_gv) + else if (agg_gv) { sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv)); + if (!sv) + break; + } else break;