*/
void
-Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
+Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
{
dVAR;
void *new_chunk;
U32 new_chunk_size;
+
+ PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
+
new_chunk = (void *)(chunk);
new_chunk_size = (chunk_size);
if (new_chunk_size > PL_nice_chunk_size) {
S_del_sv(pTHX_ SV *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DEL_SV;
+
if (DEBUG_D_TEST) {
SV* sva;
bool ok = 0;
*/
void
-Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
+Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
{
dVAR;
SV* const sva = (SV*)ptr;
register SV* sv;
register SV* svend;
+ PERL_ARGS_ASSERT_SV_ADD_ARENA;
+
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
* whose flags field matches the flags/mask args. */
STATIC I32
-S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
+S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
dVAR;
SV* sva;
I32 visited = 0;
+ PERL_ARGS_ASSERT_VISIT;
+
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
register const SV * const svend = &sva[SvREFCNT(sva)];
register SV* sv;
/* called by sv_clean_objs() for each live SV */
static void
-do_clean_objs(pTHX_ SV *ref)
+do_clean_objs(pTHX_ SV *const ref)
{
dVAR;
assert (SvROK(ref));
#ifndef DISABLE_DESTRUCTOR_KLUDGE
static void
-do_clean_named_objs(pTHX_ SV *sv)
+do_clean_named_objs(pTHX_ SV *const sv)
{
dVAR;
assert(SvTYPE(sv) == SVt_PVGV);
/* called by sv_clean_all() for each live SV */
static void
-do_clean_all(pTHX_ SV *sv)
+do_clean_all(pTHX_ SV *const sv)
{
dVAR;
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
TBD: export properly for hv.c: S_more_he().
*/
void*
-Perl_get_arena(pTHX_ size_t arena_size, U32 misc)
+Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
{
dVAR;
struct arena_desc* adesc;
SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
/* XPVIO is 84 bytes, fits 48x */
- { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
- HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
+ { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
+ + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
+ SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
};
#define new_body_type(sv_type) \
my_safecalloc((details)->body_size + (details)->offset)
STATIC void *
-S_more_bodies (pTHX_ svtype sv_type)
+S_more_bodies (pTHX_ const svtype sv_type)
{
dVAR;
void ** const root = &PL_body_roots[sv_type];
#ifndef PURIFY
STATIC void *
-S_new_body(pTHX_ svtype sv_type)
+S_new_body(pTHX_ const svtype sv_type)
{
dVAR;
void *xpv;
*/
void
-Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
+Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
{
dVAR;
void* old_body;
= bodies_by_type + old_type;
SV *referant = NULL;
+ PERL_ARGS_ASSERT_SV_UPGRADE;
+
if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
*/
int
-Perl_sv_backoff(pTHX_ register SV *sv)
+Perl_sv_backoff(pTHX_ register SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
+
+ PERL_ARGS_ASSERT_SV_BACKOFF;
PERL_UNUSED_CONTEXT;
+
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
assert(SvTYPE(sv) != SVt_PVAV);
*/
char *
-Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
{
register char *s;
+ PERL_ARGS_ASSERT_SV_GROW;
+
if (PL_madskills && newlen >= 0x100000) {
PerlIO_printf(Perl_debug_log,
"Allocation too large: %"UVxf"\n", (UV)newlen);
*/
void
-Perl_sv_setiv(pTHX_ register SV *sv, IV i)
+Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETIV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
*/
void
-Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
+Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
{
+ PERL_ARGS_ASSERT_SV_SETIV_MG;
+
sv_setiv(sv,i);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setuv(pTHX_ register SV *sv, UV u)
+Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
{
+ PERL_ARGS_ASSERT_SV_SETUV;
+
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
*/
void
-Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
+Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
{
+ PERL_ARGS_ASSERT_SV_SETUV_MG;
+
sv_setuv(sv,u);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setnv(pTHX_ register SV *sv, NV num)
+Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETNV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
*/
void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
+Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
{
+ PERL_ARGS_ASSERT_SV_SETNV_MG;
+
sv_setnv(sv,num);
SvSETMAGIC(sv);
}
*/
STATIC void
-S_not_a_number(pTHX_ SV *sv)
+S_not_a_number(pTHX_ SV *const sv)
{
dVAR;
SV *dsv;
char tmpbuf[64];
const char *pv;
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
+
if (DO_UTF8(sv)) {
dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, 0);
*/
I32
-Perl_looks_like_number(pTHX_ SV *sv)
+Perl_looks_like_number(pTHX_ SV *const sv)
{
register const char *sbegin;
STRLEN len;
+ PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
+
if (SvPOK(sv)) {
sbegin = SvPVX_const(sv);
len = SvCUR(sv);
const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
+ PERL_ARGS_ASSERT_GLOB_2NUMBER;
+
/* FAKE globs can get coerced, so need to turn this off temporarily if it
is on. */
SvFAKE_off(gv);
const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
+ PERL_ARGS_ASSERT_GLOB_2PV;
+
/* FAKE globs can get coerced, so need to turn this off temporarily if it
is on. */
SvFAKE_off(gv);
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
+S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
+# ifdef DEBUGGING
+ , I32 numtype
+# endif
+ )
{
dVAR;
- PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
+
+ PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
+
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
#endif /* !NV_PRESERVES_UV*/
STATIC bool
-S_sv_2iuv_common(pTHX_ SV *sv) {
+S_sv_2iuv_common(pTHX_ SV *const sv)
+{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_2IUV_COMMON;
+
if (SvNOKp(sv)) {
/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
* without also getting a cached IV/UV from it at the same time
1 1 already read UV.
so there's no point in sv_2iuv_non_preserve() attempting
to use atol, strtol, strtoul etc. */
+# ifdef DEBUGGING
sv_2iuv_non_preserve (sv, numtype);
+# else
+ sv_2iuv_non_preserve (sv);
+# endif
}
}
#endif /* NV_PRESERVES_UV */
*/
IV
-Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
+Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
*/
UV
-Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
+Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
*/
NV
-Perl_sv_2nv(pTHX_ register SV *sv)
+Perl_sv_2nv(pTHX_ register SV *const sv)
{
dVAR;
if (!sv)
*/
SV *
-Perl_sv_2num(pTHX_ register SV *sv)
+Perl_sv_2num(pTHX_ register SV *const sv)
{
+ PERL_ARGS_ASSERT_SV_2NUM;
+
if (!SvROK(sv))
return sv;
if (SvAMAGIC(sv)) {
*/
static char *
-S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
{
char *ptr = buf + TYPE_CHARS(UV);
char * const ebuf = ptr;
int sign;
+ PERL_ARGS_ASSERT_UIV_2BUF;
+
if (is_uv)
sign = 0;
else if (iv >= 0) {
*/
char *
-Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
register char *s;
len = 7;
retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_REGEXP) {
- char *str = NULL;
- I32 haseval = 0;
- U32 flags = 0;
- struct magic temp;
- /* FIXME - get rid of this cast away of const, or work out
- how to do it better. */
- temp.mg_obj = (SV *)referent;
- assert(temp.mg_obj);
- (str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval);
- if (flags & 1)
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- PL_reginterp_cnt += haseval;
- return str;
+ const REGEXP * const re = (REGEXP *)referent;
+ I32 seen_evals = 0;
+
+ assert(re);
+
+ /* If the regex is UTF-8 we want the containing scalar to
+ have an UTF-8 flag too */
+ if (RX_UTF8(re))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+
+ if ((seen_evals = RX_SEEN_EVALS(re)))
+ PL_reginterp_cnt += seen_evals;
+
+ if (lp)
+ *lp = RX_WRAPLEN(re);
+
+ return RX_WRAPPED(re);
} else {
const char *const typestr = sv_reftype(referent, 0);
const STRLEN typelen = strlen(typestr);
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
if (lp)
*lp = 0;
+ if (flags & SV_UNDEF_RETURNS_NULL)
+ return NULL;
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
return (char *)"";
}
}
if (isGV_with_GP(sv))
return glob_2pv((GV *)sv, lp);
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
if (lp)
*lp = 0;
+ if (flags & SV_UNDEF_RETURNS_NULL)
+ return NULL;
+ if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
*/
void
-Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
{
STRLEN len;
const char * const s = SvPV_const(ssv,len);
+
+ PERL_ARGS_ASSERT_SV_COPYPV;
+
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
{
+ PERL_ARGS_ASSERT_SV_2PVBYTE;
+
sv_utf8_downgrade(sv,0);
return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
char *
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
+ PERL_ARGS_ASSERT_SV_2PVUTF8;
+
sv_utf8_upgrade(sv);
return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
Perl_sv_2bool(pTHX_ register SV *sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_2BOOL;
+
SvGETMAGIC(sv);
if (!SvOK(sv))
Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
+
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+
if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
+ PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
+
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
+ PERL_ARGS_ASSERT_SV_UTF8_DECODE;
+
if (SvPOKp(sv)) {
const U8 *c;
const U8 *e;
{
I32 mro_changes = 0; /* 1 = method, 2 = isa */
+ PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
+
if (dtype != SVt_PVGV) {
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
}
static void
-S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
+S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr)
+{
SV * const sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = NULL;
const int intro = GvINTRO(dstr);
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
+ PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
register int dtype;
register svtype stype;
+ PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
+
if (sstr == dstr)
return;
void
Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
+ PERL_ARGS_ASSERT_SV_SETSV_MG;
+
sv_setsv(dstr,sstr);
SvSETMAGIC(dstr);
}
STRLEN len = SvLEN(sstr);
register char *new_pv;
+ PERL_ARGS_ASSERT_SV_SETSV_COW;
+
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
(void*)sstr, (void*)dstr);
dVAR;
register char *dptr;
+ PERL_ARGS_ASSERT_SV_SETPVN;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
void
Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
+ PERL_ARGS_ASSERT_SV_SETPVN_MG;
+
sv_setpvn(sv,ptr,len);
SvSETMAGIC(sv);
}
dVAR;
register STRLEN len;
+ PERL_ARGS_ASSERT_SV_SETPV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
void
Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
+ PERL_ARGS_ASSERT_SV_SETPV_MG;
+
sv_setpv(sv,ptr);
SvSETMAGIC(sv);
}
{
dVAR;
STRLEN allocate;
+
+ PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
if (!ptr) {
STATIC void
S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
{
+ PERL_ARGS_ASSERT_SV_RELEASE_COW;
+
{ /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
const U8 *real_start;
#endif
+ PERL_ARGS_ASSERT_SV_CHOP;
+
if (!ptr || !SvPOKp(sv))
return;
delta = ptr - SvPVX_const(sv);
STRLEN dlen;
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
+ PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
+
SvGROW(dsv, dlen + slen + 1);
if (sstr == dstr)
sstr = SvPVX_const(dsv);
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
dVAR;
- if (ssv) {
+
+ PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
+
+ if (ssv) {
STRLEN slen;
const char *spv = SvPV_const(ssv, slen);
if (spv) {
STRLEN tlen;
char *junk;
+ PERL_ARGS_ASSERT_SV_CATPV;
+
if (!ptr)
return;
junk = SvPV_force(sv, tlen);
void
Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
+ PERL_ARGS_ASSERT_SV_CATPV_MG;
+
sv_catpv(sv,ptr);
SvSETMAGIC(sv);
}
dVAR;
MAGIC* mg;
+ PERL_ARGS_ASSERT_SV_MAGICEXT;
+
SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
const MGVTBL *vtable;
MAGIC* mg;
+ PERL_ARGS_ASSERT_SV_MAGIC;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
{
MAGIC* mg;
MAGIC** mgp;
+
+ PERL_ARGS_ASSERT_SV_UNMAGIC;
+
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
Perl_sv_rvweaken(pTHX_ SV *sv)
{
SV *tsv;
+
+ PERL_ARGS_ASSERT_SV_RVWEAKEN;
+
if (!SvOK(sv)) /* let undefs pass */
return sv;
if (!SvROK(sv))
dVAR;
AV *av;
+ PERL_ARGS_ASSERT_SV_ADD_BACKREF;
+
if (SvTYPE(tsv) == SVt_PVHV) {
AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
SV **svp;
I32 i;
+ PERL_ARGS_ASSERT_SV_DEL_BACKREF;
+
if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
/* We mustn't attempt to "fix up" the hash here by moving the
{
SV **svp = AvARRAY(av);
+ 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
register I32 i;
STRLEN curlen;
+ PERL_ARGS_ASSERT_SV_INSERT;
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
{
dVAR;
const U32 refcnt = SvREFCNT(sv);
+
+ PERL_ARGS_ASSERT_SV_REPLACE;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1) {
Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
= bodies_by_type + type;
HV *stash;
- assert(sv);
+ PERL_ARGS_ASSERT_SV_CLEAR;
assert(SvREFCNT(sv) == 0);
assert(SvTYPE(sv) != SVTYPEMASK);
return;
}
if (ckWARN_d(WARN_INTERNAL)) {
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced scalar: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
Perl_dump_sv_child(aTHX_ sv);
#else
#ifdef DEBUG_LEAKING_SCALARS
- sv_dump(sv);
+ sv_dump(sv);
#endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ if (PL_warnhook == PERL_WARNHOOK_FATAL
+ || ckDEAD(packWARN(WARN_INTERNAL))) {
+ /* Don't let Perl_warner cause us to escape our fate: */
+ abort();
+ }
+#endif
+ /* This may not return: */
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
#endif
}
#ifdef DEBUG_LEAKING_SCALARS_ABORT
Perl_sv_free2(pTHX_ SV *sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_FREE2;
+
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
{
const U8 *s = start;
+ PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
+
while (s < send && uoffset--)
s += UTF8SKIP(s);
if (s > send) {
STRLEN uoffset, STRLEN uend)
{
STRLEN backw = uend - uoffset;
+
+ PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
+
if (uoffset < 2 * backw) {
/* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
static STRLEN
S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
const U8 *const send, STRLEN uoffset,
- STRLEN uoffset0, STRLEN boffset0) {
+ STRLEN uoffset0, STRLEN boffset0)
+{
STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
+ PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
+
assert (uoffset >= uoffset0);
if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
const U8 *start;
STRLEN len;
+ PERL_ARGS_ASSERT_SV_POS_U2B;
+
if (!sv)
return;
STRLEN blen)
{
STRLEN *cache;
+
+ PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
+
if (SvREADONLY(sv))
return;
const STRLEN forw = target - s;
STRLEN backw = end - target;
+ PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
+
if (forw < 2 * backw) {
return utf8_length(s, target);
}
const U8* send;
bool found = FALSE;
+ PERL_ARGS_ASSERT_SV_POS_B2U;
+
if (!sv)
return;
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
'use bytes' aware, handles get magic, and will coerce its args to strings
-if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
+if necessary. See also C<sv_cmp>.
=cut
*/
dVAR;
MAGIC *mg;
+ PERL_ARGS_ASSERT_SV_COLLXFRM;
+
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
const char *s;
Safefree(mg->mg_ptr);
s = SvPV_const(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
- if (SvREADONLY(sv)) {
- SAVEFREEPV(xf);
- *nxp = xlen;
- return xf + sizeof(PL_collation_ix);
- }
if (! mg) {
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
I32 i = 0;
I32 rspara = 0;
+ PERL_ARGS_ASSERT_SV_GETS;
+
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
/* XXX. If you make this PVIV, then copy on write can copy scalars read
return;
}
if (flags & SVp_NOK) {
+ const NV was = SvNVX(sv);
+ if (NV_OVERFLOWS_INTEGERS_AT &&
+ was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
+ Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when incrementing %" NVff " by 1",
+ was);
+ }
(void)SvNOK_only(sv);
- SvNV_set(sv, SvNVX(sv) + 1.0);
+ SvNV_set(sv, was + 1.0);
return;
}
SvUV_set(sv, SvUVX(sv) - 1);
}
} else {
- if (SvIVX(sv) == IV_MIN)
- sv_setnv(sv, (NV)IV_MIN - 1.0);
+ if (SvIVX(sv) == IV_MIN) {
+ sv_setnv(sv, (NV)IV_MIN);
+ goto oops_its_num;
+ }
else {
(void)SvIOK_only(sv);
SvIV_set(sv, SvIVX(sv) - 1);
return;
}
if (flags & SVp_NOK) {
- SvNV_set(sv, SvNVX(sv) - 1.0);
- (void)SvNOK_only(sv);
- return;
+ oops_its_num:
+ {
+ const NV was = SvNVX(sv);
+ if (NV_OVERFLOWS_INTEGERS_AT &&
+ was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
+ Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when decrementing %" NVff " by 1",
+ was);
+ }
+ (void)SvNOK_only(sv);
+ SvNV_set(sv, was - 1.0);
+ return;
+ }
}
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
dTHX;
register SV *sv;
va_list args;
+
+ PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
+
va_start(args, pat);
sv = vnewSVpvf(pat, &args);
va_end(args);
{
register SV *sv;
va_list args;
+
+ PERL_ARGS_ASSERT_NEWSVPVF;
+
va_start(args, pat);
sv = vnewSVpvf(pat, &args);
va_end(args);
{
dVAR;
register SV *sv;
+
+ PERL_ARGS_ASSERT_VNEWSVPVF;
+
new_SV(sv);
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return sv;
*/
SV *
-Perl_newSV_type(pTHX_ svtype type)
+Perl_newSV_type(pTHX_ const svtype type)
{
register SV *sv;
{
dVAR;
register SV *sv = newSV_type(SVt_IV);
+
+ PERL_ARGS_ASSERT_NEWRV_NOINC;
+
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
SvROK_on(sv);
Perl_newRV(pTHX_ SV *sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWRV;
+
return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
}
dVAR;
char todo[PERL_UCHAR_MAX+1];
+ PERL_ARGS_ASSERT_SV_RESET;
+
if (!stash)
return;
IO* io;
GV* gv;
+ PERL_ARGS_ASSERT_SV_2IO;
+
switch (SvTYPE(sv)) {
case SVt_PVIO:
io = (IO*)sv;
GV *gv = NULL;
CV *cv = NULL;
+ PERL_ARGS_ASSERT_SV_2CV;
+
if (!sv) {
*st = NULL;
*gvp = NULL;
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
+
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
+ PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
+
sv_pvn_force(sv,lp);
sv_utf8_downgrade(sv,0);
*lp = SvCUR(sv);
char *
Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
{
+ PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
+
sv_pvn_force(sv,lp);
sv_utf8_upgrade(sv);
*lp = SvCUR(sv);
const char *
Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
+ PERL_ARGS_ASSERT_SV_REFTYPE;
+
/* The fact that I don't need to downcast to char * everywhere, only in ?:
inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
Perl_sv_isa(pTHX_ SV *sv, const char *name)
{
const char *hvname;
+
+ PERL_ARGS_ASSERT_SV_ISA;
+
if (!sv)
return 0;
SvGETMAGIC(sv);
dVAR;
SV *sv;
+ PERL_ARGS_ASSERT_NEWSVRV;
+
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETREF_PV;
+
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
SvSETMAGIC(rv);
SV*
Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_IV;
+
sv_setiv(newSVrv(rv,classname), iv);
return rv;
}
SV*
Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_UV;
+
sv_setuv(newSVrv(rv,classname), uv);
return rv;
}
SV*
Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_NV;
+
sv_setnv(newSVrv(rv,classname), nv);
return rv;
}
SV*
Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
{
+ PERL_ARGS_ASSERT_SV_SETREF_PVN;
+
sv_setpvn(newSVrv(rv,classname), pv, n);
return rv;
}
{
dVAR;
SV *tmpRef;
+
+ PERL_ARGS_ASSERT_SV_BLESS;
+
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
HV *stash;
SV * const temp = sv_newmortal();
+ PERL_ARGS_ASSERT_SV_UNGLOB;
+
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
gv_efullname3(temp, (GV *) sv, "*");
{
SV* const target = SvRV(ref);
+ PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
+
if (SvWEAKREF(ref)) {
sv_del_backref(target, ref);
SvWEAKREF_off(ref);
void
Perl_sv_untaint(pTHX_ SV *sv)
{
+ PERL_ARGS_ASSERT_SV_UNTAINT;
+
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
bool
Perl_sv_tainted(pTHX_ SV *sv)
{
+ PERL_ARGS_ASSERT_SV_TAINTED;
+
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && (mg->mg_len & 1) )
char *ebuf;
char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ PERL_ARGS_ASSERT_SV_SETPVIV;
+
sv_setpvn(sv, ptr, ebuf - ptr);
}
void
Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
{
+ PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+
sv_setpviv(sv, iv);
SvSETMAGIC(sv);
}
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
+
va_start(args, pat);
sv_vsetpvf(sv, pat, &args);
va_end(args);
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
+
va_start(args, pat);
sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF;
+
va_start(args, pat);
sv_vsetpvf(sv, pat, &args);
va_end(args);
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
+ PERL_ARGS_ASSERT_SV_VSETPVF;
+
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_MG;
+
va_start(args, pat);
sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
+ PERL_ARGS_ASSERT_SV_VSETPVF_MG;
+
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
+
va_start(args, pat);
sv_vcatpvf(sv, pat, &args);
va_end(args);
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
+
va_start(args, pat);
sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF;
+
va_start(args, pat);
sv_vcatpvf(sv, pat, &args);
va_end(args);
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
+ PERL_ARGS_ASSERT_SV_VCATPVF;
+
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_MG;
+
va_start(args, pat);
sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
+ PERL_ARGS_ASSERT_SV_VCATPVF_MG;
+
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
void
Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
+ PERL_ARGS_ASSERT_SV_VSETPVFN;
+
sv_setpvn(sv, "", 0);
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
{
dVAR;
I32 var = 0;
+
+ PERL_ARGS_ASSERT_EXPECT_NUMBER;
+
switch (**pattern) {
case '1': case '2': case '3':
case '4': case '5': case '6':
const int neg = nv < 0;
UV uv;
+ PERL_ARGS_ASSERT_F0CONVERT;
+
if (neg)
nv = -nv;
if (nv < UV_MAX) {
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
PERL_UNUSED_ARG(maybe_tainted);
/* no matter what, this is a string now */
{
yy_parser *parser;
+ PERL_ARGS_ASSERT_PARSER_DUP;
+
if (!proto)
return NULL;
{
PerlIO *ret;
+ PERL_ARGS_ASSERT_FP_DUP;
PERL_UNUSED_ARG(type);
if (!fp)
{
GP *ret;
+ PERL_ARGS_ASSERT_GP_DUP;
+
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
+
+ PERL_ARGS_ASSERT_MG_DUP;
+
if (!mg)
return (MAGIC*)NULL;
/* look for it in the table first */
/* 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 *tbl, const void *sv)
+{
PTR_TBL_ENT_t *tblent;
const UV hash = PTR_TABLE_HASH(sv);
- assert(tbl);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_FIND;
+
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
if (tblent->oldval == sv)
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
PERL_UNUSED_CONTEXT;
+
return tblent ? tblent->newval : NULL;
}
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
{
PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_STORE;
PERL_UNUSED_CONTEXT;
if (tblent) {
const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
+
+ PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
PERL_UNUSED_CONTEXT;
Renew(ary, newsize, PTR_TBL_ENT_t*);
void
Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
{
+ PERL_ARGS_ASSERT_RVPV_DUP;
+
if (SvROK(sstr)) {
SvRV_set(dstr, SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
dVAR;
SV *dstr;
- if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
+ PERL_ARGS_ASSERT_SV_DUP;
+
+ if (!sstr)
return NULL;
+ if (SvTYPE(sstr) == SVTYPEMASK) {
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
+ return NULL;
+ }
/* look for it in the table first */
dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
if (dstr)
{
PERL_CONTEXT *ncxs;
+ PERL_ARGS_ASSERT_CX_DUP;
+
if (!cxs)
return (PERL_CONTEXT*)NULL;
return ncxs;
/* create anew and remember what it is */
- Newxz(ncxs, max + 1, PERL_CONTEXT);
+ Newx(ncxs, max + 1, PERL_CONTEXT);
ptr_table_store(PL_ptr_table, cxs, ncxs);
+ Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
while (ix >= 0) {
- PERL_CONTEXT * const cx = &cxs[ix];
PERL_CONTEXT * const ncx = &ncxs[ix];
- ncx->cx_type = cx->cx_type;
- if (CxTYPE(cx) == CXt_SUBST) {
+ if (CxTYPE(ncx) == CXt_SUBST) {
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
}
else {
- ncx->blk_oldsp = cx->blk_oldsp;
- ncx->blk_oldcop = cx->blk_oldcop;
- ncx->blk_oldmarksp = cx->blk_oldmarksp;
- ncx->blk_oldscopesp = cx->blk_oldscopesp;
- ncx->blk_oldpm = cx->blk_oldpm;
- ncx->blk_gimme = cx->blk_gimme;
- switch (CxTYPE(cx)) {
+ switch (CxTYPE(ncx)) {
case CXt_SUB:
- ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
- ? cv_dup_inc(cx->blk_sub.cv, param)
- : cv_dup(cx->blk_sub.cv,param));
- ncx->blk_sub.argarray = (cx->blk_sub.hasargs
- ? av_dup_inc(cx->blk_sub.argarray, param)
+ ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
+ ? cv_dup_inc(ncx->blk_sub.cv, param)
+ : cv_dup(ncx->blk_sub.cv,param));
+ ncx->blk_sub.argarray = (CxHASARGS(ncx)
+ ? av_dup_inc(ncx->blk_sub.argarray,
+ param)
: NULL);
- ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
- ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
- ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
- ncx->blk_sub.lval = cx->blk_sub.lval;
- ncx->blk_sub.retop = cx->blk_sub.retop;
+ ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
+ param);
ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
- cx->blk_sub.oldcomppad);
+ ncx->blk_sub.oldcomppad);
break;
case CXt_EVAL:
- ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
- ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
- ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
- ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
- ncx->blk_eval.retop = cx->blk_eval.retop;
+ ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
+ param);
+ ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
break;
- case CXt_LOOP:
- ncx->blk_loop.label = cx->blk_loop.label;
- ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
- ncx->blk_loop.my_op = cx->blk_loop.my_op;
- ncx->blk_loop.iterdata = (CxPADLOOP(cx)
- ? cx->blk_loop.iterdata
- : gv_dup((GV*)cx->blk_loop.iterdata, param));
- ncx->blk_loop.oldcomppad
- = (PAD*)ptr_table_fetch(PL_ptr_table,
- cx->blk_loop.oldcomppad);
- ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
- ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
- ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
- ncx->blk_loop.iterix = cx->blk_loop.iterix;
- ncx->blk_loop.itermax = cx->blk_loop.itermax;
+ case CXt_LOOP_LAZYSV:
+ ncx->blk_loop.state_u.lazysv.end
+ = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
+ /* We are taking advantage of av_dup_inc and sv_dup_inc
+ actually being the same function, and order equivalance of
+ the two unions.
+ We can assert the later [but only at run time :-(] */
+ assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
+ (void *) &ncx->blk_loop.state_u.lazysv.cur);
+ case CXt_LOOP_FOR:
+ ncx->blk_loop.state_u.ary.ary
+ = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_PLAIN:
+ if (CxPADLOOP(ncx)) {
+ ncx->blk_loop.oldcomppad
+ = (PAD*)ptr_table_fetch(PL_ptr_table,
+ ncx->blk_loop.oldcomppad);
+ } else {
+ ncx->blk_loop.oldcomppad
+ = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
+ }
break;
case CXt_FORMAT:
- ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
- ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
- ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
- ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
- ncx->blk_sub.retop = cx->blk_sub.retop;
+ ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
+ ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
+ ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
+ param);
break;
case CXt_BLOCK:
case CXt_NULL:
{
PERL_SI *nsi;
+ PERL_ARGS_ASSERT_SI_DUP;
+
if (!si)
return (PERL_SI*)NULL;
{
void *ret;
+ PERL_ARGS_ASSERT_ANY_DUP;
+
if (!v)
return (void*)NULL;
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
+ PERL_ARGS_ASSERT_SS_DUP;
+
Newxz(nss, max, ANY);
while (ix > 0) {
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
}
break;
- case SAVEt_PADSV:
+ case SAVEt_PADSV_AND_MORTALIZE:
longval = (long)POPLONG(ss,ix);
TOPLONG(nss,ix) = longval;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup(sv, param);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_BOOL:
ptr = POPPTR(ss,ix);
* so we know which stashes want their objects cloned */
static void
-do_mark_cloneable_stash(pTHX_ SV *sv)
+do_mark_cloneable_stash(pTHX_ SV *const sv)
{
const HEK * const hvname = HvNAME_HEK((HV*)sv);
if (hvname) {
dVAR;
#ifdef PERL_IMPLICIT_SYS
+ PERL_ARGS_ASSERT_PERL_CLONE;
+
/* perlhost.h so we need to call into it
to clone the host, CPerlHost should have a c interface, sky */
CLONE_PARAMS* const param = &clone_params;
PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+
+ PERL_ARGS_ASSERT_PERL_CLONE_USING;
+
/* for each stash, determine whether its objects should be cloned */
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+
+ PERL_ARGS_ASSERT_PERL_CLONE;
+
/* for each stash, determine whether its objects should be cloned */
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
- PL_preprocess = proto_perl->Ipreprocess;
PL_minus_n = proto_perl->Iminus_n;
PL_minus_p = proto_perl->Iminus_p;
PL_minus_l = proto_perl->Iminus_l;
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
+
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
SV *uni;
STRLEN len;
{
dVAR;
bool ret = FALSE;
+
+ PERL_ARGS_ASSERT_SV_CAT_DECODE;
+
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
SV *offsv;
dSP;
register HE **array;
I32 i;
+ PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
+
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
return NULL;
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
dVAR;
+
+ PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
+
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
(AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
return -1;
goto do_op2;
+ 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 */
projects / p5sagit/p5-mst-13.2.git / blobdiff