sv_report_used() / do_report_used()
dump all remaining SVs (debugging aid)
- sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
+ sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
+ do_clean_named_io_objs()
Attempt to free all objects pointed to by RVs,
and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
try to do the same for all objects indirectly
* "A time to plant, and a time to uproot what was planted..."
*/
-void
-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) {
- Safefree(PL_nice_chunk);
- PL_nice_chunk = (char *) new_chunk;
- PL_nice_chunk_size = new_chunk_size;
- } else {
- Safefree(chunk);
- }
-}
-
#ifdef PERL_MEM_LOG
# define MEM_LOG_NEW_SV(sv, file, line, func) \
Perl_mem_log_new_sv(sv, file, line, func)
{
dVAR;
SV* sv;
-
- if (PL_nice_chunk) {
- sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
- }
- else {
- char *chunk; /* must use New here to match call to */
- Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
- sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
- }
+ char *chunk; /* must use New here to match call to */
+ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
uproot_SV(sv);
return sv;
}
/* XXX Might want to check arrays, etc. */
}
-/* called by sv_clean_objs() for each live SV */
#ifndef DISABLE_DESTRUCTOR_KLUDGE
+
+/* clear any slots in a GV which hold objects - except IO;
+ * called by sv_clean_objs() for each live GV */
+
static void
do_clean_named_objs(pTHX_ SV *const sv)
{
dVAR;
+ SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(sv));
- if (GvGP(sv)) {
- if ((
-#ifdef PERL_DONT_CREATE_GVSV
- GvSV(sv) &&
-#endif
- SvOBJECT(GvSV(sv))) ||
- (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
- (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
- /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
- (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
- (GvCV(sv) && SvOBJECT(GvCV(sv))) )
- {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
- }
+ if (!GvGP(sv))
+ return;
+
+ /* freeing GP entries may indirectly free the current GV;
+ * hold onto it while we mess with the GP slots */
+ SvREFCNT_inc(sv);
+
+ if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log,
+ "Cleaning named glob SV object:\n "), sv_dump(obj)));
+ GvSV(sv) = NULL;
+ SvREFCNT_dec(obj);
+ }
+ if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log,
+ "Cleaning named glob AV object:\n "), sv_dump(obj)));
+ GvAV(sv) = NULL;
+ SvREFCNT_dec(obj);
+ }
+ if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log,
+ "Cleaning named glob HV object:\n "), sv_dump(obj)));
+ GvHV(sv) = NULL;
+ SvREFCNT_dec(obj);
+ }
+ if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log,
+ "Cleaning named glob CV object:\n "), sv_dump(obj)));
+ GvCV(sv) = NULL;
+ SvREFCNT_dec(obj);
}
+ SvREFCNT_dec(sv); /* undo the inc above */
+}
+
+/* clear any IO slots in a GV which hold objects (except stderr, defout);
+ * called by sv_clean_objs() for each live GV */
+
+static void
+do_clean_named_io_objs(pTHX_ SV *const sv)
+{
+ dVAR;
+ SV *obj;
+ assert(SvTYPE(sv) == SVt_PVGV);
+ assert(isGV_with_GP(sv));
+ if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
+ return;
+
+ SvREFCNT_inc(sv);
+ if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log,
+ "Cleaning named glob IO object:\n "), sv_dump(obj)));
+ GvIOp(sv) = NULL;
+ SvREFCNT_dec(obj);
+ }
+ SvREFCNT_dec(sv); /* undo the inc above */
}
#endif
Perl_sv_clean_objs(pTHX)
{
dVAR;
+ GV *olddef, *olderr;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
- /* some barnacles may yet remain, clinging to typeglobs */
+ /* Some barnacles may yet remain, clinging to typeglobs.
+ * Run the non-IO destructors first: they may want to output
+ * error messages, close files etc */
visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+ visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+ olddef = PL_defoutgv;
+ PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
+ if (olddef && isGV_with_GP(olddef))
+ do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
+ olderr = PL_stderrgv;
+ PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
+ if (olderr && isGV_with_GP(olderr))
+ do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
+ SvREFCNT_dec(olddef);
#endif
PL_in_clean_objs = FALSE;
}
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
- PL_in_clean_all = FALSE;
return cleaned;
}
while (i--)
PL_body_roots[i] = 0;
- Safefree(PL_nice_chunk);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
PL_sv_arenaroot = 0;
PL_sv_root = 0;
}
/*
=for apidoc sv_2bool
-This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+This macro is only used by sv_true() or its macro equivalent, and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK.
+It calls sv_2bool_flags with the SV_GMAGIC flag.
+
+=for apidoc sv_2bool_flags
+
+This function is only used by sv_true() and friends, and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
+contain SV_GMAGIC, then it does an mg_get() first.
+
=cut
*/
bool
-Perl_sv_2bool(pTHX_ register SV *const sv)
+Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
- PERL_ARGS_ASSERT_SV_2BOOL;
+ PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
- SvGETMAGIC(sv);
+ if(flags & SV_GMAGIC) SvGETMAGIC(sv);
if (!SvOK(sv))
return 0;
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
- if (dtype != SVt_PVGV) {
+ if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
{
switch (stype) {
case SVt_NULL:
undef_sstr:
- if (dtype != SVt_PVGV) {
+ if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
(void)SvOK_off(dstr);
return;
}
sv_upgrade(dstr, SVt_PVIV);
break;
case SVt_PVGV:
+ case SVt_PVLV:
goto end_of_first_switch;
}
(void)SvIOK_only(dstr);
sv_upgrade(dstr, SVt_PVNV);
break;
case SVt_PVGV:
+ case SVt_PVLV:
goto end_of_first_switch;
}
SvNV_set(dstr, SvNVX(sstr));
/* case SVt_BIND: */
case SVt_PVLV:
case SVt_PVGV:
- if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
glob_assign_glob(dstr, sstr, dtype);
return;
}
case SVt_PVMG:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
- if (SvTYPE(sstr) != stype) {
+ if (SvTYPE(sstr) != stype)
stype = SvTYPE(sstr);
- if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
glob_assign_glob(dstr, sstr, dtype);
return;
- }
}
}
if (stype == SVt_PVLV)
else
Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
- if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+ if (isGV_with_GP(dstr)
&& SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
sstr = SvRV(sstr);
if (sstr == dstr) {
}
if (dtype >= SVt_PV) {
- if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+ if (isGV_with_GP(dstr)) {
glob_assign_ref(dstr, sstr);
return;
}
assert(!(sflags & SVf_NOK));
assert(!(sflags & SVf_IOK));
}
- else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+ else if (isGV_with_GP(dstr)) {
if (!(sflags & SVf_OK)) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Undefined value assigned to typeglob");
#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
- else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ else if (SvFAKE(sv) && isGV_with_GP(sv))
sv_unglob(sv);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
if (ssv) {
STRLEN slen;
- const char *spv = SvPV_const(ssv, slen);
+ const char *spv = SvPV_flags_const(ssv, slen, flags);
if (spv) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
coerce its args to strings if necessary.
+=for apidoc sv_eq_flags
+
+Returns a boolean indicating whether the strings in the two SVs are
+identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
+
=cut
*/
I32
-Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const I32 flags)
{
dVAR;
const char *pv1;
}
else {
/* if pv1 and pv2 are the same, second SvPV_const call may
- * invalidate pv1, so we may need to make a copy */
- if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+ * invalidate pv1 (if we are handling magic), so we may need to
+ * make a copy */
+ if (sv1 == sv2 && flags & SV_GMAGIC
+ && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
pv1 = SvPV_const(sv1, cur1);
sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
}
- pv1 = SvPV_const(sv1, cur1);
+ pv1 = SvPV_flags_const(sv1, cur1, flags);
}
if (!sv2){
cur2 = 0;
}
else
- pv2 = SvPV_const(sv2, cur2);
+ pv2 = SvPV_flags_const(sv2, cur2, flags);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
/* Differing utf8ness.
C<sv2>. 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>.
+=for apidoc sv_cmp_flags
+
+Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get magic. See
+also C<sv_cmp_locale_flags>.
+
=cut
*/
I32
Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
{
+ return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+{
dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
cur1 = 0;
}
else
- pv1 = SvPV_const(sv1, cur1);
+ pv1 = SvPV_flags_const(sv1, cur1, flags);
if (!sv2) {
pv2 = "";
cur2 = 0;
}
else
- pv2 = SvPV_const(sv2, cur2);
+ pv2 = SvPV_flags_const(sv2, cur2, flags);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
/* Differing utf8ness.
'use bytes' aware, handles get magic, and will coerce its args to strings
if necessary. See also C<sv_cmp>.
+=for apidoc sv_cmp_locale_flags
+
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+'use bytes' aware and will coerce its args to strings if necessary. If the
+flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
+
=cut
*/
I32
Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
{
+ return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+{
dVAR;
#ifdef USE_LOCALE_COLLATE
goto raw_compare;
len1 = 0;
- pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
+ pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
len2 = 0;
- pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
+ pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
if (!pv1 || !len1) {
if (pv2 && len2)
/*
=for apidoc sv_collxfrm
-Add Collate Transform magic to an SV if it doesn't already have it.
+This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
+C<sv_collxfrm_flags>.
+
+=for apidoc sv_collxfrm_flags
+
+Add Collate Transform magic to an SV if it doesn't already have it. If the
+flags contain SV_GMAGIC, it handles get-magic.
Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
scalar data of the variable, but transformed to such a format that a normal
*/
char *
-Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
{
dVAR;
MAGIC *mg;
- PERL_ARGS_ASSERT_SV_COLLXFRM;
+ PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
if (mg)
Safefree(mg->mg_ptr);
- s = SvPV_const(sv, len);
+ s = SvPV_flags_const(sv, len, flags);
if ((xf = mem_collxfrm(s, len, &xlen))) {
if (! mg) {
#ifdef PERL_OLD_COPY_ON_WRITE
string. You are responsible for ensuring that the source string is at least
C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
-If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
+If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
C<SVf_UTF8> flag will be set on the new SV.
C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
io = MUTABLE_IO(sv);
break;
case SVt_PVGV:
+ case SVt_PVLV:
if (isGV_with_GP(sv)) {
gv = MUTABLE_GV(sv);
io = GvIO(gv);
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
- case SVt_REGEXP: return "REGEXP";
+ case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
}
return sv;
}
-/* Downgrades a PVGV to a PVMG.
+/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
+ * as it is after unglobbing it.
*/
STATIC void
PERL_ARGS_ASSERT_SV_UNGLOB;
- assert(SvTYPE(sv) == SVt_PVGV);
+ assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
SvFAKE_off(sv);
gv_efullname3(temp, MUTABLE_GV(sv), "*");
}
isGV_with_GP_off(sv);
- /* need to keep SvANY(sv) in the right arena */
- xpvmg = new_XPVMG();
- StructCopy(SvANY(sv), xpvmg, XPVMG);
- del_XPVGV(SvANY(sv));
- SvANY(sv) = xpvmg;
+ if(SvTYPE(sv) == SVt_PVGV) {
+ /* need to keep SvANY(sv) in the right arena */
+ xpvmg = new_XPVMG();
+ StructCopy(SvANY(sv), xpvmg, XPVMG);
+ del_XPVGV(SvANY(sv));
+ SvANY(sv) = xpvmg;
- SvFLAGS(sv) &= ~SVTYPEMASK;
- SvFLAGS(sv) |= SVt_PVMG;
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= SVt_PVMG;
+ }
/* Intentionally not calling any local SET magic, as this isn't so much a
set operation as merely an internal storage change. */
Newxz(parser, 1, yy_parser);
ptr_table_store(PL_ptr_table, proto, parser);
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
-
/* XXX these not yet duped */
parser->old_parser = NULL;
parser->stack = NULL;
DIR *
Perl_dirp_dup(pTHX_ DIR *const dp)
{
+#ifdef HAS_FCHDIR
+ DIR *ret;
+ DIR *pwd;
+ register const Direntry_t *dirent;
+ char smallbuf[256];
+ char *name = NULL;
+ STRLEN len = -1;
+ long pos;
+#endif
+
PERL_UNUSED_CONTEXT;
+
+#ifdef HAS_FCHDIR
if (!dp)
return (DIR*)NULL;
- /* XXX TODO */
- return dp;
+ /* look for it in the table first */
+ ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
+ if (ret)
+ return ret;
+
+ /* create anew */
+
+ /* open the current directory (so we can switch back) */
+ if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
+
+ /* chdir to our dir handle and open the present working directory */
+ if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
+ PerlDir_close(pwd);
+ return (DIR *)NULL;
+ }
+ /* Now we should have two dir handles pointing to the same dir. */
+
+ /* Be nice to the calling code and chdir back to where we were. */
+ fchdir(my_dirfd(pwd)); /* If this fails, then what? */
+
+ /* We have no need of the pwd handle any more. */
+ PerlDir_close(pwd);
+
+#ifdef DIRNAMLEN
+# define d_namlen(d) (d)->d_namlen
+#else
+# define d_namlen(d) strlen((d)->d_name)
+#endif
+ /* Iterate once through dp, to get the file name at the current posi-
+ tion. Then step back. */
+ pos = PerlDir_tell(dp);
+ if ((dirent = PerlDir_read(dp))) {
+ len = d_namlen(dirent);
+ if (len <= sizeof smallbuf) name = smallbuf;
+ else Newx(name, len, char);
+ Move(dirent->d_name, name, len, char);
+ }
+ PerlDir_seek(dp, pos);
+
+ /* Iterate through the new dir handle, till we find a file with the
+ right name. */
+ if (!dirent) /* just before the end */
+ for(;;) {
+ pos = PerlDir_tell(ret);
+ if (PerlDir_read(ret)) continue; /* not there yet */
+ PerlDir_seek(ret, pos); /* step back */
+ break;
+ }
+ else {
+ const long pos0 = PerlDir_tell(ret);
+ for(;;) {
+ pos = PerlDir_tell(ret);
+ if ((dirent = PerlDir_read(ret))) {
+ if (len == d_namlen(dirent)
+ && memEQ(name, dirent->d_name, len)) {
+ /* found it */
+ PerlDir_seek(ret, pos); /* step back */
+ break;
+ }
+ /* else we are not there yet; keep iterating */
+ }
+ else { /* This is not meant to happen. The best we can do is
+ reset the iterator to the beginning. */
+ PerlDir_seek(ret, pos0);
+ break;
+ }
+ }
+ }
+#undef d_namlen
+
+ if (name && name != smallbuf)
+ Safefree(name);
+
+ /* pop it in the pointer table */
+ ptr_table_store(PL_ptr_table, dp, ret);
+
+ return ret;
+#else
+ return (DIR*)NULL;
+#endif
}
/* duplicate a typeglob */
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
case SVt_PVGV:
+ /* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
/* Don't call sv_add_backref here as it's going to be
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
- } else
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+ }
break;
case SVt_PVIO:
/* PL_parser->rsfp_filters entries have fake IoDIRP() */
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
if (CxPADLOOP(ncx)) {
- ncx->blk_loop.oldcomppad
+ ncx->blk_loop.itervar_u.oldcomppad
= (PAD*)ptr_table_fetch(PL_ptr_table,
- ncx->blk_loop.oldcomppad);
+ ncx->blk_loop.itervar_u.oldcomppad);
} else {
- ncx->blk_loop.oldcomppad
- = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
- param);
+ ncx->blk_loop.itervar_u.gv
+ = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
+ param);
}
break;
case CXt_FORMAT:
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
/* fall through */
case SAVEt_ITEM: /* normal string */
+ case SAVEt_GVSV: /* scalar slot in GV */
case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# ifdef DEBUG_LEAKING_SCALARS
- PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+ PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
PL_body_arenas = NULL;
Zero(&PL_body_roots, 1, PL_body_roots);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
PL_sv_count = 0;
PL_sv_objcount = 0;
PL_sv_root = NULL;
PL_regex_pad = AvARRAY(PL_regex_padav);
/* shortcuts to various I/O objects */
- PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
+ PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
PL_defgv = gv_dup(proto_perl->Idefgv, param);
/* Pluggable optimizer */
PL_peepp = proto_perl->Ipeepp;
+ PL_rpeepp = proto_perl->Irpeepp;
/* op_free() hook */
PL_opfreehook = proto_perl->Iopfreehook;