/* ============================================================================
=head1 Allocation and deallocation of SVs.
+
An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
sv, av, hv...) contains type and reference count information, and for
many types, a pointer to the body (struct xrv, xpv, xpviv...), which
/*
Here are mid-level routines that manage the allocation of bodies out
- of the various arenas. There are 5 kinds of arenas:
+ of the various arenas. There are 4 kinds of arenas:
1. SV-head arenas, which are discussed and handled above
2. regular body arenas
unused block of them is wasteful. Also, several svtypes dont have
bodies; the data fits into the sv-head itself. The arena-root
pointer thus has a few unused root-pointers (which may be hijacked
- later for arena types 4,5)
+ later for arena type 4)
3 differs from 2 as an optimization; some body types have several
unused fields in the front of the structure (which are kept in-place
are decremented to point at the unused 'ghost' memory, knowing that
the pointers are used with offsets to the real memory.
-
-=head1 SV-Body Allocation
-
-=cut
-
Allocation of SV-bodies is similar to SV-heads, differing as follows;
the allocation mechanism is used for many body types, so is somewhat
more complicated, it uses arena-sets, and has no need for still-live
if (SvTYPE(sv) < SVt_NV) {
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
sv_upgrade(sv, SVt_NV);
+ CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
DEBUG_c({
- STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
"0x%" UVxf " num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
- RESTORE_LC_NUMERIC_UNDERLYING();
+ RESTORE_LC_NUMERIC();
});
+ CLANG_DIAG_RESTORE_STMT;
+
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
and ideally should be fixed. */
return 0.0;
}
+ CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
DEBUG_c({
- STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
- RESTORE_LC_NUMERIC_UNDERLYING();
+ RESTORE_LC_NUMERIC();
});
+ CLANG_DIAG_RESTORE_STMT;
return SvNVX(sv);
}
uv = iv;
sign = 0;
} else {
- uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+ uv = -(UV)iv;
sign = 1;
}
do {
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
- local_radix = PL_numeric_underlying && PL_numeric_radix_sv;
+ local_radix = _NOT_IN_NUMERIC_STANDARD;
if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
size += SvCUR(PL_numeric_radix_sv) - 1;
s = SvGROW_mutable(sv, size);
if (dtype < SVt_PVNV)
sv_upgrade(dstr, SVt_PVNV);
break;
+
+ case SVt_INVLIST:
+ invlist_clone(sstr, dstr);
+ break;
default:
{
const char * const type = sv_reftype(sstr,0);
sv_upgrade(dstr, SVt_REGEXP);
break;
- case SVt_INVLIST:
case SVt_PVLV:
case SVt_PVGV:
case SVt_PVMG:
that pointer (e.g. ptr + 1) be used.
If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>. If
-S<C<flags
> & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
+S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
and the realloc
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>).
SvCUR_set(sv, cur);
*SvEND(sv) = '\0';
}
- if (len) {
- } else {
- unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
+ if (! len) {
+ unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
#ifdef DEBUGGING
if (DEBUG_C_TEST)
/*
=for apidoc sv_insert
-Inserts a string at the specified offset/length within the SV. Similar to
-the Perl C<substr()> function. Handles get magic.
+Inserts and/or replaces a string at the specified offset/length within the SV.
+Similar to the Perl C<substr()> function, with C<littlelen> bytes starting at
+C<little> replacing C<len> bytes of the string in C<bigstr> starting at
+C<offset>. Handles get magic.
=for apidoc sv_insert_flags
STRLEN cur1;
const char *pv2;
STRLEN cur2;
- I32 eq = 0;
- SV* svrecode = NULL;
if (!sv1) {
pv1 = "";
}
if (cur1 == cur2)
- eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
-
- SvREFCNT_dec(svrecode);
-
- return eq;
+ return (pv1 == pv2) || memEQ(pv1, pv2, cur1);
+ else
+ return 0;
}
/*
(C<\0>) and other binary data. The reference count for the SV is set to 1.
Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
are responsible for ensuring that the source buffer is at least
-C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
+C<len> bytes long. If the C<s> argument is NULL the new SV will be
undefined.
=cut
assert(!Perl_isinfnan(nv));
if (neg)
nv = -nv;
- if (nv < UV_MAX) {
+ if (nv != 0.0 && nv < UV_MAX) {
char *p = endbuf;
- nv += 0.5;
uv = (UV)nv;
- if (uv & 1 && uv == nv)
- uv--; /* Round to even */
+ if (uv != nv) {
+ nv += 0.5;
+ uv = (UV)nv;
+ if (uv & 1 && uv == nv)
+ uv--; /* Round to even */
+ }
do {
const unsigned dig = uv % 10;
*--p = '0' + dig;
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
#else
- if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ if (IN_LC(LC_NUMERIC)) {
STRLEN n;
const char* r = SvPV(PL_numeric_radix_sv, n);
Copy(r, p, n, char);
esignbuf[esignlen++] = plus;
}
else {
- uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+ uv = -(UV)iv;
esignbuf[esignlen++] = '-';
}
}
lc_numeric_set = TRUE;
}
- if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ 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
SvTAINT(sv);
- RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
- each iteration. */
+#ifdef USE_LOCALE_NUMERIC
+
+ if (lc_numeric_set) {
+ RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to
+ save/restore each iteration. */
+ }
+
+#endif
+
}
/* =========================================================================
/* FALLTHROUGH */
case CXt_LOOP_LIST:
case CXt_LOOP_LAZYIV:
- case CXt_LOOP_GIVEN:
/* code common to all 'for' CXt_LOOP_* types */
ncx->blk_loop.itersave =
sv_dup_inc(ncx->blk_loop.itersave, param);
ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
param);
break;
+ case CXt_GIVEN:
+ ncx->blk_givwhen.defsv_save =
+ sv_dup_inc(ncx->blk_givwhen.defsv_save, param);
+ break;
case CXt_BLOCK:
case CXt_NULL:
- case CXt_WHERESO:
+ case CXt_WHEN:
break;
}
}
#ifdef USE_LOCALE_NUMERIC
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_underlying = proto_perl->Inumeric_underlying;
+ PL_numeric_underlying_is_standard = proto_perl->Inumeric_underlying_is_standard;
#endif /* !USE_LOCALE_NUMERIC */
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
+ my_strlcpy(PL_locale_utf8ness, proto_perl->Ilocale_utf8ness, sizeof(PL_locale_utf8ness));
+#if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
+ PL_lc_numeric_mutex_depth = 0;
+#endif
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+#if defined(USE_POSIX_2008_LOCALE) \
+ && defined(USE_THREAD_SAFE_LOCALE) \
+ && ! defined(HAS_QUERYLOCALE)
+ for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
+ PL_curlocales[i] = savepv("."); /* An illegal value */
+ }
+#endif
#ifdef USE_LOCALE_CTYPE
/* Should we warn if uses locale? */
PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
#ifdef USE_LOCALE_NUMERIC
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+
+# if defined(HAS_POSIX_2008_LOCALE)
+ PL_underlying_numeric_obj = NULL;
+# endif
#endif /* !USE_LOCALE_NUMERIC */
PL_langinfo_buf = NULL;
PL_langinfo_bufsize = 0;
- /* Unicode inversion lists */
- 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_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param);
-
- PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
- PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+ PL_setlocale_buf = NULL;
+ PL_setlocale_bufsize = 0;
/* 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_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
- }
- PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
- PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
- PL_SCX_invlist = sv_dup_inc(proto_perl->ISCX_invlist, param);
- PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param);
- PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
- PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
- PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
- PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
- PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
- PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
- PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
- PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
- PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
- PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
- PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, 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);
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
- PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
https://perl5.git.perl.org / perl5.git / blobdiff