/* ============================================================================
-=head1 Allocation and deallocation of SVs.
+=for apidoc_section SV Handling
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
perl_destruct() to physically free all the arenas allocated since the
start of the interpreter.
-The function visit() scans the SV arenas list, and calls a specified
+The internal function visit() scans the SV arenas list, and calls a specified
function for each SV it finds which is still live - ie which has an SvTYPE
other than all 1's, and a non-zero SvREFCNT. visit() is used by the
following functions (specified as [function that calls visit()] / [function
/*
-=head1 SV Manipulation Functions
+=for apidoc_section SV Handling
=for apidoc sv_add_arena
/*
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
U32 arena_size; /* Size of arena to allocate */
};
+#define ALIGNED_TYPE_NAME(name) name##_aligned
+#define ALIGNED_TYPE(name) \
+ typedef union { \
+ name align_me; \
+ NV nv; \
+ IV iv; \
+ } ALIGNED_TYPE_NAME(name);
+
+ALIGNED_TYPE(regexp);
+ALIGNED_TYPE(XPVGV);
+ALIGNED_TYPE(XPVLV);
+ALIGNED_TYPE(XPVAV);
+ALIGNED_TYPE(XPVHV);
+ALIGNED_TYPE(XPVCV);
+ALIGNED_TYPE(XPVFM);
+ALIGNED_TYPE(XPVIO);
+
#define HADNV FALSE
#define NONV TRUE
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- { sizeof(regexp),
+ { sizeof(ALIGNED_TYPE_NAME(regexp)),
sizeof(regexp),
0,
SVt_REGEXP, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(regexp))
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))
},
- { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
+ { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) },
- { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
+ { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) },
- { sizeof(XPVAV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVAV)),
copy_length(XPVAV, xav_alloc),
0,
SVt_PVAV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVAV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) },
- { sizeof(XPVHV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVHV)),
copy_length(XPVHV, xhv_max),
0,
SVt_PVHV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVHV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) },
- { sizeof(XPVCV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVCV)),
sizeof(XPVCV),
0,
SVt_PVCV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVCV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) },
- { sizeof(XPVFM),
+ { sizeof(ALIGNED_TYPE_NAME(XPVFM)),
sizeof(XPVFM),
0,
SVt_PVFM, TRUE, NONV, NOARENA,
- FIT_ARENA(20, sizeof(XPVFM)) },
+ FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) },
- { sizeof(XPVIO),
+ { sizeof(ALIGNED_TYPE_NAME(XPVIO)),
sizeof(XPVIO),
0,
SVt_PVIO, TRUE, NONV, HASARENA,
- FIT_ARENA(24, sizeof(XPVIO)) },
+ FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
};
#define new_body_allocated(sv_type) \
char *start;
const char *end;
const size_t good_arena_size = Perl_malloc_good_size(arena_size);
-#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
- dVAR;
-#endif
-#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
+#if defined(DEBUGGING)
static bool done_sanity_check;
- /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
- * variables like done_sanity_check. */
if (!done_sanity_check) {
unsigned int i = SVt_LAST;
/*
=for apidoc sv_setiv
+=for apidoc_item sv_setiv_mg
-Copies an integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<L</sv_setiv_mg>>.
+These copy an integer into the given SV, upgrading first if necessary.
+
+They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
+not.
=cut
*/
SvTAINT(sv);
}
-/*
-=for apidoc sv_setiv_mg
-
-Like C<sv_setiv>, but also handles 'set' magic.
-
-=cut
-*/
-
void
Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
{
/*
=for apidoc sv_setuv
+=for apidoc_item sv_setuv_mg
+
+These copy an unsigned integer into the given SV, upgrading first if necessary.
+
-Copies an unsigned integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<L</sv_setuv_mg>>.
+They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
+not.
=cut
*/
SvUV_set(sv, u);
}
-/*
-=for apidoc sv_setuv_mg
-
-Like C<sv_setuv>, but also handles 'set' magic.
-
-=cut
-*/
-
void
Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
{
/*
=for apidoc sv_setnv
+=for apidoc_item sv_setnv_mg
-Copies a double into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<L</sv_setnv_mg>>.
+These copy a double into the given SV, upgrading first if necessary.
+
+They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
+not.
=cut
*/
SvTAINT(sv);
}
-/*
-=for apidoc sv_setnv_mg
-
-Like C<sv_setnv>, but also handles 'set' magic.
-
-=cut
-*/
-
void
Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
{
/* 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)
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
}
}
- else {
+ else {
if (isGV_with_GP(sv))
return glob_2number(MUTABLE_GV(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
*/
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
#endif /* NV_PRESERVES_UV */
}
- else {
+ else {
if (isGV_with_GP(sv)) {
glob_2number(MUTABLE_GV(sv));
return 0.0;
return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
}
+/* int2str_table: lookup table containing string representations of all
+ * two digit numbers. For example, int2str_table.arr[0] is "00" and
+ * int2str_table.arr[12*2] is "12".
+ *
+ * We are going to read two bytes at a time, so we have to ensure that
+ * the array is aligned to a 2 byte boundary. That's why it was made a
+ * union with a dummy U16 member. */
+static const union {
+ char arr[200];
+ U16 dummy;
+} int2str_table = {{
+ '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
+ '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
+ '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
+ '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
+ '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
+ '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
+ '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
+ '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
+ '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
+ '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
+ '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
+ '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
+ '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
+ '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
+ '9', '8', '9', '9'
+}};
+
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
* We assume that buf is at least TYPE_CHARS(UV) long.
*/
-static char *
+PERL_STATIC_INLINE char *
S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
{
char *ptr = buf + TYPE_CHARS(UV);
char * const ebuf = ptr;
int sign;
+ U16 *word_ptr, *word_table;
PERL_ARGS_ASSERT_UIV_2BUF;
- if (is_uv)
+ /* ptr has to be properly aligned, because we will cast it to U16* */
+ assert(PTR2nat(ptr) % 2 == 0);
+ /* we are going to read/write two bytes at a time */
+ word_ptr = (U16*)ptr;
+ word_table = (U16*)int2str_table.arr;
+
+ if (UNLIKELY(is_uv))
sign = 0;
else if (iv >= 0) {
uv = iv;
sign = 0;
} else {
- uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+ /* Using 0- here to silence bogus warning from MS VC */
+ uv = (UV) (0 - (UV) iv);
sign = 1;
}
- do {
- *--ptr = '0' + (char)(uv % 10);
- } while (uv /= 10);
+
+ while (uv > 99) {
+ *--word_ptr = word_table[uv % 100];
+ uv /= 100;
+ }
+ ptr = (char*)word_ptr;
+
+ if (uv < 10)
+ *--ptr = (char)uv + '0';
+ else {
+ *--word_ptr = word_table[uv];
+ ptr = (char*)word_ptr;
+ }
+
if (sign)
- *--ptr = '-';
+ *--ptr = '-';
+
*peob = ebuf;
return ptr;
}
*/
char *
-Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
+Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
{
char *s;
return RX_WRAPPED(re);
} else {
- const char *const typestr = sv_reftype(referent, 0);
- const STRLEN typelen = strlen(typestr);
+ const char *const typestring = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestring);
UV addr = PTR2UV(referent);
const char *stashname = NULL;
STRLEN stashnamelen = 0; /* hush, gcc */
*--retval = '(';
retval -= typelen;
- memcpy(retval, typestr, typelen);
+ memcpy(retval, typestring, typelen);
if (stashname) {
*--retval = '=';
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
const U32 isUIOK = SvIsUV(sv);
- char buf[TYPE_CHARS(UV)];
+ /* The purpose of this union is to ensure that arr is aligned on
+ a 2 byte boundary, because that is what uiv_2buf() requires */
+ union {
+ char arr[TYPE_CHARS(UV)];
+ U16 dummy;
+ } buf;
char *ebuf, *ptr;
STRLEN len;
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
+ ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
len = ebuf - ptr;
/* inlined from sv_setpvn */
s = SvGROW_mutable(sv, len + 1);
=for apidoc sv_copypv
Copies a stringified representation of the source SV into the
-destination SV. Automatically performs any necessary C<mg_get> and
+destination SV. Automatically performs any necessary C<L</mg_get>> and
coercion of numeric values into strings. Guaranteed to preserve
C<UTF8> flag even from overloaded objects. Similar in nature to
C<sv_2pv[_flags]> but operates directly on an SV instead of just the
/*
=for apidoc sv_2pvbyte
-Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
-to its length. May cause the SV to be downgraded from UTF-8 as a
-side-effect.
+Returns a pointer to the byte-encoded representation of the SV, and set C<*lp>
+to its length. If the SV is marked as being encoded as UTF-8, it will
+downgrade it to a byte string as a side-effect, if possible. If the SV cannot
+be downgraded, this croaks.
+
+Processes 'get' magic.
Usually accessed via the C<SvPVbyte> 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);
}
*/
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);
}
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
-Will C<mg_get> on C<sv> if appropriate.
+Will C<L</mg_get>> on C<sv> if appropriate.
Always sets the C<SvUTF8> flag to avoid future validity checks even
if the whole string is the same in UTF-8 as not.
Returns the number of bytes in the converted string
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes are invariant in UTF-8.
If C<flags> has C<SV_GMAGIC> bit set,
-will C<mg_get> on C<sv> if appropriate, else not.
+will C<L</mg_get>> on C<sv> if appropriate, else not.
The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
}
if (SvCUR(sv) == 0) {
- if (extra) SvGROW(sv, extra);
+ if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
+ byte */
} else { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
* had a FLAG in SVs to signal if there are any variant
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)))
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.
-If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
+If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<L</mg_get>> on
C<ssv> if appropriate, else not. If the C<flags>
parameter has the C<SV_NOSTEAL> bit set then the
buffers of temps will not be stolen. C<sv_setsv>
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
*/
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:
bytes to be copied. If the C<ptr> argument is NULL the SV will become
undefined. Does not handle 'set' magic. See C<L</sv_setpvn_mg>>.
+The UTF-8 flag is not changed by this function. A terminating NUL byte is
+guaranteed.
+
=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
*/
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)
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
*/
string appended will be upgraded to UTF-8 if necessary.
If C<flags> has the C<SV_SMAGIC> bit set, will
-C<mg_set> on C<dsv> afterwards if appropriate.
+C<L</mg_set>> on C<dsv> afterwards if appropriate.
C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
+=for apidoc Amnh||SV_CATUTF8
+=for apidoc Amnh||SV_CATBYTES
+
=cut
*/
Concatenates the string from SV C<ssv> onto the end of the string in SV
C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
-If C<flags> has the C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
-appropriate. If C<flags> has the C<SV_SMAGIC> bit set, C<mg_set> will be called on
+If C<flags> has the C<SV_GMAGIC> bit set, will call C<L</mg_get>> on both SVs if
+appropriate. If C<flags> has the C<SV_SMAGIC> bit set, C<L</mg_set>> will be called on
the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
and C<sv_catsv_mg> are implemented in terms of this function.
Concatenates the C<NUL>-terminated string onto the end of the string which is
in the SV.
If the SV has the UTF-8 status set, then the bytes appended should
-be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
+be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<L</mg_set>>
on the modified SV if appropriate.
=cut
/*
=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
void
Perl_sv_clear(pTHX_ SV *const orig_sv)
{
- dVAR;
HV *stash;
U32 type;
const struct body_details *sv_type_details;
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
void
Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
{
- dVAR;
PERL_ARGS_ASSERT_SV_FREE2;
* null assign is a placeholder. */
rslast = rslen ? rsptr[rslen - 1] : '\0';
- if (rspara) { /* have to do this both before and after */
- do { /* to make sure file boundaries work right */
- if (PerlIO_eof(fp))
- return 0;
- i = PerlIO_getc(fp);
- if (i != '\n') {
- if (i == -1)
- return 0;
- PerlIO_ungetc(fp,i);
- break;
- }
- } while (i != EOF);
+ if (rspara) { /* have to do this both before and after */
+ /* to make sure file boundaries work right */
+ while (1) {
+ if (PerlIO_eof(fp))
+ return 0;
+ i = PerlIO_getc(fp);
+ if (i != '\n') {
+ if (i == -1)
+ return 0;
+ PerlIO_ungetc(fp,i);
+ break;
+ }
+ }
}
/* See if we know enough about I/O mechanism to cheat it ! */
Note we have to deal with the char in 'i' if we are not at EOF
*/
+ bpx = bp - (STDCHAR*)SvPVX_const(sv);
+ /* signals might be called here, possibly modifying sv */
i = PerlIO_getc(fp); /* get more characters */
+ bp = (STDCHAR*)SvPVX_const(sv) + bpx;
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
else
{
/*The big, slow, and stupid way. */
-#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
- STDCHAR *buf = NULL;
- Newx(buf, 8192, STDCHAR);
- assert(buf);
-#else
STDCHAR buf[8192];
-#endif
screamer2:
if (rslen) {
goto screamer2;
}
-#ifdef USE_HEAP_INSTEAD_OF_STACK
- Safefree(buf);
-#endif
}
if (rspara) { /* have to do this both before and after */
/*
=for apidoc sv_dec
+=for apidoc_item sv_dec_nomg
-Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic and operator overloading.
+These auto-decrement the value in the SV, doing string to numeric conversion
+if necessary. They both handle operator overloading.
+
+They differ only in that:
+
+C<sv_dec> handles 'get' magic; C<sv_dec_nomg> skips 'get' magic.
=cut
*/
sv_dec_nomg(sv);
}
-/*
-=for apidoc sv_dec_nomg
-
-Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles operator overloading. Skips handling 'get' magic.
-
-=cut
-*/
-
void
Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
explicit call to C<FREETMPS>, or by an implicit call at places such as
statement boundaries. See also C<L</sv_newmortal>> and C<L</sv_2mortal>>.
+=for apidoc sv_mortalcopy_flags
+
+Like C<sv_mortalcopy>, but the extra C<flags> are passed to the
+C<sv_setsv_flags>.
+
=cut
*/
#define newSVpvn_utf8(s, len, u) \
newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+=for apidoc Amnh||SVs_TEMP
+
=cut
*/
SV *
Perl_sv_2mortal(pTHX_ SV *const sv)
{
- dVAR;
if (!sv)
return sv;
if (SvIMMORTAL(sv))
(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<s> argument is NULL the new SV will be
+C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
undefined.
=cut
SV *
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
- dVAR;
SV *sv;
bool is_utf8 = FALSE;
const char *const orig_src = src;
Creates a new SV and initializes it with the string formatted like
C<sv_catpvf>.
+=for apidoc newSVpvf_nocontext
+Like C<L</newSVpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
+=for apidoc vnewSVpvf
+Like C<L</newSVpvf>> but but the arguments are an encapsulated argument list.
+
=cut
*/
Creates a new SV which is an exact duplicate of the original SV.
(Uses C<sv_setsv>.)
+=for apidoc newSVsv_nomg
+
+Like C<newSVsv> but does not process get magic.
+
=cut
*/
SV *
-Perl_newSVsv(pTHX_ SV *const old)
+Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags)
{
SV *sv;
return NULL;
}
/* Do this here, otherwise we leak the new SV if this croaks. */
- SvGETMAGIC(old);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(old);
new_SV(sv);
- /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
- with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
- sv_setsv_flags(sv, old, SV_NOSTEAL);
+ sv_setsv_flags(sv, old, flags & ~SV_GMAGIC);
return sv;
}
=for apidoc sv_pvn_force_flags
Get a sensible string out of the SV somehow.
-If C<flags> has the C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+If C<flags> has the C<SV_GMAGIC> bit set, will C<L</mg_get>> on C<sv> if
appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
implemented in terms of this function.
You normally want to use the various wrapper macros instead: see
*/
char *
-Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
+Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
{
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
=for apidoc sv_pvbyten_force
The backend for the C<SvPVbytex_force> macro. Always use the macro
-instead.
+instead. If the SV cannot be downgraded from UTF-8, this croaks.
=cut
*/
=for apidoc sv_isa
Returns a boolean indicating whether the SV is blessed into the specified
-class. This does not check for subtypes; use C<sv_derived_from> to verify
-an inheritance relationship.
+class.
+
+This does not check for subtypes or method overloading. Use C<sv_isa_sv> to
+verify an inheritance relationship in the same way as the C<isa> operator by
+respecting any C<isa()> method overloading; or C<sv_derived_from_sv> to test
+directly on the actual object type.
=cut
*/
Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
RV then it will be upgraded to one. If C<classname> 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<rv>.
+reference count is 1. The reference count 1 is owned by C<rv>. See also
+newRV_inc() and newRV_noinc() for creating a new RV properly.
=cut
*/
different from one or the reference being a readonly SV).
See C<L</SvROK_off>>.
+=for apidoc Amnh||SV_IMMEDIATE_UNREF
+
=cut
*/
void
Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
{
- char buf[TYPE_CHARS(UV)];
+ /* The purpose of this union is to ensure that arr is aligned on
+ a 2 byte boundary, because that is what uiv_2buf() requires */
+ union {
+ char arr[TYPE_CHARS(UV)];
+ U16 dummy;
+ } buf;
char *ebuf;
- char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ char * const ptr = uiv_2buf(buf.arr, iv, 0, 0, &ebuf);
PERL_ARGS_ASSERT_SV_SETPVIV;
{
PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+ GCC_DIAG_IGNORE_STMT(-Wdeprecated-declarations);
+
sv_setpviv(sv, iv);
+
+ GCC_DIAG_RESTORE_STMT;
+
SvSETMAGIC(sv);
}
Works like C<sv_catpvf> but copies the text into the SV instead of
appending it. Does not handle 'set' magic. See C<L</sv_setpvf_mg>>.
+=for apidoc sv_setpvf_nocontext
+Like C<L</sv_setpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut
*/
Like C<sv_setpvf>, but also handles 'set' magic.
+=for apidoc sv_setpvf_mg_nocontext
+Like C<L</sv_setpvf_mg>>, but does not take a thread context (C<aTHX>)
+parameter, so is used in situations where the caller doesn't already have the
+thread context.
+
=cut
*/
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sv_catpvfn>, and appends the formatted
-output to an SV. As with C<sv_catpvfn> called with a non-null C-style
+Processes its arguments like C<sprintf>, and appends the formatted
+output to an SV. As with C<sv_vcatpvfn> called with a non-null C-style
variable argument list, argument reordering is not supported.
If the appended data contains "wide" characters
(including, but not limited to, SVs with a UTF-8 PV formatted with C<%s>,
C<L</sv_catpvf_mg>>. If the original SV was UTF-8, the pattern should be
valid UTF-8; if the original SV was bytes, the pattern should be too.
+=for apidoc sv_catpvf_nocontext
+Like C<L</sv_catpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut */
void
/*
=for apidoc sv_vcatpvf
-Processes its arguments like C<sv_catpvfn> called with a non-null C-style
+Processes its arguments like C<sv_vcatpvfn> called with a non-null C-style
variable argument list, and appends the formatted output
to an SV. Does not handle 'set' magic. See C<L</sv_vcatpvf_mg>>.
Like C<sv_catpvf>, but also handles 'set' magic.
+=for apidoc sv_catpvf_mg_nocontext
+Like C<L</sv_catpvf_mg>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut
*/
return (STRLEN)iv;
}
-
-/* Returns true if c is in the range '1'..'9'
- * Written with the cast so it only needs one conditional test
- */
-#define IS_1_TO_9(c) ((U8)(c - '1') <= 8)
-
/* Read in and return a number. Updates *pattern to point to the char
* following the number. Expects the first char to 1..9.
* Croaks if the number exceeds 1/4 of the maximum value of STRLEN.
PERL_ARGS_ASSERT_EXPECT_NUMBER;
- assert(IS_1_TO_9(**pattern));
+ assert(inRANGE(**pattern, '1', '9'));
var = *(*pattern)++ - '0';
while (isDIGIT(**pattern)) {
* 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;
else {
*p++ = '0';
exponent = 0;
- zerotail = precis;
+ zerotail = has_precis ? precis : 0;
}
/* The radix is always output if precis, or if alt. */
- if (precis > 0 || alt) {
+ if ((has_precis && precis > 0) || alt) {
hexradix = TRUE;
}
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
}
return elen;
}
-
/*
=for apidoc sv_vcatpvfn
+=for apidoc_item sv_vcatpvfn_flags
-=for apidoc sv_vcatpvfn_flags
-
-Processes its arguments like C<vsprintf> and appends the formatted output
-to an SV. Uses an array of SVs if the C-style variable argument list is
-missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d>
-or C<%*2$d>) is supported only when using an array of SVs; using a C-style
+These process their arguments like C<L<vsprintf(3)>> and append the formatted output
+to an SV. They use an array of SVs if the C-style variable argument list is
+missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d> or
+C<%*2$d>) is supported only when using an array of SVs; using a C-style
C<va_list> argument list with a format string that uses argument reordering
will yield an exception.
-When running with taint checks enabled, indicates via
-C<maybe_tainted> if results are untrustworthy (often due to the use of
-locales).
-
-If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic.
+When running with taint checks enabled, they indicate via C<maybe_tainted> if
+results are untrustworthy (often due to the use of locales).
-It assumes that pat has the same utf8-ness as sv. It's the caller's
+They assume that C<pat> has the same utf8-ness as C<sv>. It's the caller's
responsibility to ensure that this is so.
-Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
+They differ in that C<sv_vcatpvfn_flags> has a C<flags> parameter in which you
+can set or clear the C<SV_GMAGIC> and/or S<SV_SMAGIC> flags, to specify which
+magic to handle or not handle; whereas plain C<sv_vcatpvfn> always specifies
+both 'get' and 'set' magic.
+
+They are usually used via one of the frontends C<sv_vcatpvf> and
+C<sv_vcatpvf_mg>.
=cut
*/
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);
[%bcdefginopsuxDFOUX] format (mandatory)
*/
- if (IS_1_TO_9(*q)) {
+ if (inRANGE(*q, '1', '9')) {
width = expect_number(&q);
if (*q == '$') {
if (args)
Perl_croak_nocontext(
- "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
++q;
efix = (Size_t)width;
width = 0;
if (*q == '*') {
STRLEN ix; /* explicit width/vector separator index */
q++;
- if (IS_1_TO_9(*q)) {
+ if (inRANGE(*q, '1', '9')) {
ix = expect_number(&q);
if (*q++ == '$') {
if (args)
Perl_croak_nocontext(
- "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
no_redundant_warning = TRUE;
} else
goto unknown;
/* 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') {
fill = TRUE;
q++;
}
- if (IS_1_TO_9(*q))
+ if (inRANGE(*q, '1', '9'))
width = expect_number(&q);
}
if (*q == '*') {
STRLEN ix; /* explicit precision index */
q++;
- if (IS_1_TO_9(*q)) {
+ if (inRANGE(*q, '1', '9')) {
ix = expect_number(&q);
if (*q++ == '$') {
if (args)
Perl_croak_nocontext(
- "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
no_redundant_warning = TRUE;
} else
goto unknown;
{
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)
+ precis = 0;
}
}
else {
*/
while (*q == '0')
q++;
- precis = IS_1_TO_9(*q) ? expect_number(&q) : 0;
+ precis = inRANGE(*q, '1', '9') ? expect_number(&q) : 0;
has_precis = TRUE;
}
}
goto string;
}
- if (vectorize && !strchr("BbDdiOouUXx", c))
+ if (vectorize && !memCHRs("BbDdiOouUXx", c))
goto unknown;
/* get next arg (individual branches do their own va_arg()
* being allowed for %c (ideally we should warn on e.g. '%hc').
* Setting a default intsize, along with a positive
* (which signals unsigned) base, causes, for C-ish use, the
- * va_arg to be interpreted as as unsigned int, when it's
+ * va_arg to be interpreted as an unsigned int, when it's
* actually signed, which will convert -ve values to high +ve
* values. Note that unlike the libc %c, values > 255 will
* convert to high unicode points rather than being truncated
case 't': iv = va_arg(*args, ptrdiff_t); break;
#endif
default: iv = va_arg(*args, int); break;
- case 'j': iv = va_arg(*args, PERL_INTMAX_T); break;
+ case 'j': iv = (IV) va_arg(*args, PERL_INTMAX_T); break;
case 'q':
#if IVSIZE >= 8
iv = va_arg(*args, Quad_t); break;
esignbuf[esignlen++] = plus;
}
else {
- uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
+ /* Using 0- here to silence bogus warning from MS VC */
+ uv = (UV) (0 - (UV) iv);
esignbuf[esignlen++] = '-';
}
}
* uptrdiff_t, so oh well */
case 't': uv = va_arg(*args, ptrdiff_t); break;
#endif
- case 'j': uv = va_arg(*args, PERL_UINTMAX_T); break;
+ case 'j': uv = (UV) va_arg(*args, PERL_UINTMAX_T); break;
default: uv = va_arg(*args, unsigned); break;
case 'q':
#if IVSIZE >= 8
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES)
{
- assert(sizeof(ebuf) >= UTF8_MAXBYTES + 1);
+ STATIC_ASSERT_STMT(sizeof(ebuf) >= UTF8_MAXBYTES + 1);
eptr = ebuf;
elen = uvchr_to_utf8((U8*)eptr, uv) - (U8*)ebuf;
is_utf8 = TRUE;
* 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 (float_need < width)
float_need = width;
+ if (float_need > INT_MAX) {
+ /* snprintf() returns an int, and we use that return value,
+ so die horribly if the expected size is too large for int
+ */
+ Perl_croak(aTHX_ "Numeric format result too large");
+ }
+
if (PL_efloatsize <= float_need) {
/* PL_efloatbuf should be at least 1 greater than
* float_need to allow a trailing \0 to be returned by
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);
}
/* =========================================================================
-=head1 Cloning an interpreter
+=for apidoc_section Embedding and Interpreter Cloning
=cut
static SV *
S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
- dVAR;
SV *dstr;
PERL_ARGS_ASSERT_SV_DUP_COMMON;
/* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
- /* XXX what do do with cur_top_env ???? */
+ /* XXX what to do with cur_top_env ???? */
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
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;
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
- dVAR;
ANY * const ss = proto_perl->Isavestack;
const I32 max = proto_perl->Isavestack_max + SS_MAXPUSH;
I32 ix = proto_perl->Isavestack_ix;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = ptr;
break;
+ case SAVEt_HINTS_HH:
+ hv = (const HV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ /* FALLTHROUGH */
case SAVEt_HINTS:
ptr = POPPTR(ss,ix);
ptr = cophh_copy((COPHH*)ptr);
TOPPTR(nss,ix) = ptr;
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
- if (i & HINT_LOCALIZE_HH) {
- hv = (const HV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
- }
break;
case SAVEt_PADSV_AND_MORTALIZE:
longval = (long)POPLONG(ss,ix);
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
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
- dVAR;
#ifdef PERL_IMPLICIT_SYS
PERL_ARGS_ASSERT_PERL_CLONE;
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_cv_has_eval = proto_perl->Icv_has_eval;
-#ifdef FCRYPT
- PL_cryptseen = proto_perl->Icryptseen;
-#endif
-
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_standard = proto_perl->Icollation_standard;
/* Recursion stopper for PerlIO_find_layer */
PL_in_load_module = proto_perl->Iin_load_module;
- /* sort() routine */
- PL_sort_RealCmp = proto_perl->Isort_RealCmp;
-
/* Not really needed/useful since the reenrant_retint is "volatile",
* but do it for consistency's sake. */
PL_reentrant_retint = proto_perl->Ireentrant_retint;
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);
if (PL_my_cxt_size) {
Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
-#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
- Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
-#endif
}
else {
PL_my_cxt_list = (void**)NULL;
-#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- PL_my_cxt_keys = (const char**)NULL;
-#endif
}
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
# endif
#endif /* !USE_LOCALE_NUMERIC */
+#ifdef HAS_MBRLEN
+ PL_mbrlen_ps = proto_perl->Imbrlen_ps;
+#endif
+#ifdef HAS_MBRTOWC
+ PL_mbrtowc_ps = proto_perl->Imbrtowc_ps;
+#endif
+#ifdef HAS_WCRTOMB
+ PL_wcrtomb_ps = proto_perl->Iwcrtomb_ps;
+#endif
+
PL_langinfo_buf = NULL;
PL_langinfo_bufsize = 0;
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_foldclosures = sv_dup_inc(proto_perl->Iutf8_foldclosures, 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);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
- while(av_tindex(param->stashes) != -1) {
+ while(av_count(param->stashes) != 0) {
HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
void
Perl_clone_params_del(CLONE_PARAMS *param)
{
- /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
- happy: */
+ PerlInterpreter *const was = PERL_GET_THX;
PerlInterpreter *const to = param->new_perl;
dTHXa(to);
- PerlInterpreter *const was = PERL_GET_THX;
PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
CLONE_PARAMS *
Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
{
- dVAR;
/* Need to play this game, as newAV() can call safesysmalloc(), and that
does a dTHX; to get the context from thread local storage.
FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
void
Perl_init_constants(pTHX)
{
+
SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL;
SvANY(&PL_sv_undef) = NULL;
}
/*
-=head1 Unicode Support
+=for apidoc_section Unicode Support
=for apidoc sv_recode_to_utf8
STATIC SV*
S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
{
- dVAR;
HE **array;
I32 i;
/*
+=apidoc_section Warning and Dieing
=for apidoc find_uninit_var
Find the name of the undefined variable (if any) that caused the operator
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
bool match, const char **desc_p)
{
- dVAR;
SV *sv;
const GV *gv;
const OP *o, *o2, *kid;
negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
FUV_SUBSCRIPT_ARRAY);
}
- else {
+ else {
/* index is an expression;
* attempt to find a match within the aggregate */
if (obase->op_type == OP_HELEM) {
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;
: varname(agg_gv, '@', agg_targ,
NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
}
- else {
+ else {
/* index is an var */
if (is_hv) {
SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
return varname(agg_gv, '@', agg_targ,
NULL, index, FUV_SUBSCRIPT_ARRAY);
}
+ /* look for an element not found */
+ if (!SvMAGICAL(sv)) {
+ SV *index_sv = NULL;
+ if (index_targ) {
+ index_sv = PL_curpad[index_targ];
+ }
+ else if (index_gv) {
+ index_sv = GvSV(index_gv);
+ }
+ if (index_sv && !SvMAGICAL(index_sv) && !SvROK(index_sv)) {
+ if (is_hv) {
+ HE *he = hv_fetch_ent(MUTABLE_HV(sv), index_sv, 0, 0);
+ if (!he) {
+ return varname(agg_gv, '%', agg_targ,
+ index_sv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ }
+ else {
+ SSize_t index = SvIV(index_sv);
+ SV * const * const svp =
+ av_fetch(MUTABLE_AV(sv), index, FALSE);
+ if (!svp) {
+ return varname(agg_gv, '@', agg_targ,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ }
+ }
+ }
if (match)
break;
return varname(agg_gv,
https://perl5.git.perl.org / perl5.git / blobdiff