/* 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)
{
SvPOK_on(sv); /* PV is okay, though. */
}
}
-#ifdef USING_MSVC6
-# pragma warning(pop)
-#endif
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
+=for apidoc Amnh||SV_GMAGIC
+
=cut
*/
*/
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);
}
*/
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);
}
This is not a general purpose Unicode to byte encoding interface:
use the C<Encode> extension for that.
+This function process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_nomg
+
+Like C<sv_utf8_downgrade>, but does not process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_flags
+
+Like C<sv_utf8_downgrade>, but with additional C<flags>.
+If C<flags> has C<SV_GMAGIC> bit set, processes get magic on C<sv>.
+
=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);
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)))
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
*/
will be skipped (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>).
+=for apidoc Amnh||SV_SMAGIC
+=for apidoc Amnh||SV_HAS_TRAILING_NUL
+
=cut
*/
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
*/
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
#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
*/
different from one or the reference being a readonly SV).
See C<L</SvROK_off>>.
+=for apidoc Amnh||SV_IMMEDIATE_UNREF
+
=cut
*/
{
PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+ GCC_DIAG_IGNORE_STMT(-Wdeprecated-declarations);
+
sv_setpviv(sv, iv);
+
+ GCC_DIAG_RESTORE_STMT;
+
SvSETMAGIC(sv);
}
* 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.
*/
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;
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
}
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);
/* 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') {
{
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)
* 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
&& !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;
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;
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;
}
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;
}
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);
}
/* =========================================================================
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;
C<perl_clone> 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<KEEP_PTR_TABLE> is not set then C<perl_clone> will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-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<threads.xs> create.
+clone it again, but rather just use the value and increase the
+refcount.
+If C<KEEP_PTR_TABLE> is not set then C<perl_clone> will kill the ptr_table
+using the function S<C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>>.
+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<CLONEf_CLONE_HOST> -
-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
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;
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);
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);
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;