/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
- * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
+ * and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
- * "I wonder what the Entish is for 'yes' and 'no'," he thought.
+ */
+
+/*
+ * 'I wonder what the Entish is for "yes" and "no",' he thought.
+ * --Pippin
+ *
+ * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
+ */
+
+/*
*
*
* This file contains the code that creates, manipulates and destroys
#ifdef PERL_POISON
# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
-# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = (SV *)(val)
+# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
/* Whilst I'd love to do this, it seems that things like to check on
unreferenced scalars
# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
#define uproot_SV(p) \
STMT_START { \
(p) = PL_sv_root; \
- PL_sv_root = (SV*)SvARENA_CHAIN(p); \
+ PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
++PL_sv_count; \
} STMT_END
if (DEBUG_D_TEST) {
SV* sva;
bool ok = 0;
- for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
+ for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
const SV * const sv = sva + 1;
const SV * const svend = &sva[SvREFCNT(sva)];
if (p >= sv && p < svend) {
=cut
*/
-void
-Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
+static void
+S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
{
dVAR;
- SV* const sva = (SV*)ptr;
+ SV *const sva = MUTABLE_SV(ptr);
register SV* sv;
register SV* svend;
PERL_ARGS_ASSERT_VISIT;
- for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
register const SV * const svend = &sva[SvREFCNT(sva)];
register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
do_clean_all(pTHX_ SV *const sv)
{
dVAR;
- if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
+ if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
/* don't clean pid table and strtab */
return;
}
contiguity of the fake ones with the corresponding real ones.) */
for (sva = PL_sv_arenaroot; sva; sva = svanext) {
- svanext = (SV*) SvANY(sva);
+ svanext = MUTABLE_SV(SvANY(sva));
while (svanext && SvFAKE(svanext))
- svanext = (SV*) SvANY(svanext);
+ svanext = MUTABLE_SV(SvANY(svanext));
if (!SvFAKE(sva))
Safefree(sva);
#define copy_length(type, last_member) \
STRUCT_OFFSET(type, last_member) \
- + sizeof (((type*)SvANY((SV*)0))->last_member)
+ + sizeof (((type*)SvANY((const SV *)0))->last_member)
static const struct body_details bodies_by_type[] = {
{ sizeof(HE), 0, 0, SVt_NULL,
}
else {
if (isGV_with_GP(sv))
- return glob_2number((GV *)sv);
+ return glob_2number(MUTABLE_GV(sv));
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
}
else {
if (isGV_with_GP(sv)) {
- glob_2number((GV *)sv);
+ glob_2number(MUTABLE_GV(sv));
return 0.0;
}
STRLEN len;
char *retval;
char *buffer;
- const SV *const referent = (SV*)SvRV(sv);
+ SV *const referent = SvRV(sv);
if (!referent) {
len = 7;
retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_REGEXP) {
- const REGEXP * const re = (REGEXP *)referent;
+ REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
I32 seen_evals = 0;
assert(re);
*s = '\0';
}
else if (SvNOKp(sv)) {
- const int olderrno = errno;
+ dSAVE_ERRNO;
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
/* The +20 is pure guesswork. Configure test needed. --jhi */
{
Gconvert(SvNVX(sv), NV_DIG, 0, s);
}
- errno = olderrno;
+ RESTORE_ERRNO;
#ifdef FIXNEGATIVEZERO
if (*s == '-' && s[1] == '0' && !s[2]) {
s[0] = '0';
}
else {
if (isGV_with_GP(sv))
- return glob_2pv((GV *)sv, lp);
+ return glob_2pv(MUTABLE_GV(sv), lp);
if (lp)
*lp = 0;
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.
Always sets the SvUTF8 flag to avoid future validity checks even
-if all the bytes have hibit clear.
+if the whole string is the same in UTF-8 as not.
+Returns the number of bytes in the converted string
This is not as a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
+=for apidoc sv_utf8_upgrade_nomg
+
+Like sv_utf8_upgrade, but doesn't do magic on C<sv>
+
=for apidoc sv_utf8_upgrade_flags
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
-if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
-will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+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.
+Returns the number of bytes in the converted string
+C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
This is not as a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=cut
+
+The grow version is currently not externally documented. It adds a parameter,
+extra, which is the number of unused bytes the string of 'sv' is guaranteed to
+have free after it upon return. This allows the caller to reserve extra space
+that it intends to fill, to avoid extra grows.
+
+Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
+which can be used to tell this function to not first check to see if there are
+any characters that are different in UTF-8 (variant characters) which would
+force it to allocate a new string to sv, but to assume there are. Typically
+this flag is used by a routine that has already parsed the string to find that
+there are such characters, and passes this information on so that the work
+doesn't have to be repeated.
+
+(One might think that the calling routine could pass in the position of the
+first such variant, so it wouldn't have to be found again. But that is not the
+case, because typically when the caller is likely to use this flag, it won't be
+calling this routine unless it finds something that won't fit into a byte.
+Otherwise it tries to not upgrade and just use bytes. But some things that
+do fit into a byte are variants in utf8, and the caller may not have been
+keeping track of these.)
+
+If the routine itself changes the string, it adds a trailing NUL. Such a NUL
+isn't guaranteed due to having other routines do the work in some input cases,
+or if the input is already flagged as being in utf8.
+
+The speed of this could perhaps be improved for many cases if someone wanted to
+write a fast function that counts the number of variant characters in a string,
+especially if it could return the position of the first one.
+
*/
STRLEN
-Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
{
dVAR;
- PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
+ PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
if (sv == &PL_sv_undef)
return 0;
STRLEN len = 0;
if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
(void) sv_2pv_flags(sv,&len, flags);
- if (SvUTF8(sv))
+ if (SvUTF8(sv)) {
+ if (extra) SvGROW(sv, SvCUR(sv) + extra);
return len;
+ }
} else {
(void) SvPV_force(sv,len);
}
}
if (SvUTF8(sv)) {
+ if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
}
sv_force_normal_flags(sv, 0);
}
- if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
+ if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
sv_recode_to_utf8(sv, PL_encoding);
- else { /* Assume Latin-1/EBCDIC */
+ if (extra) SvGROW(sv, SvCUR(sv) + extra);
+ return SvCUR(sv);
+ }
+
+ if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
- * had a FLAG in SVs to signal if there are any hibit
+ * had a FLAG in SVs to signal if there are any variant
* chars in the PV. Given that there isn't such a flag
- * make the loop as fast as possible. */
- const U8 * const s = (U8 *) SvPVX_const(sv);
- const U8 * const e = (U8 *) SvEND(sv);
- const U8 *t = s;
+ * make the loop as fast as possible (although there are certainly ways
+ * to speed this up, eg. through vectorization) */
+ U8 * s = (U8 *) SvPVX_const(sv);
+ U8 * e = (U8 *) SvEND(sv);
+ U8 *t = s;
+ STRLEN two_byte_count = 0;
+ if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
+
+ /* See if really will need to convert to utf8. We mustn't rely on our
+ * incoming SV being well formed and having a trailing '\0', as certain
+ * code in pp_formline can send us partially built SVs. */
+
while (t < e) {
const U8 ch = *t++;
- /* Check for hi bit */
- if (!NATIVE_IS_INVARIANT(ch)) {
- STRLEN len = SvCUR(sv);
- /* *Currently* bytes_to_utf8() adds a '\0' after every string
- it converts. This isn't documented. It's not clear if it's
- a bad thing to be doing, and should be changed to do exactly
- what the documentation says. If so, this code will have to
- be changed.
- As is, we mustn't rely on our incoming SV being well formed
- and having a trailing '\0', as certain code in pp_formline
- can send us partially built SVs. */
- U8 * const recoded = bytes_to_utf8((U8*)s, &len);
-
- SvPV_free(sv); /* No longer using what was there before. */
- SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len);
- SvLEN_set(sv, len + 1); /* No longer know the real size. */
- break;
- }
+ if (NATIVE_IS_INVARIANT(ch)) continue;
+
+ t--; /* t already incremented; re-point to first variant */
+ two_byte_count = 1;
+ goto must_be_utf8;
}
- /* Mark as UTF-8 even if no hibit - saves scanning loop */
+
+ /* utf8 conversion not needed because all are invariants. Mark as
+ * UTF-8 even if no variant - saves scanning loop */
SvUTF8_on(sv);
+ return SvCUR(sv);
+
+must_be_utf8:
+
+ /* Here, the string should be converted to utf8, either because of an
+ * input flag (two_byte_count = 0), or because a character that
+ * requires 2 bytes was found (two_byte_count = 1). t points either to
+ * the beginning of the string (if we didn't examine anything), or to
+ * the first variant. In either case, everything from s to t - 1 will
+ * occupy only 1 byte each on output.
+ *
+ * There are two main ways to convert. One is to create a new string
+ * and go through the input starting from the beginning, appending each
+ * converted value onto the new string as we go along. It's probably
+ * best to allocate enough space in the string for the worst possible
+ * case rather than possibly running out of space and having to
+ * reallocate and then copy what we've done so far. Since everything
+ * from s to t - 1 is invariant, the destination can be initialized
+ * with these using a fast memory copy
+ *
+ * The other way is to figure out exactly how big the string should be
+ * by parsing the entire input. Then you don't have to make it big
+ * enough to handle the worst possible case, and more importantly, if
+ * the string you already have is large enough, you don't have to
+ * allocate a new string, you can copy the last character in the input
+ * string to the final position(s) that will be occupied by the
+ * converted string and go backwards, stopping at t, since everything
+ * before that is invariant.
+ *
+ * There are advantages and disadvantages to each method.
+ *
+ * In the first method, we can allocate a new string, do the memory
+ * copy from the s to t - 1, and then proceed through the rest of the
+ * string byte-by-byte.
+ *
+ * In the second method, we proceed through the rest of the input
+ * string just calculating how big the converted string will be. Then
+ * there are two cases:
+ * 1) if the string has enough extra space to handle the converted
+ * value. We go backwards through the string, converting until we
+ * get to the position we are at now, and then stop. If this
+ * position is far enough along in the string, this method is
+ * faster than the other method. If the memory copy were the same
+ * speed as the byte-by-byte loop, that position would be about
+ * half-way, as at the half-way mark, parsing to the end and back
+ * is one complete string's parse, the same amount as starting
+ * over and going all the way through. Actually, it would be
+ * somewhat less than half-way, as it's faster to just count bytes
+ * than to also copy, and we don't have the overhead of allocating
+ * a new string, changing the scalar to use it, and freeing the
+ * existing one. But if the memory copy is fast, the break-even
+ * point is somewhere after half way. The counting loop could be
+ * sped up by vectorization, etc, to move the break-even point
+ * further towards the beginning.
+ * 2) if the string doesn't have enough space to handle the converted
+ * value. A new string will have to be allocated, and one might
+ * as well, given that, start from the beginning doing the first
+ * method. We've spent extra time parsing the string and in
+ * exchange all we've gotten is that we know precisely how big to
+ * make the new one. Perl is more optimized for time than space,
+ * so this case is a loser.
+ * So what I've decided to do is not use the 2nd method unless it is
+ * guaranteed that a new string won't have to be allocated, assuming
+ * the worst case. I also decided not to put any more conditions on it
+ * than this, for now. It seems likely that, since the worst case is
+ * twice as big as the unknown portion of the string (plus 1), we won't
+ * be guaranteed enough space, causing us to go to the first method,
+ * unless the string is short, or the first variant character is near
+ * the end of it. In either of these cases, it seems best to use the
+ * 2nd method. The only circumstance I can think of where this would
+ * be really slower is if the string had once had much more data in it
+ * than it does now, but there is still a substantial amount in it */
+
+ {
+ STRLEN invariant_head = t - s;
+ STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
+ if (SvLEN(sv) < size) {
+
+ /* Here, have decided to allocate a new string */
+
+ U8 *dst;
+ U8 *d;
+
+ Newx(dst, size, U8);
+
+ /* If no known invariants at the beginning of the input string,
+ * set so starts from there. Otherwise, can use memory copy to
+ * get up to where we are now, and then start from here */
+
+ if (invariant_head <= 0) {
+ d = dst;
+ } else {
+ Copy(s, dst, invariant_head, char);
+ d = dst + invariant_head;
+ }
+
+ while (t < e) {
+ const UV uv = NATIVE8_TO_UNI(*t++);
+ if (UNI_IS_INVARIANT(uv))
+ *d++ = (U8)UNI_TO_NATIVE(uv);
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
+ }
+ }
+ *d = '\0';
+ SvPV_free(sv); /* No longer using pre-existing string */
+ SvPV_set(sv, (char*)dst);
+ SvCUR_set(sv, d - dst);
+ SvLEN_set(sv, size);
+ } else {
+
+ /* Here, have decided to get the exact size of the string.
+ * Currently this happens only when we know that there is
+ * guaranteed enough space to fit the converted string, so
+ * don't have to worry about growing. If two_byte_count is 0,
+ * then t points to the first byte of the string which hasn't
+ * been examined yet. Otherwise two_byte_count is 1, and t
+ * points to the first byte in the string that will expand to
+ * two. Depending on this, start examining at t or 1 after t.
+ * */
+
+ U8 *d = t + two_byte_count;
+
+
+ /* Count up the remaining bytes that expand to two */
+
+ while (d < e) {
+ const U8 chr = *d++;
+ if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
+ }
+
+ /* The string will expand by just the number of bytes that
+ * occupy two positions. But we are one afterwards because of
+ * the increment just above. This is the place to put the
+ * trailing NUL, and to set the length before we decrement */
+
+ d += two_byte_count;
+ SvCUR_set(sv, d - s);
+ *d-- = '\0';
+
+
+ /* Having decremented d, it points to the position to put the
+ * very last byte of the expanded string. Go backwards through
+ * the string, copying and expanding as we go, stopping when we
+ * get to the part that is invariant the rest of the way down */
+
+ e--;
+ while (e >= t) {
+ const U8 ch = NATIVE8_TO_UNI(*e--);
+ if (UNI_IS_INVARIANT(ch)) {
+ *d-- = UNI_TO_NATIVE(ch);
+ } else {
+ *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
+ *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
+ }
+ }
+ }
+ }
}
+
+ /* Mark as UTF-8 even if no variant - saves scanning loop */
+ SvUTF8_on(sv);
return SvCUR(sv);
}
=for apidoc sv_utf8_downgrade
Attempts to convert the PV of an SV from characters to bytes.
-If the PV contains a character beyond byte, this conversion will fail;
+If the PV contains a character that cannot fit
+in a byte, this conversion will fail;
in this case, either returns false or, if C<fail_ok> is not
true, croaks.
sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv)) {
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
(void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
- Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
- gv_name_set((GV *)dstr, name, len, GV_ADD);
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
+ gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
SvFAKE_on(dstr); /* can coerce to non-glob */
}
#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
+ if (GvUNIQUE((const GV *)dstr)) {
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
#endif
- if(GvGP((GV*)sstr)) {
+ if(GvGP(MUTABLE_GV(sstr))) {
/* If source has method cache entry, clear it */
if(GvCVGEN(sstr)) {
SvREFCNT_dec(GvCV(sstr));
}
/* If source has a real method, then a method is
going to change */
- else if(GvCV((GV*)sstr)) {
+ else if(GvCV((const GV *)sstr)) {
mro_changes = 1;
}
}
/* If dest already had a real method, that's a change as well */
- if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
+ if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
mro_changes = 1;
}
- if(strEQ(GvNAME((GV*)dstr),"ISA"))
+ if(strEQ(GvNAME((const GV *)dstr),"ISA"))
mro_changes = 2;
- gp_free((GV*)dstr);
+ gp_free(MUTABLE_GV(dstr));
isGV_with_GP_off(dstr);
(void)SvOK_off(dstr);
isGV_with_GP_on(dstr);
PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
+ if (GvUNIQUE((const GV *)dstr)) {
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
#endif
if (intro) {
GvINTRO_off(dstr); /* one-shot flag */
GvLINE(dstr) = CopLINE(PL_curcop);
- GvEGV(dstr) = (GV*)dstr;
+ GvEGV(dstr) = MUTABLE_GV(dstr);
}
GvMULTI_on(dstr);
switch (stype) {
common:
if (intro) {
if (stype == SVt_PVCV) {
- /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
+ /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
if (GvCVGEN(dstr)) {
SvREFCNT_dec(GvCV(dstr));
GvCV(dstr) = NULL;
else
dref = *location;
if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
- CV* const cv = (CV*)*location;
+ CV* const cv = MUTABLE_CV(*location);
if (cv) {
- if (!GvCVGEN((GV*)dstr) &&
+ if (!GvCVGEN((const GV *)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
/* Redefining a sub - warning is mandatory if
it was a const and its value changed. */
- if (CvCONST(cv) && CvCONST((CV*)sref)
+ if (CvCONST(cv) && CvCONST((const CV *)sref)
&& cv_const_sv(cv)
== cv_const_sv((const CV *)sref)) {
NOOP;
}
else if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
- && (!CvCONST((CV*)sref)
+ && (!CvCONST((const CV *)sref)
|| sv_cmp(cv_const_sv(cv),
cv_const_sv((const CV *)
sref))))) {
(CvCONST(cv)
? "Constant subroutine %s::%s redefined"
: "Subroutine %s::%s redefined"),
- HvNAME_get(GvSTASH((GV*)dstr)),
- GvENAME((GV*)dstr));
+ HvNAME_get(GvSTASH((const GV *)dstr)),
+ GvENAME(MUTABLE_GV(dstr)));
}
}
if (!intro)
- cv_ckproto_len(cv, (GV*)dstr,
+ cv_ckproto_len(cv, (const GV *)dstr,
SvPOK(sref) ? SvPVX_const(sref) : NULL,
SvPOK(sref) ? SvCUR(sref) : 0);
}
}
else {
GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
- if (dstr != (SV*)gv) {
+ if (dstr != (const SV *)gv) {
if (GvGP(dstr))
- gp_free((GV*)dstr);
+ gp_free(MUTABLE_GV(dstr));
GvGP(dstr) = gp_ref(GvGP(gv));
}
}
/* FAKE globs can get coerced, so need to turn this off
temporarily if it is on. */
SvFAKE_off(sstr);
- gv_efullname3(dstr, (GV *)sstr, "*");
+ gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
SvFLAGS(sstr) |= wasfake;
}
else
}
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
/* At this point I believe that I can drop the global SV mutex. */
}
#else
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
#endif
if (SvROK(sv))
*/
if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
- obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
+ obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
{
sv_rvweaken(obj);
}
if (name) {
if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
- else if (namlen == HEf_SVKEY)
- mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
- else
+ else if (namlen == HEf_SVKEY) {
+ /* Yes, this is casting away const. This is only for the case of
+ HEf_SVKEY. I think we need to document this abberation of the
+ constness of the API, rather than making name non-const, as
+ that change propagating outwards a long way. */
+ mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
+ } else
mg->mg_ptr = (char *) name;
}
mg->mg_virtual = (MGVTBL *) vtable;
&& how != PERL_MAGIC_backref
)
{
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
if (mg->mg_len > 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec((SV*)mg->mg_ptr);
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
else if (mg->mg_type == PERL_MAGIC_utf8)
Safefree(mg->mg_ptr);
}
if (mg) {
/* Aha. They've got it stowed in magic. Bring it back. */
- av = (AV*)mg->mg_obj;
+ av = MUTABLE_AV(mg->mg_obj);
/* Stop mg_free decreasing the refernce count. */
mg->mg_obj = NULL;
/* Stop mg_free even calling the destructor, given that
const MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
if (mg)
- av = (AV*)mg->mg_obj;
+ av = MUTABLE_AV(mg->mg_obj);
else {
av = newAV();
AvREAL_off(av);
- sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
+ sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
/* av now has a refcnt of 2; see discussion above */
}
}
const MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
if (mg)
- av = (AV *)mg->mg_obj;
+ av = MUTABLE_AV(mg->mg_obj);
}
if (!av)
PUSHMARK(SP);
PUSHs(tmpref);
PUTBACK;
- call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+ call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
POPSTACK;
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
{
- io_close((IO*)sv, FALSE);
+ io_close(MUTABLE_IO(sv), FALSE);
}
if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
PerlDir_close(IoDIRP(sv));
goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
- cv_undef((CV*)sv);
+ cv_undef(MUTABLE_CV(sv));
goto freescalar;
case SVt_PVHV:
if (PL_last_swash_hv == (const HV *)sv) {
hv_undef(MUTABLE_HV(sv));
break;
case SVt_PVAV:
- if (PL_comppad == (AV*)sv) {
+ if (PL_comppad == MUTABLE_AV(sv)) {
PL_comppad = NULL;
PL_curpad = NULL;
}
- av_undef((AV*)sv);
+ av_undef(MUTABLE_AV(sv));
break;
case SVt_PVLV:
if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
SvREFCNT_dec(LvTARG(sv));
case SVt_PVGV:
if (isGV_with_GP(sv)) {
- if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
+ if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
+ && HvNAME_get(stash))
mro_method_changed_in(stash);
- gp_free((GV*)sv);
+ gp_free(MUTABLE_GV(sv));
if (GvNAME_HEK(sv))
unshare_hek(GvNAME_HEK(sv));
/* If we're in a stash, we don't own a reference to it. However it does
have a back reference to us, which needs to be cleared. */
if (!SvVALID(sv) && (stash = GvSTASH(sv)))
- sv_del_backref((SV*)stash, sv);
+ sv_del_backref(MUTABLE_SV(stash), sv);
}
/* FIXME. There are probably more unreferenced pointers to SVs in the
interpreter struct that we should check and tidy in a similar
fashion to this: */
- if ((GV*)sv == PL_last_in_gv)
+ if ((const GV *)sv == PL_last_in_gv)
PL_last_in_gv = NULL;
case SVt_PVMG:
case SVt_PVNV:
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
if (SvROK(sv)) {
IV i;
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
if (SvROK(sv)) {
IV i;
return;
if (!*s) { /* reset ?? searches */
- MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
+ MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
if (mg) {
const U32 count = mg->mg_len / sizeof(PMOP**);
PMOP **pmp = (PMOP**) mg->mg_ptr;
if (!todo[(U8)*HeKEY(entry)])
continue;
- gv = (GV*)HeVAL(entry);
+ gv = MUTABLE_GV(HeVAL(entry));
sv = GvSV(gv);
if (sv) {
if (SvTHINKFIRST(sv)) {
switch (SvTYPE(sv)) {
case SVt_PVIO:
- io = (IO*)sv;
+ io = MUTABLE_IO(sv);
break;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
io = GvIO(gv);
if (!io)
Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
case SVt_PVCV:
*st = CvSTASH(sv);
*gvp = NULL;
- return (CV*)sv;
+ return MUTABLE_CV(sv);
case SVt_PVHV:
case SVt_PVAV:
*st = NULL;
return NULL;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
*gvp = gv;
*st = GvESTASH(gv);
goto fix_gv;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
- cv = (CV*)sv;
+ cv = MUTABLE_CV(sv);
*gvp = NULL;
*st = CvSTASH(cv);
return cv;
}
else if(isGV_with_GP(sv))
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
else if (isGV_with_GP(sv)) {
SvGETMAGIC(sv);
- gv = (GV*)sv;
+ gv = MUTABLE_GV(sv);
}
else
gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
- sv = (SV*)SvRV(sv);
+ sv = SvRV(sv);
if (!SvOBJECT(sv))
return 0;
return 1;
SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
- sv = (SV*)SvRV(sv);
+ sv = SvRV(sv);
if (!SvOBJECT(sv))
return 0;
hvname = HvNAME_get(SvSTASH(sv));
if (SvIsCOW(tmpRef))
sv_force_normal_flags(tmpRef, 0);
if (SvREADONLY(tmpRef))
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
- gv_efullname3(temp, (GV *) sv, "*");
+ gv_efullname3(temp, MUTABLE_GV(sv), "*");
if (GvGP(sv)) {
- if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
+ if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
+ && HvNAME_get(stash))
mro_method_changed_in(stash);
- gp_free((GV*)sv);
+ gp_free(MUTABLE_GV(sv));
}
if (GvSTASH(sv)) {
- sv_del_backref((SV*)GvSTASH(sv), sv);
+ sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
GvSTASH(sv) = NULL;
}
GvMULTI_off(sv);
{
PERL_ARGS_ASSERT_SV_VSETPVFN;
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
}
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
- argsv = (SV*)va_arg(*args, void*);
+ argsv = MUTABLE_SV(va_arg(*args, void*));
sv_catsv(sv, argsv);
return;
}
STRLEN esignlen = 0;
const char *eptr = NULL;
+ const char *fmtstart;
STRLEN elen = 0;
SV *vecsv = NULL;
const U8 *vecstr = NULL;
if (q++ >= patend)
break;
+ fmtstart = q;
+
/*
We allow format specification elements in this order:
\d+\$ explicit format parameter index
precis = n;
has_precis = TRUE;
}
- argsv = (SV*)va_arg(*args, void*);
+ argsv = MUTABLE_SV(va_arg(*args, void*));
eptr = SvPV_const(argsv, elen);
if (DO_UTF8(argsv))
is_utf8 = TRUE;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
default: iv = va_arg(*args, int); break;
+ case 'q':
#ifdef HAS_QUAD
- case 'q': iv = va_arg(*args, Quad_t); break;
+ iv = va_arg(*args, Quad_t); break;
+#else
+ goto unknown;
#endif
}
}
case 'l': iv = (long)tiv; break;
case 'V':
default: iv = tiv; break;
+ case 'q':
#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)tiv; break;
+ iv = (Quad_t)tiv; break;
+#else
+ goto unknown;
#endif
}
}
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
default: uv = va_arg(*args, unsigned); break;
+ case 'q':
#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Uquad_t); break;
+ uv = va_arg(*args, Uquad_t); break;
+#else
+ goto unknown;
#endif
}
}
case 'l': uv = (unsigned long)tuv; break;
case 'V':
default: uv = tuv; break;
+ case 'q':
#ifdef HAS_QUAD
- case 'q': uv = (Uquad_t)tuv; break;
+ uv = (Uquad_t)tuv; break;
+#else
+ goto unknown;
#endif
}
}
default: *(va_arg(*args, int*)) = i; break;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
+ case 'q':
#ifdef HAS_QUAD
- case 'q': *(va_arg(*args, Quad_t*)) = i; break;
+ *(va_arg(*args, Quad_t*)) = i; break;
+#else
+ goto unknown;
#endif
}
}
SV * const msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
(PL_op->op_type == OP_PRTF) ? "" : "s");
- if (c) {
- if (isPRINT(c))
- Perl_sv_catpvf(aTHX_ msg,
- "\"%%%c\"", c & 0xFF);
- else
- Perl_sv_catpvf(aTHX_ msg,
- "\"%%\\%03"UVof"\"",
- (UV)c & 0xFF);
- } else
+ if (fmtstart < patend) {
+ const char * const fmtend = q < patend ? q : patend;
+ const char * f;
+ sv_catpvs(msg, "\"%");
+ for (f = fmtstart; f < fmtend; f++) {
+ if (isPRINT(*f)) {
+ sv_catpvn(msg, f, 1);
+ } else {
+ Perl_sv_catpvf(aTHX_ msg,
+ "\\%03"UVof, (UV)*f & 0xFF);
+ }
+ }
+ sv_catpvs(msg, "\"");
+ } else {
sv_catpvs(msg, "end of string");
+ }
Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
}
have = esignlen + zeros + elen;
if (have < zeros)
- Perl_croak_nocontext(PL_memory_wrap);
+ Perl_croak_nocontext("%s", PL_memory_wrap);
need = (have > width ? have : width);
gap = need - have;
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
- Perl_croak_nocontext(PL_memory_wrap);
+ Perl_croak_nocontext("%s", PL_memory_wrap);
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
If this changes, please unmerge ss_dup. */
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
-#define av_dup(s,t) (AV*)sv_dup((const SV *)s,t)
-#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((const SV *)s,t))
+#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
+#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
-#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
-#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((const SV *)s,t))
-#define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
-#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((const SV *)s,t))
-#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
-#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((const SV *)s,t))
+#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
+#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
+#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
+#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
#define SAVEPV(p) ((p) ? savepv(p) : NULL)
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
nmg->mg_flags = mg->mg_flags;
/* FIXME for plugins
if (mg->mg_type == PERL_MAGIC_qr) {
- nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
+ nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)mg->mg_obj, param));
}
else
*/
if(mg->mg_type == PERL_MAGIC_backref) {
/* The backref AV has its reference count deliberately bumped by
1. */
- nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
+ nmg->mg_obj
+ = SvREFCNT_inc(av_dup_inc((const AV *) mg->mg_obj, param));
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
}
}
else if (mg->mg_len == HEf_SVKEY)
- nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
+ nmg->mg_ptr = (char*)sv_dup_inc((const SV *)mg->mg_ptr, param);
}
if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
if (SvROK(sstr)) {
SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param));
+ ? sv_dup(SvRV_const(sstr), param)
+ : sv_dup_inc(SvRV_const(sstr), param));
}
else if (SvPVX_const(sstr)) {
}
else {
/* Some other special case - random pointer */
- SvPV_set(dstr, SvPVX(sstr));
+ SvPV_set(dstr, (char *) SvPVX_const(sstr));
}
}
}
return NULL;
}
/* look for it in the table first */
- dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
+ dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
if (dstr)
return dstr;
const HEK * const hvname = HvNAME_HEK(sstr);
if (hvname)
/** don't clone stashes if they already exist **/
- return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
+ return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
}
}
break;
case SVt_PVGV:
- if (GvUNIQUE((GV*)sstr)) {
+ if (GvUNIQUE((const GV *)sstr)) {
NOOP; /* Do sharing here, and fall through */
}
case SVt_PVIO:
if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
LvTARG(dstr) = dstr;
else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
- LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
+ LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
case SVt_PVGV:
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
break;
case SVt_PVAV:
- if (AvARRAY((AV*)sstr)) {
+ /* avoid cloning an empty array */
+ if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
SV **dst_ary, **src_ary;
- SSize_t items = AvFILLp((AV*)sstr) + 1;
+ SSize_t items = AvFILLp((const AV *)sstr) + 1;
- src_ary = AvARRAY((AV*)sstr);
- Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
+ src_ary = AvARRAY((const AV *)sstr);
+ Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
- AvARRAY((AV*)dstr) = dst_ary;
- AvALLOC((AV*)dstr) = dst_ary;
- if (AvREAL((AV*)sstr)) {
+ AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
+ AvALLOC((const AV *)dstr) = dst_ary;
+ if (AvREAL((const AV *)sstr)) {
while (items-- > 0)
*dst_ary++ = sv_dup_inc(*src_ary++, param);
}
while (items-- > 0)
*dst_ary++ = sv_dup(*src_ary++, param);
}
- items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
+ items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
*dst_ary++ = &PL_sv_undef;
}
}
else {
- AvARRAY((AV*)dstr) = NULL;
- AvALLOC((AV*)dstr) = (SV**)NULL;
+ AvARRAY(MUTABLE_AV(dstr)) = NULL;
+ AvALLOC((const AV *)dstr) = (SV**)NULL;
+ AvMAX( (const AV *)dstr) = -1;
+ AvFILLp((const AV *)dstr) = -1;
}
break;
case SVt_PVHV:
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
- ? (AV*) SvREFCNT_inc(
- sv_dup_inc((SV*)saux->xhv_backreferences, param))
+ ? MUTABLE_AV(SvREFCNT_inc(
+ sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
: 0;
daux->xhv_mro_meta = saux->xhv_mro_meta
if (CvCONST(dstr) && CvISXSUB(dstr)) {
CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
- sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
+ sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
ncx->blk_loop.oldcomppad);
} else {
ncx->blk_loop.oldcomppad
- = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
+ = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
+ param);
}
break;
case CXt_FORMAT:
const I32 max = proto_perl->Isavestack_max;
I32 ix = proto_perl->Isavestack_ix;
ANY *nss;
- SV *sv;
+ const SV *sv;
const GV *gv;
const AV *av;
const HV *hv;
TOPINT(nss,ix) = type;
switch (type) {
case SAVEt_HELEM: /* hash element */
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
/* fall through */
case SAVEt_ITEM: /* normal string */
case SAVEt_SV: /* scalar reference */
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
/* fall through */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
break;
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
case SAVEt_HV: /* hash reference */
case SAVEt_AV: /* array reference */
- sv = (SV*) POPPTR(ss,ix);
+ sv = (const SV *) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
/* fall through */
case SAVEt_COMPPAD:
case SAVEt_NSTAB:
- sv = (SV*) POPPTR(ss,ix);
+ sv = (const SV *) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_INT: /* int reference */
case SAVEt_SPTR: /* SV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_VPTR: /* random* reference */
gp = (GP*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
- gv = (GV*)POPPTR(ss,ix);
+ gv = (const GV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_FREEOP:
else
TOPPTR(nss,ix) = NULL;
break;
- case SAVEt_FREEPV:
- c = (char*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = pv_dup_inc(c);
- break;
case SAVEt_DELETE:
hv = (const HV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ /* Fall through */
+ case SAVEt_FREEPV:
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
- /* fall through */
+ break;
case SAVEt_STACK_POS: /* Position on Perl stack */
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
ix -= i;
break;
case SAVEt_AELEM: /* array element */
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
- av = (AV*)POPPTR(ss,ix);
+ av = (const AV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
case SAVEt_OP:
TOPPTR(nss,ix) = ptr;
break;
case SAVEt_HINTS:
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
ptr = POPPTR(ss,ix);
if (ptr) {
HINTS_REFCNT_LOCK;
HINTS_REFCNT_UNLOCK;
}
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);
TOPLONG(nss,ix) = longval;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_BOOL:
TOPINT(nss,ix) = i;
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
- sv = (SV*)POPPTR(ss,ix);
+ sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_RE_STATE:
PUSHMARK(SP);
mXPUSHs(newSVhek(hvname));
PUTBACK;
- call_sv((SV*)GvCV(cloner), G_SCALAR);
+ call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
SPAGAIN;
status = POPu;
PUTBACK;
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
- sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
- sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
- sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+ sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
+ sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
+ sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
/* RE engine related */
PL_regex_pad = AvARRAY(PL_regex_padav);
/* shortcuts to various I/O objects */
+ PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
PL_defgv = gv_dup(proto_perl->Idefgv, param);
* orphaned
*/
for (i = 0; i<= proto_perl->Itmps_ix; i++) {
- SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
- proto_perl->Itmps_stack[i]);
+ SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
+ proto_perl->Itmps_stack[i]));
if (nsv && !SvREFCNT(nsv)) {
EXTEND_MORTAL(1);
PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_rs = sv_dup_inc(proto_perl->Irs, param);
PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
- PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param);
PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
PTR2UV(PL_watchok));
}
+ PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PUSHMARK(SP);
mXPUSHs(newSVhek(HvNAME_HEK(stash)));
PUTBACK;
- call_sv((SV*)GvCV(cloner), G_DISCARD);
+ call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
FREETMPS;
LEAVE;
}
if (!cv || !CvPADLIST(cv))
return NULL;
- av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
+ av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
sv = *av_fetch(av, targ, FALSE);
sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
}
gv = cGVOPx_gv(cUNOPx(obase)->op_first);
if (!gv)
break;
- sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
+ sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
}
else /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
subscript_type = FUV_SUBSCRIPT_HASH;
}
else {
- index = find_array_subscript((AV*)sv, uninit_sv);
+ index = find_array_subscript((const AV *)sv, uninit_sv);
if (index >= 0)
subscript_type = FUV_SUBSCRIPT_ARRAY;
}
if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
if (match) {
SV **svp;
- AV *av = (AV*)PAD_SV(obase->op_targ);
+ AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
if (!av || SvRMAGICAL(av))
break;
svp = av_fetch(av, (I32)obase->op_private, FALSE);
gv = cGVOPx_gv(cUNOPo->op_first);
if (!gv)
break;
- sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
+ sv = o->op_type
+ == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
}
if (!sv)
break;
break;
}
else {
- SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
if (!svp || *svp != uninit_sv)
break;
}
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- const I32 index = find_array_subscript((AV*)sv, uninit_sv);
+ const I32 index
+ = find_array_subscript((const AV *)sv, uninit_sv);
if (index >= 0)
return varname(gv, '@', o->op_targ,
NULL, index, FUV_SUBSCRIPT_ARRAY);
: DEFSV))
{
sv = sv_newmortal();
- sv_setpvn(sv, "$_", 2);
+ sv_setpvs(sv, "$_");
return sv;
}
}
*/
void
-Perl_report_uninit(pTHX_ SV* uninit_sv)
+Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
dVAR;
if (PL_op) {
https://perl5.git.perl.org / perl5.git / blobdiff