/* sv.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * 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
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
}
}
+#ifdef PERL_MEM_LOG
+# define MEM_LOG_NEW_SV(sv, file, line, func) \
+ Perl_mem_log_new_sv(sv, file, line, func)
+# define MEM_LOG_DEL_SV(sv, file, line, func) \
+ Perl_mem_log_del_sv(sv, file, line, func)
+#else
+# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
+# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
+#endif
+
#ifdef DEBUG_LEAKING_SCALARS
# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
+# define DEBUG_SV_SERIAL(sv) \
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
+ PTR2UV(sv), (long)(sv)->sv_debug_serial))
#else
# define FREE_SV_DEBUG_FILE(sv)
+# define DEBUG_SV_SERIAL(sv) NOOP
#endif
#ifdef PERL_POISON
# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
+# 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)
PoisonNew(&SvREFCNT(sv), 1, U32)
#else
# define SvARENA_CHAIN(sv) SvANY(sv)
+# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
# define POSION_SV_HEAD(sv)
#endif
+/* Mark an SV head as unused, and add to free list.
+ *
+ * If SVf_BREAK is set, skip adding it to the free list, as this SV had
+ * its refcount artificially decremented during global destruction, so
+ * there may be dangling pointers to it. The last thing we want in that
+ * case is for it to be reused. */
+
#define plant_SV(p) \
STMT_START { \
+ const U32 old_flags = SvFLAGS(p); \
+ MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
+ DEBUG_SV_SERIAL(p); \
FREE_SV_DEBUG_FILE(p); \
POSION_SV_HEAD(p); \
- SvARENA_CHAIN(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
- PL_sv_root = (p); \
+ if (!(old_flags & SVf_BREAK)) { \
+ SvARENA_CHAIN_SET(p, PL_sv_root); \
+ PL_sv_root = (p); \
+ } \
--PL_sv_count; \
} STMT_END
#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
#ifdef DEBUG_LEAKING_SCALARS
/* provide a real function for a debugger to play with */
STATIC SV*
-S_new_SV(pTHX)
+S_new_SV(pTHX_ const char *file, int line, const char *func)
{
SV* sv;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
- sv->sv_debug_line = (U16) (PL_parser
- ? PL_parser->copline == NOLINE
- ? PL_curcop
+ sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
+ ? PL_parser->copline
+ : PL_curcop
? CopLINE(PL_curcop)
: 0
- : PL_parser->copline
- : 0);
+ );
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
-
+
+ sv->sv_debug_serial = PL_sv_serial++;
+
+ MEM_LOG_NEW_SV(sv, file, line, func);
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
+ PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
+
return sv;
}
-# define new_SV(p) (p)=S_new_SV(aTHX)
+# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
#else
# define new_SV(p) \
SvANY(p) = 0; \
SvREFCNT(p) = 1; \
SvFLAGS(p) = 0; \
+ MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
} STMT_END
#endif
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) {
Perl_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;
svend = &sva[SvREFCNT(sva) - 1];
sv = sva + 1;
while (sv < svend) {
- SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
+ SvARENA_CHAIN_SET(sv, (sv + 1));
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
- SvARENA_CHAIN(sv) = 0;
+ SvARENA_CHAIN_SET(sv, 0);
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
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 == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
+ /* don't clean pid table and strtab */
+ return;
+ }
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
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,
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
-#ifndef MYMALLOC
+#ifndef Perl_safesysmalloc_size
newlen = PERL_STRLEN_ROUNDUP(newlen);
#endif
if (SvLEN(sv) && s) {
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
STRLEN len;
char *retval;
char *buffer;
- const SV *const referent = (SV*)SvRV(sv);
+ const SV *const referent = SvRV(sv);
if (!referent) {
len = 7;
const U8 ch = *t++;
/* Check for hi bit */
if (!NATIVE_IS_INVARIANT(ch)) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ 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 - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ SvCUR_set(sv, len);
+ SvLEN_set(sv, len + 1); /* No longer know the real size. */
break;
}
}
}
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
- Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
gv_name_set((GV *)dstr, name, len, GV_ADD);
SvFAKE_on(dstr); /* can coerce to non-glob */
}
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) &&
(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)
- && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
+ if (CvCONST(cv) && CvCONST((const CV *)sref)
+ && cv_const_sv(cv)
+ == cv_const_sv((const CV *)sref)) {
NOOP;
/* They are 2 constant subroutines generated from
the same constant. This probably means that
}
else if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
- && (!CvCONST((CV*)sref)
+ && (!CvCONST((const CV *)sref)
|| sv_cmp(cv_const_sv(cv),
- cv_const_sv((CV*)sref))))) {
+ cv_const_sv((const CV *)
+ sref))))) {
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
(const char *)
(CvCONST(cv)
{
/* need to nuke the magic */
mg_free(dstr);
- SvRMAGICAL_off(dstr);
}
/* There's a lot of redundancy below but we're going for speed here */
Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
if (isGV_with_GP(dstr) && dtype == SVt_PVGV
- && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
}
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);
GvGP(dstr) = gp_ref(GvGP(gv));
#ifdef DEBUGGING
const U8 *real_start;
#endif
+ STRLEN max_delta;
PERL_ARGS_ASSERT_SV_CHOP;
/* Nothing to do. */
return;
}
- assert(ptr > SvPVX_const(sv));
+ /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
+ nothing uses the value of ptr any more. */
+ max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
+ if (ptr <= SvPVX_const(sv))
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
+ ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
SV_CHECK_THINKFIRST(sv);
+ if (delta > max_delta)
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
+ SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
+ SvPVX_const(sv) + max_delta);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_symtab ||
(SvTYPE(obj) == SVt_PVGV &&
- (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
- GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
- GvFORM(obj) == (CV*)sv)))
+ (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
+ || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
+ || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
{
mg->mg_obj = obj;
}
*/
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;
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);
}
* back-reference to sv onto the array associated with the backref magic.
*/
+/* A discussion about the backreferences array and its refcount:
+ *
+ * The AV holding the backreferences is pointed to either as the mg_obj of
+ * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
+ * structure, from the xhv_backreferences field. (A HV without hv_aux will
+ * have the standard magic instead.) The array is created with a refcount
+ * of 2. This means that if during global destruction the array gets
+ * picked on first to have its refcount decremented by the random zapper,
+ * it won't actually be freed, meaning it's still theere for when its
+ * parent gets freed.
+ * When the parent SV is freed, in the case of magic, the magic is freed,
+ * Perl_magic_killbackrefs is called which decrements one refcount, then
+ * mg_obj is freed which kills the second count.
+ * In the vase of a HV being freed, one ref is removed by
+ * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
+ * calls.
+ */
+
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
PERL_ARGS_ASSERT_SV_ADD_BACKREF;
if (SvTYPE(tsv) == SVt_PVHV) {
- AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+ AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
av = *avp;
if (!av) {
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
} else {
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc_simple_void(av);
+ SvREFCNT_inc_simple_void(av); /* see discussion above */
}
*avp = av;
}
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);
- /* av now has a refcnt of 2, which avoids it getting freed
- * before us during global cleanup. The extra ref is removed
- * by magic_killbackrefs() when tsv is being freed */
+ sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
+ /* av now has a refcnt of 2; see discussion above */
}
}
if (AvFILLp(av) >= AvMAX(av)) {
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+ av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
/* We mustn't attempt to "fix up" the hash here by moving the
backreference array back to the hv_aux structure, as that is stored
in the main HvARRAY(), and hfreentries assumes that no-one
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) {
- if (PL_in_clean_all)
- return;
+
+ if (!av)
Perl_croak(aTHX_ "panic: del_backref");
- }
- if (SvIS_FREED(av))
- return;
+ assert(!SvIS_FREED(av));
svp = AvARRAY(av);
/* We shouldn't be in here more than once, but for paranoia reasons lets
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
PERL_UNUSED_ARG(sv);
- /* Not sure why the av can get freed ahead of its sv, but somehow it does
- in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
- if (svp && !SvIS_FREED(av)) {
+ assert(!svp || !SvIS_FREED(av));
+ if (svp) {
SV *const *const last = svp + AvFILLp(av);
while (svp <= last) {
SvTYPE(referrer) == SVt_PVLV) {
/* You lookin' at me? */
assert(GvSTASH(referrer));
- assert(GvSTASH(referrer) == (HV*)sv);
+ assert(GvSTASH(referrer) == (const HV *)sv);
GvSTASH(referrer) = 0;
} else {
Perl_croak(aTHX_
=for apidoc sv_insert
Inserts a string at the specified offset/length within the SV. Similar to
-the Perl substr() function.
+the Perl substr() function. Handles get magic.
+
+=for apidoc sv_insert_flags
+
+Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
=cut
*/
void
-Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
- const char *const little, const STRLEN littlelen)
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
dVAR;
register char *big;
register I32 i;
STRLEN curlen;
- PERL_ARGS_ASSERT_SV_INSERT;
+ PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
- SvPV_force(bigstr, curlen);
+ SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
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:
- Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
- hv_undef((HV*)sv);
+ if (PL_last_swash_hv == (const HV *)sv) {
+ PL_last_swash_hv = NULL;
+ }
+ Perl_hv_kill_backrefs(aTHX_ MUTABLE_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 */
/* 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
boffset = real_boffset;
}
- S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
return boffset;
}
}
*offsetp = len;
- S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
}
/*
I32 bytesread;
char *buffer;
U32 recsize;
+#ifdef VMS
+ int fd;
+#endif
/* Grab the size of the record we're getting */
recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
/* doing, but we've got no other real choice - except avoid stdio
as implementation - perhaps write a :vms layer ?
*/
- bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+ fd = PerlIO_fileno(fp);
+ if (fd == -1) { /* in-memory file from PerlIO::Scalar */
+ bytesread = PerlIO_read(fp, buffer, recsize);
+ }
+ else {
+ bytesread = PerlLIO_read(fd, buffer, recsize);
+ }
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
if (bytesread < 0)
bytesread = 0;
- SvCUR_set(sv, bytesread += append);
+ SvCUR_set(sv, bytesread + append);
buffer[bytesread] = '\0';
goto return_string_or_null;
}
*/
SV *
-Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags)
+Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_sv_2mortal(pTHX_ register SV *sv)
+Perl_sv_2mortal(pTHX_ register SV *const sv)
{
dVAR;
if (!sv)
*/
SV *
-Perl_newSVpv(pTHX_ const char *s, STRLEN len)
+Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
+Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVhek(pTHX_ const HEK *hek)
+Perl_newSVhek(pTHX_ const HEK *const hek)
{
dVAR;
if (!hek) {
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
+ /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
+ changes here, update it there too. */
sv_upgrade(sv, SVt_PV);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
*/
SV *
-Perl_newSVpvf_nocontext(const char* pat, ...)
+Perl_newSVpvf_nocontext(const char *const pat, ...)
{
dTHX;
register SV *sv;
*/
SV *
-Perl_newSVpvf(pTHX_ const char* pat, ...)
+Perl_newSVpvf(pTHX_ const char *const pat, ...)
{
register SV *sv;
va_list args;
/* backend for newSVpvf() and newSVpvf_nocontext() */
SV *
-Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
+Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVnv(pTHX_ NV n)
+Perl_newSVnv(pTHX_ const NV n)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSViv(pTHX_ IV i)
+Perl_newSViv(pTHX_ const IV i)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVuv(pTHX_ UV u)
+Perl_newSVuv(pTHX_ const UV u)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newRV_noinc(pTHX_ SV *tmpRef)
+Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
dVAR;
register SV *sv = newSV_type(SVt_IV);
*/
SV *
-Perl_newRV(pTHX_ SV *sv)
+Perl_newRV(pTHX_ SV *const sv)
{
dVAR;
*/
SV *
-Perl_newSVsv(pTHX_ register SV *old)
+Perl_newSVsv(pTHX_ register SV *const old)
{
dVAR;
register SV *sv;
*/
void
-Perl_sv_reset(pTHX_ register const char *s, HV *stash)
+Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
{
dVAR;
char todo[PERL_UCHAR_MAX+1];
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;
*/
IO*
-Perl_sv_2io(pTHX_ SV *sv)
+Perl_sv_2io(pTHX_ SV *const sv)
{
IO* io;
GV* gv;
switch (SvTYPE(sv)) {
case SVt_PVIO:
- io = (IO*)sv;
+ io = MUTABLE_IO(sv);
break;
case SVt_PVGV:
- gv = (GV*)sv;
- io = GvIO(gv);
- if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
- break;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ io = GvIO(gv);
+ if (!io)
+ Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ break;
+ }
+ /* FALL THROUGH */
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
*/
CV *
-Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
+Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
{
dVAR;
GV *gv = NULL;
case SVt_PVCV:
*st = CvSTASH(sv);
*gvp = NULL;
- return (CV*)sv;
+ return MUTABLE_CV(sv);
case SVt_PVHV:
case SVt_PVAV:
*st = NULL;
*gvp = NULL;
return NULL;
case SVt_PVGV:
- gv = (GV*)sv;
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ *gvp = gv;
+ *st = GvESTASH(gv);
+ goto fix_gv;
+ }
+ /* FALL THROUGH */
default:
- SvGETMAGIC(sv);
if (SvROK(sv)) {
SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SvGETMAGIC(sv);
tryAMAGICunDEREF(to_cv);
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(sv))
+ else if(isGV_with_GP(sv))
gv = (GV*)sv;
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
- else if (isGV(sv))
+ else if (isGV_with_GP(sv)) {
+ SvGETMAGIC(sv);
gv = (GV*)sv;
+ }
else
- gv = gv_fetchsv(sv, lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
*gvp = gv;
if (!gv) {
*st = NULL;
return NULL;
}
/* Some flags to gv_fetchsv mean don't really create the GV */
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
*st = NULL;
return NULL;
}
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(sv));
+ SVfARG(SvOK(sv) ? sv : &PL_sv_no));
}
return GvCVu(gv);
}
*/
I32
-Perl_sv_true(pTHX_ register SV *sv)
+Perl_sv_true(pTHX_ register SV *const sv)
{
if (!sv)
return 0;
*/
char *
-Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
*/
char *
-Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
*/
char *
-Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
*/
const char *
-Perl_sv_reftype(pTHX_ const SV *sv, int ob)
+Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
{
PERL_ARGS_ASSERT_SV_REFTYPE;
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
- case SVt_PVGV: return "GLOB";
+ case SVt_PVGV: return (char *) (isGV_with_GP(sv)
+ ? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
- sv = (SV*)SvRV(sv);
+ sv = SvRV(sv);
if (!SvOBJECT(sv))
return 0;
return 1;
*/
int
-Perl_sv_isa(pTHX_ SV *sv, const char *name)
+Perl_sv_isa(pTHX_ SV *sv, const char *const name)
{
const char *hvname;
SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
- sv = (SV*)SvRV(sv);
+ sv = SvRV(sv);
if (!SvOBJECT(sv))
return 0;
hvname = HvNAME_get(SvSTASH(sv));
*/
SV*
-Perl_newSVrv(pTHX_ SV *rv, const char *classname)
+Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
{
dVAR;
SV *sv;
*/
SV*
-Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
+Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
{
dVAR;
*/
SV*
-Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
+Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
{
PERL_ARGS_ASSERT_SV_SETREF_IV;
*/
SV*
-Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
{
PERL_ARGS_ASSERT_SV_SETREF_UV;
*/
SV*
-Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
+Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
{
PERL_ARGS_ASSERT_SV_SETREF_NV;
*/
SV*
-Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
+Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
+ const char *const pv, const STRLEN n)
{
PERL_ARGS_ASSERT_SV_SETREF_PVN;
*/
SV*
-Perl_sv_bless(pTHX_ SV *sv, HV *stash)
+Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
{
dVAR;
SV *tmpRef;
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
+ SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
*/
STATIC void
-S_sv_unglob(pTHX_ SV *sv)
+S_sv_unglob(pTHX_ SV *const sv)
{
dVAR;
void *xpvmg;
gp_free((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);
*/
void
-Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
+Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
{
SV* const target = SvRV(ref);
*/
void
-Perl_sv_untaint(pTHX_ SV *sv)
+Perl_sv_untaint(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UNTAINT;
*/
bool
-Perl_sv_tainted(pTHX_ SV *sv)
+Perl_sv_tainted(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_TAINTED;
*/
void
-Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
*/
void
-Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
{
PERL_ARGS_ASSERT_SV_SETPVIV_MG;
*/
void
-Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
*/
void
-Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
*/
void
-Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
*/
void
-Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
PERL_ARGS_ASSERT_SV_VSETPVF;
*/
void
-Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
*/
void
-Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
PERL_ARGS_ASSERT_SV_VSETPVF_MG;
*/
void
-Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
*/
void
-Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
=cut */
void
-Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
*/
void
-Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
PERL_ARGS_ASSERT_SV_VCATPVF;
*/
void
-Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
*/
void
-Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
PERL_ARGS_ASSERT_SV_VCATPVF_MG;
*/
void
-Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
+Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
PERL_ARGS_ASSERT_SV_VSETPVFN;
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
STATIC I32
-S_expect_number(pTHX_ char** pattern)
+S_expect_number(pTHX_ char **const pattern)
{
dVAR;
I32 var = 0;
}
STATIC char *
-S_F0convert(NV nv, char *endbuf, STRLEN *len)
+S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
{
const int neg = nv < 0;
UV uv;
/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
void
-Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
+Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
dVAR;
char *p;
}
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;
}
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;
*/
if (sv_derived_from(vecsv, "version")) {
char *version = savesvpv(vecsv);
- if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
+ if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"vector argument not supported with alpha versions");
goto unknown;
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((SV*)s,t)
-#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
-#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
-#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((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((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((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((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) 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) (GV*)sv_dup((const SV *)s,t)
+#define gv_dup_inc(s,t) (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)
/* clone a parser */
yy_parser *
-Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
+Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
{
yy_parser *parser;
/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
+Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
{
PerlIO *ret;
/* duplicate a directory handle */
DIR *
-Perl_dirp_dup(pTHX_ DIR *dp)
+Perl_dirp_dup(pTHX_ DIR *const dp)
{
PERL_UNUSED_CONTEXT;
if (!dp)
/* duplicate a typeglob */
GP *
-Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
+Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
{
GP *ret;
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
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);
/* map an existing pointer using a table */
STATIC PTR_TBL_ENT_t *
-S_ptr_table_find(PTR_TBL_t *tbl, const void *sv)
+S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
{
PTR_TBL_ENT_t *tblent;
const UV hash = PTR_TABLE_HASH(sv);
}
void *
-Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
+Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
/* add a new entry to a pointer-mapping table */
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
{
PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
/* double the hash bucket size of an existing ptr table */
void
-Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
const UV oldsize = tbl->tbl_max + 1;
/* remove all the entries from a ptr table */
void
-Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
if (tbl && tbl->tbl_items) {
register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
/* clear and free a ptr table */
void
-Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
{
if (!tbl) {
return;
#if defined(USE_ITHREADS)
void
-Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
+Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
{
PERL_ARGS_ASSERT_RVPV_DUP;
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
dVAR;
SV *dstr;
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));
}
}
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)) {
+ if (AvARRAY((const AV *)sstr)) {
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;
}
break;
case SVt_PVHV:
- if (HvARRAY((HV*)sstr)) {
+ if (HvARRAY((const HV *)sstr)) {
STRLEN i = 0;
const bool sharekeys = !!HvSHAREKEYS(sstr);
XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
(bool)!!HvSHAREKEYS(sstr), param) : 0;
+ /* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
- ? (AV*) SvREFCNT_inc(
- sv_dup((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
}
}
else
- HvARRAY((HV*)dstr) = NULL;
+ HvARRAY(MUTABLE_HV(dstr)) = NULL;
break;
case SVt_PVCV:
if (!(param->flags & CLONEf_COPY_STACKS)) {
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 */
const I32 max = proto_perl->Isavestack_max;
I32 ix = proto_perl->Isavestack_ix;
ANY *nss;
- SV *sv;
- GV *gv;
- AV *av;
- HV *hv;
+ const SV *sv;
+ const GV *gv;
+ const AV *av;
+ const HV *hv;
void* ptr;
int intval;
long longval;
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 */
TOPPTR(nss,ix) = pv_dup_inc(c);
break;
case SAVEt_DELETE:
- hv = (HV*)POPPTR(ss,ix);
+ hv = (const HV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
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;
if (i & HINT_LOCALIZE_HH) {
- hv = (HV*)POPPTR(ss,ix);
+ hv = (const HV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
}
break;
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:
static void
do_mark_cloneable_stash(pTHX_ SV *const sv)
{
- const HEK * const hvname = HvNAME_HEK((HV*)sv);
+ const HEK * const hvname = HvNAME_HEK((const HV *)sv);
if (hvname) {
- GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
if (cloner && GvCV(cloner)) {
dSP;
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 */
* 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);
identified by sv_dup() above.
*/
while(av_len(param->stashes) != -1) {
- HV* const stash = (HV*) av_shift(param->stashes);
+ HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
dSP;
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 so, return a mortal copy of the key. */
STATIC SV*
-S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
{
dVAR;
register HE **array;
* If so, return the index, otherwise return -1. */
STATIC I32
-S_find_array_subscript(pTHX_ AV *av, SV* val)
+S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
{
dVAR;
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
STATIC SV*
-S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
- SV* keyname, I32 aindex, int subscript_type)
+S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
+ const SV *const keyname, I32 aindex, int subscript_type)
{
SV * const name = sv_newmortal();
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));
}
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
- else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
+ /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
+ Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
+ }
return name;
}
*/
STATIC SV *
-S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
+S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
+ bool match)
{
dVAR;
SV *sv;
- AV *av;
- GV *gv;
- OP *o, *o2, *kid;
+ const GV *gv;
+ const OP *o, *o2, *kid;
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
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,
/* attempt to find a match within the aggregate */
if (hash) {
- keysv = find_hash_subscript((HV*)sv, uninit_sv);
+ keysv = find_hash_subscript((const HV*)sv, uninit_sv);
if (keysv)
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*)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);
break;
if (match) {
SV **svp;
- av = GvAV(gv);
+ AV *const av = GvAV(gv);
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;
if (SvMAGICAL(sv))
break;
if (obase->op_type == OP_HELEM) {
- HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
if (!he || HeVAL(he) != uninit_sv)
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;
}
/* index is an expression;
* attempt to find a match within the aggregate */
if (obase->op_type == OP_HELEM) {
- SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
+ SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
if (keysv)
return varname(gv, '%', o->op_targ,
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;
}
}
case OP_PRTF:
case OP_PRINT:
case OP_SAY:
+ match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
case OP_RV2SV:
- case OP_CUSTOM:
- match = 1; /* XS or custom code could trigger random warnings */
+ case OP_CUSTOM: /* XS or custom code could trigger random warnings */
+
+ /* the following ops are capable of returning PL_sv_undef even for
+ * defined arg(s) */
+
+ case OP_BACKTICK:
+ case OP_PIPE_OP:
+ case OP_FILENO:
+ case OP_BINMODE:
+ case OP_TIED:
+ case OP_GETC:
+ case OP_SYSREAD:
+ case OP_SEND:
+ case OP_IOCTL:
+ case OP_SOCKET:
+ case OP_SOCKPAIR:
+ case OP_BIND:
+ case OP_CONNECT:
+ case OP_LISTEN:
+ case OP_ACCEPT:
+ case OP_SHUTDOWN:
+ case OP_SSOCKOPT:
+ case OP_GETPEERNAME:
+ case OP_FTRREAD:
+ case OP_FTRWRITE:
+ case OP_FTREXEC:
+ case OP_FTROWNED:
+ case OP_FTEREAD:
+ case OP_FTEWRITE:
+ case OP_FTEEXEC:
+ case OP_FTEOWNED:
+ case OP_FTIS:
+ case OP_FTZERO:
+ case OP_FTSIZE:
+ case OP_FTFILE:
+ case OP_FTDIR:
+ case OP_FTLINK:
+ case OP_FTPIPE:
+ case OP_FTSOCK:
+ case OP_FTBLK:
+ case OP_FTCHR:
+ case OP_FTTTY:
+ case OP_FTSUID:
+ case OP_FTSGID:
+ case OP_FTSVTX:
+ case OP_FTTEXT:
+ case OP_FTBINARY:
+ case OP_FTMTIME:
+ case OP_FTATIME:
+ case OP_FTCTIME:
+ case OP_READLINK:
+ case OP_OPEN_DIR:
+ case OP_READDIR:
+ case OP_TELLDIR:
+ case OP_SEEKDIR:
+ case OP_REWINDDIR:
+ case OP_CLOSEDIR:
+ case OP_GMTIME:
+ case OP_ALARM:
+ case OP_SEMGET:
+ case OP_GETLOGIN:
+ case OP_UNDEF:
+ case OP_SUBSTR:
+ case OP_AEACH:
+ case OP_EACH:
+ case OP_SORT:
+ case OP_CALLER:
+ case OP_DOFILE:
+ case OP_PROTOTYPE:
+ case OP_NCMP:
+ case OP_SMARTMATCH:
+ case OP_UNPACK:
+ case OP_SYSOPEN:
+ case OP_SYSSEEK:
+ match = 1;
goto do_op;
case OP_ENTERSUB:
Need a better fix at dome point. DAPM 11/2007 */
break;
+
case OP_POS:
/* def-ness of rval pos() is independent of the def-ness of its arg */
if ( !(obase->op_flags & OPf_MOD))
https://perl5.git.perl.org / perl5.git / blobdiff