/* 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 = (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
#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;
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
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
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)
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
GvMULTI_on(dstr);
return;
}
- if (isGV_with_GP(sstr)) {
- glob_assign_glob(dstr, sstr, dtype);
- return;
- }
+ glob_assign_glob(dstr, sstr, dtype);
+ return;
}
if (dtype >= SVt_PV) {
#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 (SvLEN(sv))
- assert(delta <= SvLEN(sv));
- else
- assert(delta <= SvCUR(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;
}
* 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 */
+ /* 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_
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 */
#endif
if (bytesread < 0)
bytesread = 0;
- SvCUR_set(sv, bytesread += append);
+ SvCUR_set(sv, bytesread + append);
buffer[bytesread] = '\0';
goto return_string_or_null;
}
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);
case SVt_PVCV:
*st = CvSTASH(sv);
*gvp = NULL;
- return (CV*)sv;
+ return MUTABLE_CV(sv);
case SVt_PVHV:
case SVt_PVAV:
*st = NULL;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
- cv = (CV*)sv;
+ cv = MUTABLE_CV(sv);
*gvp = NULL;
*st = CvSTASH(cv);
return cv;
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);
{
PERL_ARGS_ASSERT_SV_VSETPVFN;
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
*/
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 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((SV*)s,t))
+#define cv_dup_inc(s,t) MUTABLE_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((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((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)
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)
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((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)) {
I32 ix = proto_perl->Isavestack_ix;
ANY *nss;
SV *sv;
- GV *gv;
- AV *av;
- HV *hv;
+ const GV *gv;
+ const AV *av;
+ const HV *hv;
void* ptr;
int intval;
long longval;
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);
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;
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;
#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 */
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;
* 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));
}
*/
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)))
/* 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);
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;
}
}
https://perl5.git.perl.org / perl5.git / blobdiff