/* ============================================================================
-=for apidoc_section $SV
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_ARGS_ASSERT_HV_AUXALLOC;
assert(SvTYPE(hv) == SVt_PVHV);
- assert(!SvOOK(hv));
+ assert(!HvHasAUX(hv));
#ifdef PURIFY
new_body = new_NOARENAZ(&fake_hv_with_aux);
#endif
SvANY(hv) = (XPVHV *) new_body;
- SvOOK_on(hv);
+ SvFLAGS(hv) |= SVphv_HasAUX;
return HvAUX(hv);
}
assert (SvIOKp(sv));
} else {
if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ U_V(Perl_fabs(SvNVX(sv)))) {
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv))
SvIOK_on(sv);
- /* Assumption: first non-preserved integer is < IV_MAX,
- this NV is in the preserved range, therefore: */
- if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
- < (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%" NVgf " U_V is 0x%" UVxf ", IV_MAX is 0x%" UVxf "\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
- }
+ /* There had been runtime checking for
+ "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
+ that this NV is in the preserved range, but this should
+ be always true if the following assertion is true: */
+ STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
+ (UV)IV_MAX);
} else {
/* IN_UV NOT_INT
0 0 already failed to read UV.
/* if that shift count is out of range then Configure's test is
wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
UV_BITS */
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
SvNOK_on(sv); /* Definitely small enough to preserve all bits */
} else if (!(numtype & IS_NUMBER_IN_UV)) {
/* Can't use strtol etc to convert this string, so don't try.
}
/*
-=for apidoc sv_2pv_flags
+=for apidoc sv_2pv
+=for apidoc_item sv_2pv_flags
+
+These implement the various forms of the L<perlapi/C<SvPV>> macros.
+The macros are the preferred interface.
+
+These return a pointer to the string value of an SV (coercing it to a string if
+necessary), and set C<*lp> to its length in bytes.
-Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
-If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. Coerces C<sv> to a
-string if necessary. Normally invoked via the C<SvPV_flags> macro.
-C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
+The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
+C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
+
+=for apidoc Amnh||SV_GMAGIC
=cut
*/
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
- local_radix = _NOT_IN_NUMERIC_STANDARD;
+ 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);
/*
=for apidoc sv_copypv
-=for apidoc_item sv_copypv_nomg
=for apidoc_item sv_copypv_flags
+=for apidoc_item sv_copypv_nomg
These copy a stringified representation of the source SV into the
destination SV. They automatically perform coercion of numeric values into
strings. Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
-instead of just the string. Mostly they use L<perlintern/C<sv_2pv_flags>> to
+instead of just the string. Mostly they use L</C<sv_2pv_flags>> to
do the work, except when that would lose the UTF-8'ness of the PV.
The three forms differ only in whether or not they perform 'get magic' on
}
/*
-=for apidoc sv_2pvbyte
+=for apidoc sv_2pvbyte
+=for apidoc_item sv_2pvbyte_flags
-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.
+These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
+The macros are the preferred interface.
-Processes 'get' magic.
+These return 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
+be downgraded, if possible, to a byte string. If the SV cannot be downgraded,
+they croak.
-Usually accessed via the C<SvPVbyte> macro.
+The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
+C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
+
+=for apidoc Amnh||SV_GMAGIC
=cut
*/
}
/*
-=for apidoc sv_2pvutf8
+=for apidoc sv_2pvutf8
+=for apidoc_item sv_2pvutf8_flags
-Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
-to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
+These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
+The macros are the preferred interface.
-Usually accessed via the C<SvPVutf8> macro.
+These return a pointer to the UTF-8-encoded representation of the SV, and set
+C<*lp> to its length in bytes. They may cause the SV to be upgraded to UTF-8
+as a side-effect.
+
+The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
+C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
=cut
*/
/*
=for apidoc sv_utf8_upgrade
-=for apidoc_item sv_utf8_upgrade_nomg
=for apidoc_item sv_utf8_upgrade_flags
=for apidoc_item sv_utf8_upgrade_flags_grow
+=for apidoc_item sv_utf8_upgrade_nomg
These convert the PV of an SV to its UTF-8-encoded form.
The SV is forced to string form if it is not already.
C<sv_utf8_downgrade_nomg> does not.
C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
-C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not proccess 'get' magic.
+C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
=cut
*/
SV * const sref = (SV *)GvAV((const GV *)dsv);
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
- AV * const ary = newAV();
- av_push(ary, mg->mg_obj); /* takes the refcount */
+ AV * const ary = newAV_alloc_x(2);
+ av_push_simple(ary, mg->mg_obj); /* takes the refcount */
+ av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
mg->mg_obj = (SV *)ary;
+ } else {
+ av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
}
- av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
}
else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
}
: NULL;
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
- AV * const ary = newAV();
- av_push(ary, mg->mg_obj); /* takes the refcount */
+ AV * const ary = newAV_alloc_xz(4);
+ av_push_simple(ary, mg->mg_obj); /* takes the refcount */
mg->mg_obj = (SV *)ary;
}
if (omg) {
}
if (sflags & SVp_NOK) {
SvNV_set(dsv, SvNVX(ssv));
+ if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
+ /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
+ a value set as floating point and later stringified, where
+ the value happens to be one of the few that we know aren't
+ affected by the numeric locale, hence we can cache the
+ stringification. Currently that's +Inf, -Inf and NaN, but
+ conceivably we might extend this to -9 .. +9 (excluding -0).
+ So mark destination the same: */
+ SvFLAGS(dsv) &= ~SVf_POK;
+ }
}
if (sflags & SVp_IOK) {
SvIV_set(dsv, SvIVX(ssv));
SvOK_off(sv);
}
+/*
+=for apidoc sv_set_true
+
+Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
+efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !0;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_true(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SV_SET_TRUE;
+ sv_setsv(sv, &PL_sv_yes);
+}
+
+/*
+=for apidoc sv_set_false
+
+Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
+efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !1;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_false(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SV_SET_FALSE;
+ sv_setsv(sv, &PL_sv_no);
+}
+
+/*
+=for apidoc sv_set_bool
+
+Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
+may be made more efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !!$expr;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
+{
+ PERL_ARGS_ASSERT_SV_SET_BOOL;
+ sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
+}
+
+
void
Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
{
}
/*
-=for apidoc sv_setpvn
-=for apidoc_item sv_setpvn_fresh
-=for apidoc_item sv_setpvn_mg
+=for apidoc sv_setpv
+=for apidoc_item sv_setpv_mg
+=for apidoc_item sv_setpvn
+=for apidoc_item sv_setpvn_fresh
+=for apidoc_item sv_setpvn_mg
+=for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
+=for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
-These copy a string (possibly containing embedded C<NUL> characters) into an
-SV. The C<len> parameter indicates the number of bytes to be copied. If the
-C<ptr> argument is NULL the SV will become
+These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
+
+In the C<pvs> forms, the string must be a C literal string, enclosed in double
+quotes.
+
+In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
+C<len> indicates the number of bytes to be copied, potentially including
+embedded C<NUL> characters.
+
+In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string. That is,
+it points to the first byte of the string, and the copy proceeds up through the
+first enountered C<NUL> byte.
+
+In the forms that take a C<ptr> argument, if it is NULL, the SV will become
undefined.
The UTF-8 flag is not changed by these functions. A terminating NUL byte is
-guaranteed.
+guaranteed in the result.
-They differ only in that:
-
-C<sv_setpvn> does not handle 'set' magic; C<sv_setpvn_mg> does.
+The C<_mg> forms handle 'set' magic; the other forms skip all magic.
C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
}
}
-/*
-=for apidoc sv_setpv
-=for apidoc_item sv_setpv_mg
-
-These copy a string into an SV. The string must be terminated with a C<NUL>
-character, and not contain embeded C<NUL>'s.
-
-They differ only in that:
-
-C<sv_setpv> does not handle 'set' magic; C<sv_setpv_mg> does.
-
-=cut
-*/
-
void
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on(sv);
return;
- } else if (flags & HVhek_UNSHARED) {
+ } else if (flags & HVhek_NOTSHARED) {
sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on(sv);
/*
-=for apidoc sv_usepvn_flags
+=for apidoc sv_usepvn
+=for apidoc_item sv_usepvn_flags
+=for apidoc_item sv_usepvn_mg
-Tells an SV to use C<ptr> to find its string value. Normally the
-string is stored inside the SV, but sv_usepvn allows the SV to use an
-outside string. C<ptr> should point to memory that was allocated
-by L<C<Newx>|perlclib/Memory Management and String Handling>. It must be
+These tell an SV to use C<ptr> for its string value. Normally SVs have
+their string stored inside the SV, but these tell the SV to use an
+external string instead.
+
+C<ptr> should point to memory that was allocated
+by L</C<Newx>>. It must be
the start of a C<Newx>-ed block of memory, and not a pointer to the
middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
and not be from a non-C<Newx> memory allocator like C<malloc>. The
string length, C<len>, must be supplied. By default this function
-will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
-so that pointer should not be freed or used by the programmer after
-giving it to C<sv_usepvn>, and neither should any pointers from "behind"
-that pointer (e.g. ptr + 1) be used.
+will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
+so that the pointer should not be freed or used by the programmer after giving
+it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
+(I<e.g.>, S<C<ptr> + 1>) be used.
+
+In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
+C<SvSETMAGIC> is called before returning.
+And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
+C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
+least 1 byte longer than C<len>, and already meets the requirements for storing
+in C<SvPVX>).
-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>,
-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>).
+C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
+magic is skipped.
+
+C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
+so 'set' magic is performed.
=for apidoc Amnh||SV_SMAGIC
=for apidoc Amnh||SV_HAS_TRAILING_NUL
}
}
- /* Force pos to be stored as characters, not bytes. */
- if (SvMAGICAL(sv) && DO_UTF8(sv)
- && (mg = mg_find(sv, PERL_MAGIC_regex_global))
- && mg->mg_len != -1
- && mg->mg_flags & MGf_BYTES) {
- mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
- SV_CONST_RETURN);
- mg->mg_flags &= ~MGf_BYTES;
- }
-
/* Rest of work is done else where */
mg = sv_magicext(sv,obj,how,vtable,name,namlen);
/* find slot to store array or singleton backref */
if (SvTYPE(sv) == SVt_PVHV) {
- if (SvOOK(sv)) {
+ if (HvHasAUX(sv)) {
struct xpvhv_aux * const iter = HvAUX((HV *)sv);
backrefs = (SV *)iter->xhv_backreferences;
}
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (SvTYPE(tsv) == SVt_PVHV) {
- if (SvOOK(tsv))
+ if (HvHasAUX(tsv))
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
U32 arena_index;
const struct body_details *sv_type_details;
- if (type == SVt_PVHV && SvOOK(sv)) {
+ if (type == SVt_PVHV && HvHasAUX(sv)) {
arena_index = HVAUX_ARENA_ROOT_IX;
sv_type_details = &fake_hv_with_aux;
}
CV* destructor = NULL;
struct mro_meta *meta;
- assert (SvOOK(stash));
+ assert (HvHasAUX(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
HvNAME(stash)) );
Safefree(mg->mg_ptr);
s = SvPV_flags_const(sv, len, flags);
- if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
+ if ((xf = mem_collxfrm_(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
if (! mg) {
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
}
/*
+=for apidoc newSVhek_mortal
+
+Creates a new mortal SV from the hash key structure. It will generate
+scalars that point to the shared string table where possible. Returns
+a new (undefined) SV if C<hek> is NULL.
+
+This is more efficient than using sv_2mortal(newSVhek( ... ))
+
+=cut
+*/
+
+SV *
+Perl_newSVhek_mortal(pTHX_ const HEK *const hek)
+{
+ SV * const sv = newSVhek(hek);
+ assert(sv);
+ assert(!SvIMMORTAL(sv));
+
+ PUSH_EXTEND_MORTAL__SV_C(sv);
+ SvTEMP_on(sv);
+ return sv;
+}
+
+/*
=for apidoc newSVhek
Creates a new SV from the hash key structure. It will generate scalars that
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
return sv;
- } else if (flags & HVhek_UNSHARED) {
+ } else if (flags & HVhek_NOTSHARED) {
/* A hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
share_hek_hek on it. */
SV *
Perl_newSVnv(pTHX_ const NV n)
{
- SV *sv;
+ SV *sv = newSV_type(SVt_NV);
+ (void)SvNOK_on(sv);
+
+ SvNV_set(sv, n);
+ SvTAINT(sv);
- new_SV(sv);
- sv_setnv(sv,n);
return sv;
}
SV *
Perl_newSViv(pTHX_ const IV i)
{
- SV *sv;
-
- new_SV(sv);
-
- /* Inlining ONLY the small relevant subset of sv_setiv here
- * for performance. Makes a significant difference. */
-
- /* We're starting from SVt_FIRST, so provided that's
- * actual 0, we don't have to unset any SV type flags
- * to promote to SVt_IV. */
- STATIC_ASSERT_STMT(SVt_FIRST == 0);
-
- SET_SVANY_FOR_BODYLESS_IV(sv);
- SvFLAGS(sv) |= SVt_IV;
+ SV *sv = newSV_type(SVt_IV);
(void)SvIOK_on(sv);
SvIV_set(sv, i);
}
/*
-=for apidoc newRV_noinc
+=for apidoc newSVbool
-Creates an RV wrapper for an SV. The reference count for the original
-SV is B<not> incremented.
+Creates a new SV boolean.
=cut
*/
SV *
-Perl_newRV_noinc(pTHX_ SV *const tmpRef)
+Perl_newSVbool(pTHX_ bool bool_val)
{
- SV *sv;
+ PERL_ARGS_ASSERT_NEWSVBOOL;
+ SV *sv = newSVsv(bool_val ? &PL_sv_yes : &PL_sv_no);
- PERL_ARGS_ASSERT_NEWRV_NOINC;
+ return sv;
+}
- new_SV(sv);
+/*
+=for apidoc newSV_true
- /* We're starting from SVt_FIRST, so provided that's
- * actual 0, we don't have to unset any SV type flags
- * to promote to SVt_IV. */
- STATIC_ASSERT_STMT(SVt_FIRST == 0);
+Creates a new SV that is a boolean true.
- SET_SVANY_FOR_BODYLESS_IV(sv);
- SvFLAGS(sv) |= SVt_IV;
+=cut
+*/
+SV *
+Perl_newSV_true(pTHX)
+{
+ PERL_ARGS_ASSERT_NEWSV_TRUE;
+ SV *sv = newSVsv(&PL_sv_yes);
+
+ return sv;
+}
- SvTEMP_off(tmpRef);
+/*
+=for apidoc newSV_false
- sv_setrv_noinc(sv, tmpRef);
+Creates a new SV that is a boolean false.
+
+=cut
+*/
+
+SV *
+Perl_newSV_false(pTHX)
+{
+ PERL_ARGS_ASSERT_NEWSV_FALSE;
+ SV *sv = newSVsv(&PL_sv_no);
return sv;
}
/*
=for apidoc newSVsv
-=for apidoc_item newSVsv_nomg
=for apidoc_item newSVsv_flags
+=for apidoc_item newSVsv_nomg
These create a new SV which is an exact duplicate of the original SV
(using C<sv_setsv>.)
if (!s) { /* reset ?? searches */
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
- if (mg) {
+ if (mg && mg->mg_len) {
const U32 count = mg->mg_len / sizeof(PMOP**);
PMOP **pmp = (PMOP**) mg->mg_ptr;
PMOP *const *const end = pmp + count;
PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
sv_pvn_force(sv,lp);
- sv_utf8_downgrade(sv,0);
+ (void)sv_utf8_downgrade(sv,0);
*lp = SvCUR(sv);
return SvPVX(sv);
}
return FALSE;
}
-#ifndef NO_MATHOMS /* Can't move these to mathoms.c because call uiv_2buf(),
- private to this file */
-
-/*
-=for apidoc sv_setpviv
-=for apidoc_item sv_setpviv_mg
-
-These copy an integer into the given SV, also updating its string value.
-
-They differ only in that C<sv_setpviv_mg> performs 'set' magic; C<sv_setpviv>
-skips any magic.
-
-=cut
-*/
-
-void
-Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
-{
- /* 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.arr, iv, 0, 0, &ebuf);
-
- PERL_ARGS_ASSERT_SV_SETPVIV;
-
- sv_setpvn(sv, ptr, ebuf - ptr);
-}
-
-void
-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);
-}
-
-#endif /* NO_MATHOMS */
-
#if defined(MULTIPLICITY)
/* pTHX_ magic can't cope with varargs, so this is a no-context
#endif
/*
-=for apidoc sv_setpvf
-=for apidoc_item sv_setpvf_nocontext
+=for apidoc sv_setpvf
=for apidoc_item sv_setpvf_mg
=for apidoc_item sv_setpvf_mg_nocontext
+=for apidoc_item sv_setpvf_nocontext
These work like C<L</sv_catpvf>> but copy the text into the SV instead of
appending it.
The differences between these are:
-C<sv_setpvf> and C<sv_setpvf_nocontext> do not handle 'set' magic;
-C<sv_setpvf_mg> and C<sv_setpvf_mg_nocontext> do.
+C<sv_setpvf_mg> and C<sv_setpvf_mg_nocontext> perform 'set' magic; C<sv_setpvf>
+and C<sv_setpvf_nocontext> skip all magic.
C<sv_setpvf_nocontext> and C<sv_setpvf_mg_nocontext> do not take a thread
context (C<aTHX>) parameter, so are used in situations where the caller
/*
=for apidoc sv_catpvf
-=for apidoc_item sv_catpvf_nocontext
=for apidoc_item sv_catpvf_mg
=for apidoc_item sv_catpvf_mg_nocontext
+=for apidoc_item sv_catpvf_nocontext
These process their arguments like C<sprintf>, and append the formatted
output to an SV. As with C<sv_vcatpvfn>, argument reordering is not supporte
Works like C<sv_vcatpvfn> but copies the text into the SV instead of
appending it.
-Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
+Usually used via one of its frontends L</C<sv_vsetpvf>> and
+L</C<sv_vsetpvf_mg>>.
=cut
*/
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>.
+They are usually used via one of the frontends L</C<sv_vcatpvf>> and
+L</C<sv_vcatpvf_mg>>.
=cut
*/
#endif
/* we never change this unless USE_LOCALE_NUMERIC */
bool in_lc_numeric = FALSE;
+ SV *tmp_sv = NULL;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
char c; /* the actual format ('d', s' etc) */
+ bool escape_it = FALSE; /* if this is a string should we quote and escape it? */
+
/* echo everything up to the next format specification */
for (q = fmtstart; q < patend && *q != '%'; ++q)
}
string:
+ if (escape_it) {
+ U32 flags = PERL_PV_PRETTY_QUOTEDPREFIX;
+ if (is_utf8)
+ flags |= PERL_PV_ESCAPE_UNI;
+
+ if (!tmp_sv) {
+ /* "blah"... where blah might be made up
+ * of characters like \x{1234} */
+ tmp_sv = newSV(1 + (PERL_QUOTEDPREFIX_LEN * 8) + 1 + 3);
+ sv_2mortal(tmp_sv);
+ }
+ pv_pretty(tmp_sv, eptr, elen, PERL_QUOTEDPREFIX_LEN,
+ NULL, NULL, flags);
+ eptr = SvPV_const(tmp_sv, elen);
+ }
if (has_precis && precis < elen)
elen = precis;
break;
case 'p':
- /* %p extensions:
+ /* BEGIN NOTE
+ *
+ * We want to extend the C level sprintf format API with
+ * custom formats for specific types (eg SV*) and behavior.
+ * However some C compilers are "sprintf aware" and will
+ * throw compile time exceptions when an illegal sprintf is
+ * encountered, so we can't just add new format letters.
+ *
+ * However it turns out the length argument to the %p format
+ * is more or less useless (the size of a pointer does not
+ * change over time) and is not really used in the C level
+ * code. Accordingly we can map our special behavior to
+ * specific "length" options to the %p format. We hide these
+ * mappings behind defines anyway, so nobody needs to know
+ * that HEKf is actually %2p. This keeps the C compiler
+ * happy while allowing us to add new formats.
+ *
+ * Note the existing logic for which number is used for what
+ * is torturous. All negative values are used for SVf, and
+ * non-negative values have arbitrary meanings with no
+ * structure to them. This may change in the future.
+ *
+ * NEVER use the raw %p values directly. Always use the define
+ * as the underlying mapping may change in the future.
+ *
+ * END NOTE
+ *
+ * %p extensions:
*
* "%...p" is normally treated like "%...x", except that the
* number to print is the SV's address (or a pointer address
* extensions. These are currently:
*
* %-p (SVf) Like %s, but gets the string from an SV*
- * arg rather than a char* arg.
+ * arg rather than a char* arg. Use C<SVfARG()>
+ * to set up the argument properly.
* (This was previously %_).
*
- * %-<num>p Ditto but like %.<num>s (i.e. num is max width)
+ * %-<num>p Ditto but like %.<num>s (i.e. num is max
+ * width), there is no escaped and quoted version
+ * of this.
+ *
+ * %1p (PVf_QUOTEDPREFIX). Like raw %s, but it is escaped
+ * and quoted.
+ *
+ * %5p (SVf_QUOTEDPREFIX) Like SVf, but length restricted,
+ * escaped and quoted with pv_pretty. Intended
+ * for error messages.
*
* %2p (HEKf) Like %s, but using the key string in a HEK
+ * %7p (HEKf_QUOTEDPREFIX) ... but escaped and quoted.
*
* %3p (HEKf256) Ditto but like %.256s
+ * %8p (HEKf256_QUOTEDPREFIX) ... but escaped and quoted
*
* %d%lu%4p (UTF8f) A utf8 string. Consumes 3 args:
* (cBOOL(utf8), len, string_buf).
* It's handled by the "case 'd'" branch
* rather than here.
+ * %d%lu%9p (UTF8f_QUOTEDPREFIX) .. but escaped and quoted.
+ *
*
- * %<num>p where num is 1 or > 4: reserved for future
+ * %<num>p where num is > 9: reserved for future
* extensions. Warns, but then is treated as a
* general %p (print hex address) format.
+ *
+ * NOTE: If you add a new magic %p value you will
+ * need to update F<t/porting/diag.t> to be aware of it
+ * on top of adding the various defines and etc. Do not
+ * forget to add it to F<pod/perlguts.pod> as well.
*/
if ( args
&& q[-2] != '*'
&& q[-2] != '$'
) {
- if (left) { /* %-p (SVf), %-NNNp */
- if (width) {
+ if (left || width == 5) { /* %-p (SVf), %-NNNp, %5p */
+ if (left && width) {
precis = width;
has_precis = TRUE;
+ } else if (width == 5) {
+ escape_it = TRUE;
}
argsv = MUTABLE_SV(va_arg(*args, void*));
eptr = SvPV_const(argsv, elen);
width = 0;
goto string;
}
- else if (width == 2 || width == 3) { /* HEKf, HEKf256 */
+ else if (width == 2 || width == 3 ||
+ width == 7 || width == 8)
+ { /* HEKf, HEKf256, HEKf_QUOTEDPREFIX, HEKf256_QUOTEDPREFIX */
HEK * const hek = va_arg(*args, HEK *);
eptr = HEK_KEY(hek);
elen = HEK_LEN(hek);
precis = 256;
has_precis = TRUE;
}
+ if (width > 5)
+ escape_it = TRUE;
+ width = 0;
+ goto string;
+ }
+ else if (width == 1) {
+ eptr = va_arg(*args,char *);
+ elen = strlen(eptr);
+ escape_it = TRUE;
width = 0;
goto string;
}
else if (width) {
+ /* note width=4 or width=9 is handled under %d */
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"internal %%<num>p might conflict with future printf extensions");
}
case 'd':
/* probably just a plain %d, but it might be the start of the
* special UTF8f format, which usually looks something like
- * "%d%lu%4p" (the lu may vary by platform)
+ * "%d%lu%4p" (the lu may vary by platform) or
+ * "%d%lu%9p" for an escaped version.
*/
assert((UTF8f)[0] == 'd');
assert((UTF8f)[1] == '%');
&& q == fmtstart + 1 /* plain %d, not %....d */
&& patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */
&& *q == '%'
- && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 3))
+ && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 5)
+ && q[sizeof(UTF8f)-3] == 'p'
+ && (q[sizeof(UTF8f)-4] == '4' ||
+ q[sizeof(UTF8f)-4] == '9'))
{
/* The argument has already gone through cBOOL, so the cast
is safe. */
+ if (q[sizeof(UTF8f)-4] == '9')
+ escape_it = TRUE;
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
/* if utf8 length is larger than 0x7ffff..., then it might
return parser;
}
+/*
+=for apidoc_section $io
+=for apidoc fp_dup
-/* duplicate a file handle */
+Duplicate a file handle, returning a pointer to the cloned object.
+
+=cut
+*/
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a directory handle */
+/*
+=for apidoc_section $io
+=for apidoc dirp_dup
+
+Duplicate a directory handle, returning a pointer to the cloned object.
+
+=cut
+*/
DIR *
Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a typeglob */
+/*
+=for apidoc_section $GV
+=for apidoc gp_dup
+
+Duplicate a typeglob, returning a pointer to the cloned object.
+
+=cut
+*/
GP *
Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a chain of magic */
+
+/*
+=for apidoc_section $magic
+=for apidoc mg_dup
+
+Duplicate a chain of magic, returning a pointer to the cloned object.
+
+=cut
+*/
MAGIC *
Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
};
-/* create a new pointer-mapping table */
+/*
+=for apidoc ptr_table_new
+
+Create a new pointer-mapping table
+
+=cut
+*/
PTR_TBL_t *
Perl_ptr_table_new(pTHX)
return NULL;
}
+/*
+=for apidoc ptr_table_fetch
+
+Look for C<sv> in the pointer-mapping table C<tbl>, returning its value, or
+NULL if not found.
+
+=cut
+*/
+
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
{
return tblent ? tblent->newval : NULL;
}
-/* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is
- * the key; 'newsv' is the value. The names "old" and "new" are specific to
- * the core's typical use of ptr_tables in thread cloning. */
+/*
+=for apidoc ptr_table_store
+
+Add a new entry to a pointer-mapping table C<tbl>.
+In hash terms, C<oldsv> is the key; Cnewsv> is the value.
+
+The names "old" and "new" are specific to the core's typical use of ptr_tables
+in thread cloning.
+
+=cut
+*/
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
}
}
-/* double the hash bucket size of an existing ptr table */
+/*
+=for apidoc ptr_table_split
+
+Double the hash bucket size of an existing ptr table
+
+=cut
+*/
void
Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
}
}
-/* clear and free a ptr table */
+/*
+=for apidoc ptr_table_free
+
+Clear and free a ptr table
+
+=cut
+*/
void
Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
break;
case SVt_PVHV:
- if (SvOOK(ssv)) {
+ if (HvHasAUX(ssv)) {
sv_type_details = &fake_hv_with_aux;
#ifdef PURIFY
new_body = new_NOARENA(sv_type_details);
? he_dup(source, FALSE, param) : 0;
++i;
}
- if (SvOOK(ssv)) {
+ if (HvHasAUX(ssv)) {
const struct xpvhv_aux * const saux = HvAUX(ssv);
struct xpvhv_aux * const daux = HvAUX(dsv);
/* This flag isn't copied. */
} else if (CvCONST(dsv)) {
CvXSUBANY(dsv).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param);
+ } else if (CvREFCOUNTED_ANYSV(dsv)) {
+ CvXSUBANY(dsv).any_sv =
+ sv_dup_inc((const SV *)CvXSUBANY(dsv).any_sv, param);
}
assert(!CvSLABBED(dsv));
if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv));
return ncxs;
}
-/* duplicate a stack info structure */
+/*
+=for apidoc si_dup
+
+Duplicate a stack info structure, returning a pointer to the cloned object.
+
+=cut
+*/
PERL_SI *
Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
return ret;
}
-/* duplicate the save stack */
+/*
+=for apidoc ss_dup
+
+Duplicate the save stack, returning a pointer to the cloned object.
+
+=cut
+*/
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
PL_savestack_max = -1;
PL_sig_pending = 0;
PL_parser = NULL;
+ PL_eval_begin_nest_depth = proto_perl->Ieval_begin_nest_depth;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
Zero(&PL_padname_undef, 1, PADNAME);
Zero(&PL_padname_const, 1, PADNAME);
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
PL_evalseq = proto_perl->Ievalseq;
- PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
PL_sighandlerp = proto_perl->Isighandlerp;
PL_collxfrm_base = proto_perl->Icollxfrm_base;
PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
PL_strxfrm_max_cp = proto_perl->Istrxfrm_max_cp;
+ PL_strxfrm_is_behaved = proto_perl->Istrxfrm_is_behaved;
+ PL_strxfrm_NUL_replacement = proto_perl->Istrxfrm_NUL_replacement;
#endif /* USE_LOCALE_COLLATE */
#ifdef 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;
+
+#ifdef USE_LOCALE_THREADS
+ assert(PL_locale_mutex_depth <= 0);
+ PL_locale_mutex_depth = 0;
#endif
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
PL_srand_called = proto_perl->Isrand_called;
Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
+ PL_srand_override = proto_perl->Isrand_override;
+ PL_srand_override_next = proto_perl->Isrand_override_next;
if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
-#if defined(USE_POSIX_2008_LOCALE) \
- && defined(USE_THREAD_SAFE_LOCALE) \
- && ! defined(HAS_QUERYLOCALE)
+#ifdef USE_PL_CURLOCALES
for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
- PL_curlocales[i] = savepv("."); /* An illegal value */
+ PL_curlocales[i] = SAVEPV(proto_perl->Icurlocales[i]);
}
#endif
#ifdef USE_LOCALE_CTYPE
+ Copy(proto_perl->Ifold_locale, PL_fold_locale, 256, U8);
/* Should we warn if uses locale? */
+ PL_ctype_name = SAVEPV(proto_perl->Ictype_name);
PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+ PL_utf8locale = proto_perl->Iutf8locale;
+ PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+ PL_in_utf8_turkic_locale = proto_perl->Iin_utf8_turkic_locale;
#endif
#ifdef USE_LOCALE_COLLATE
+ PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
#endif /* USE_LOCALE_COLLATE */
#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);
+ PL_underlying_radix_sv = sv_dup_inc(proto_perl->Iunderlying_radix_sv, param);
-# if defined(HAS_POSIX_2008_LOCALE)
+# if defined(USE_POSIX_2008_LOCALE)
PL_underlying_numeric_obj = NULL;
# endif
#endif /* !USE_LOCALE_NUMERIC */
+#if defined(USE_POSIX_2008_LOCALE)
+ PL_scratch_locale_obj = NULL;
+#endif
#ifdef HAS_MBRLEN
PL_mbrlen_ps = proto_perl->Imbrlen_ps;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
+ PL_stdize_locale_buf = NULL;
+ PL_stdize_locale_bufsize = 0;
+
/* Unicode inversion lists */
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, 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) {
+ 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_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);
If C<sv> already is UTF-8 (or if it is not C<POK>), or if C<encoding>
is not a reference, nothing is done to C<sv>. If C<encoding> is not
an C<Encode::XS> Encoding object, bad things will happen.
-(See F<cpan/Encode/encoding.pm> and L<Encode>.)
+(See L<encoding> and L<Encode>.)
The PV of C<sv> is returned.
HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) == val)
- return sv_2mortal(newSVhek(HeKEY_hek(entry)));
+ return newSVhek_mortal(HeKEY_hek(entry));
}
}
return NULL;
/*
+=for apidoc_section $warning
=for apidoc report_uninit
Print appropriate "Use of uninitialized variable" warning.
https://perl5.git.perl.org / perl5.git / blobdiff