#include "perl.h"
#include "regcomp.h"
+#ifndef HAS_C99
+# if __STDC_VERSION__ >= 199901L && !defined(VMS)
+# define HAS_C99 1
+# endif
+#endif
+#if HAS_C99
+# include <stdint.h>
+#endif
+
#define FCALL *f
#ifdef __Lynx__
contains fields specific to each type. Some types store all they need
in the head, so don't have a body.
-In all but the most memory-paranoid configuations (ex: PURIFY), heads
+In all but the most memory-paranoid configurations (ex: PURIFY), heads
and bodies are allocated out of arenas, which by default are
approximately 4K chunks of memory parcelled up into N heads or bodies.
Sv-bodies are allocated by their sv-type, guaranteeing size
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
+ and try to do the same for all objects indirectly
referenced by typeglobs too. Called once from
perl_destruct(), prior to calling sv_clean_all()
below.
}
-#ifndef DISABLE_DESTRUCTOR_KLUDGE
-
/* clear any slots in a GV which hold objects - except IO;
* called by sv_clean_objs() for each live GV */
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;
+ GvCV_set(sv, NULL);
SvREFCNT_dec(obj);
}
SvREFCNT_dec(sv); /* undo the inc above */
}
SvREFCNT_dec(sv); /* undo the inc above */
}
-#endif
+
+/* Void wrapper to pass to visit() */
+static void
+do_curse(pTHX_ SV * const sv) {
+ if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
+ || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
+ return;
+ (void)curse(sv, 0);
+}
/*
=for apidoc sv_clean_objs
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.
* 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);
+ /* And if there are some very tenacious barnacles clinging to arrays,
+ closures, or what have you.... */
+ visit(do_curse, SVs_OBJECT, SVs_OBJECT);
olddef = PL_defoutgv;
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
if (olddef && isGV_with_GP(olddef))
if (olderr && isGV_with_GP(olderr))
do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
SvREFCNT_dec(olddef);
-#endif
PL_in_clean_objs = FALSE;
}
Remember, this is integer division: */
end = start + good_arena_size / body_size * body_size;
- /* computed count doesnt reflect the 1st slot reservation */
+ /* computed count doesn't reflect the 1st slot reservation */
#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d (from %d) type %d "
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
+ /* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
default: NOOP;
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
+ /* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
default: NOOP;
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. In practice it seems that they never
- actually anywhere accessible by user Perl code, let alone get used
- in anything other than a string context. */
+ if (SvGMAGICAL(sv) || SvVALID(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ In practice they are extremely unlikely to actually get anywhere
+ accessible by user Perl code - the only way that I'm aware of is when
+ a constant subroutine which is used as the second argument to index.
+ */
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
SV * tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr=AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvIV(tmpstr);
}
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. */
+ if (SvGMAGICAL(sv) || SvVALID(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs. */
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr = AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvUV(tmpstr);
}
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
- /* FBMs use the same flag bit as SVf_IVisUV, so must let them
- cache IVs just in case. */
+ if (SvGMAGICAL(sv) || SvVALID(sv)) {
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
+ the same flag bit as SVf_IVisUV, so must not let them cache NVs. */
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvNOKp(sv))
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr = AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvNV(tmpstr);
}
if (!SvROK(sv))
return sv;
if (SvAMAGIC(sv)) {
- SV * const tmpsv = AMG_CALLun(sv,numer);
+ SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
TAINT_IF(tmpsv && SvTAINTED(tmpsv));
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return sv_2num(tmpsv);
len = SvIsUV(sv)
? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
: my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
+ } else if(SvNVX(sv) == 0.0) {
+ tbuf[0] = '0';
+ tbuf[1] = 0;
+ len = 1;
} else {
Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
len = strlen(tbuf);
{
dVAR;
- if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
- tbuf[0] = '0';
- tbuf[1] = 0;
- len = 1;
- }
SvUPGRADE(sv, SVt_PV);
if (lp)
*lp = len;
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return NULL;
- tmpstr = AMG_CALLun(sv,string);
+ tmpstr = AMG_CALLunary(sv, string_amg);
TAINT_IF(tmpstr && SvTAINTED(tmpstr));
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
/* Unwrap this: */
retval -= stashnamelen;
memcpy(retval, stashname, stashnamelen);
}
- /* retval may not neccesarily have reached the start of the
+ /* retval may not necessarily have reached the start of the
buffer here. */
assert (retval >= buffer);
*s = '\0';
}
else if (SvNOKp(sv)) {
- dSAVE_ERRNO;
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- /* The +20 is pure guesswork. Configure test needed. --jhi */
- s = SvGROW_mutable(sv, NV_DIG + 20);
- /* some Xenix systems wipe out errno here */
-#ifdef apollo
- if (SvNVX(sv) == 0.0)
- my_strlcpy(s, "0", SvLEN(sv));
- else
-#endif /*apollo*/
- {
+ if (SvNVX(sv) == 0.0) {
+ s = SvGROW_mutable(sv, 2);
+ *s++ = '0';
+ *s = '\0';
+ } else {
+ dSAVE_ERRNO;
+ /* The +20 is pure guesswork. Configure test needed. --jhi */
+ s = SvGROW_mutable(sv, NV_DIG + 20);
+ /* some Xenix systems wipe out errno here */
Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ RESTORE_ERRNO;
+ while (*s) s++;
}
- RESTORE_ERRNO;
- if (*s == '-' && s[1] == '0' && !s[2]) {
- s[0] = '0';
- s[1] = 0;
- }
- while (*s) s++;
#ifdef hcx
if (s[-1] == '.')
*--s = '\0';
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
+ SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
- return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+ return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
/*
return 0;
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
- SV * const tmpsv = AMG_CALLun(sv,bool_);
+ SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return cBOOL(SvTRUE(tmpsv));
}
return len;
}
} else {
- (void) SvPV_force(sv,len);
+ (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
}
}
}
}
}
+
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* Update pos. We do it at the end rather than during
+ * the upgrade, to avoid slowing down the common case
+ * (upgrade without pos) */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0 && (U32)pos > invariant_head) {
+ U8 *d = (U8*) SvPVX(sv) + invariant_head;
+ STRLEN n = (U32)pos - invariant_head;
+ while (n > 0) {
+ if (UTF8_IS_START(*d))
+ d++;
+ d++;
+ n--;
+ }
+ mg->mg_len = d - (U8*)SvPVX(sv);
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
}
}
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
+ int mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
- s = (U8 *) SvPV(sv, len);
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* update pos */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0) {
+ sv_pos_b2u(sv, &pos);
+ mg_flags = 0; /* sv_pos_b2u does get magic */
+ mg->mg_len = pos;
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+
+ }
+ s = (U8 *) SvPV_flags(sv, len, mg_flags);
+
if (!utf8_to_bytes(s, &len)) {
if (fail_ok)
return FALSE;
If the PV of the SV is an octet sequence in UTF-8
and contains a multiple-byte character, the C<SvUTF8> flag is turned on
so that it looks like a character. If the PV contains only single-byte
-characters, the C<SvUTF8> flag stays being off.
+characters, the C<SvUTF8> flag stays off.
Scans PV for validity and returns false if the PV is invalid UTF-8.
=cut
PERL_ARGS_ASSERT_SV_UTF8_DECODE;
if (SvPOKp(sv)) {
- const U8 *c;
+ const U8 *start, *c;
const U8 *e;
/* The octets may have got themselves encoded - get them back as
/* it is actually just a matter of turning the utf8 flag on, but
* we want to make sure everything inside is valid utf8 first.
*/
- c = (const U8 *) SvPVX_const(sv);
+ c = start = (const U8 *) SvPVX_const(sv);
if (!is_utf8_string(c, SvCUR(sv)+1))
return FALSE;
e = (const U8 *) SvEND(sv);
break;
}
}
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* adjust pos to the start of a UTF8 char sequence */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0) {
+ for (c = start + pos; c > start; c--) {
+ if (UTF8_IS_START(*c))
+ break;
+ }
+ mg->mg_len = c - start;
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
}
return TRUE;
}
/* If source has method cache entry, clear it */
if(GvCVGEN(sstr)) {
SvREFCNT_dec(GvCV(sstr));
- GvCV(sstr) = NULL;
+ GvCV_set(sstr, NULL);
GvCVGEN(sstr) = 0;
}
/* If source has a real method, then a method is
going to change */
- else if(GvCV((const GV *)sstr)) {
+ else if(
+ GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+ ) {
mro_changes = 1;
}
}
/* If dest already had a real method, that's a change as well */
- if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
+ if(
+ !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
+ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+ ) {
mro_changes = 1;
}
glob to begin with. */
if(dtype == SVt_PVGV) {
const char * const name = GvNAME((const GV *)dstr);
- if(strEQ(name,"ISA"))
+ if(
+ strEQ(name,"ISA")
+ /* The stash may have been detached from the symbol table, so
+ check its name. */
+ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+ && GvAV((const GV *)sstr)
+ )
mro_changes = 2;
else {
const STRLEN len = GvNAMELEN(dstr);
- if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')) {
mro_changes = 3;
/* Set aside the old stash, so we can reset isa caches on
its subclasses. */
- old_stash = GvHV(dstr);
+ if((old_stash = GvHV(dstr)))
+ /* Make sure we do not lose it early. */
+ SvREFCNT_inc_simple_void_NN(
+ sv_2mortal((SV *)old_stash)
+ );
}
}
}
(void)SvOK_off(dstr);
isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
- GvGP(dstr) = gp_ref(GvGP(sstr));
+ GvGP_set(dstr, gp_ref(GvGP(sstr)));
if (SvTAINTED(sstr))
SvTAINT(dstr);
if (GvIMPORTED(dstr) != GVf_IMPORTED
GvIMPORTED_on(dstr);
}
GvMULTI_on(dstr);
- if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ if(mro_changes == 2) {
+ MAGIC *mg;
+ SV * const sref = (SV *)GvAV((const GV *)dstr);
+ if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+ if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+ AV * const ary = newAV();
+ av_push(ary, mg->mg_obj); /* takes the refcount */
+ mg->mg_obj = (SV *)ary;
+ }
+ av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
+ }
+ else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
+ mro_isa_changed_in(GvSTASH(dstr));
+ }
else if(mro_changes == 3) {
- const HV * const stash = GvHV(dstr);
- if(stash && HvNAME(stash)) mro_package_moved(stash);
- if(old_stash && HvNAME(old_stash)) mro_package_moved(old_stash);
+ HV * const stash = GvHV(dstr);
+ if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
+ mro_package_moved(
+ stash, old_stash,
+ (GV *)dstr, 0
+ );
}
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
GvMULTI_on(dstr);
switch (stype) {
case SVt_PVCV:
- location = (SV **) &GvCV(dstr);
+ location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
import_flag = GVf_IMPORTED_CV;
goto common;
case SVt_PVHV:
/*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
if (GvCVGEN(dstr)) {
SvREFCNT_dec(GvCV(dstr));
- GvCV(dstr) = NULL;
+ GvCV_set(dstr, NULL);
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
}
}
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
- if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
- if(HvNAME(dref)) mro_package_moved((HV *)dref);
- if(HvNAME(sref)) mro_package_moved((HV *)sref);
+ if (
+ (
+ (len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')
+ )
+ && (!dref || HvENAME_get(dref))
+ ) {
+ mro_package_moved(
+ (HV *)sref, (HV *)dref,
+ (GV *)dstr, 0
+ );
+ }
+ }
+ else if (
+ stype == SVt_PVAV && sref != dref
+ && strEQ(GvNAME((GV*)dstr), "ISA")
+ /* The stash may have been detached from the symbol table, so
+ check its name before doing anything. */
+ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
+ ) {
+ MAGIC *mg;
+ MAGIC * const omg = dref && SvSMAGICAL(dref)
+ ? mg_find(dref, PERL_MAGIC_isa)
+ : NULL;
+ if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
+ if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
+ AV * const ary = newAV();
+ av_push(ary, mg->mg_obj); /* takes the refcount */
+ mg->mg_obj = (SV *)ary;
+ }
+ if (omg) {
+ if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
+ SV **svp = AvARRAY((AV *)omg->mg_obj);
+ I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
+ while (items--)
+ av_push(
+ (AV *)mg->mg_obj,
+ SvREFCNT_inc_simple_NN(*svp++)
+ );
+ }
+ else
+ av_push(
+ (AV *)mg->mg_obj,
+ SvREFCNT_inc_simple_NN(omg->mg_obj)
+ );
+ }
+ else
+ av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
}
- }
- else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
- sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
- mro_isa_changed_in(GvSTASH(dstr));
+ else
+ {
+ sv_magic(
+ sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
+ );
+ mg = mg_find(sref, PERL_MAGIC_isa);
+ }
+ /* Since the *ISA assignment could have affected more than
+ one stash, don’t call mro_isa_changed_in directly, but let
+ magic_clearisa do it for us, as it already has the logic for
+ dealing with globs vs arrays of globs. */
+ assert(mg);
+ Perl_magic_clearisa(aTHX_ NULL, mg);
}
break;
}
/* case SVt_BIND: */
case SVt_PVLV:
case SVt_PVGV:
- if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
- glob_assign_glob(dstr, sstr, dtype);
- return;
- }
- /* SvVALID means that this PVGV is playing at being an FBM. */
- /*FALLTHROUGH*/
-
case SVt_PVMG:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype)
stype = SvTYPE(sstr);
- if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
+ }
+ if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
glob_assign_glob(dstr, sstr, dtype);
return;
- }
}
if (stype == SVt_PVLV)
SvUPGRADE(dstr, SVt_PVNV);
const STRLEN len = GvNAMELEN(dstr);
HV *old_stash = NULL;
bool reset_isa = FALSE;
- if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')) {
/* Set aside the old stash, so we can reset isa caches
on its subclasses. */
- old_stash = GvHV(dstr);
+ if((old_stash = GvHV(dstr))) {
+ /* Make sure we do not lose it early. */
+ SvREFCNT_inc_simple_void_NN(
+ sv_2mortal((SV *)old_stash)
+ );
+ }
reset_isa = TRUE;
}
if (GvGP(dstr))
gp_free(MUTABLE_GV(dstr));
- GvGP(dstr) = gp_ref(GvGP(gv));
+ GvGP_set(dstr, gp_ref(GvGP(gv)));
if (reset_isa) {
- const HV * const stash = GvHV(dstr);
- if(stash && HvNAME(stash)) mro_package_moved(stash);
- if(old_stash && HvNAME(old_stash))
- mro_package_moved(old_stash);
+ HV * const stash = GvHV(dstr);
+ if(
+ old_stash ? (HV *)HvENAME_get(old_stash) : stash
+ )
+ mro_package_moved(
+ stash, old_stash,
+ (GV *)dstr, 0
+ );
}
}
}
#endif
if (flags & SV_HAS_TRAILING_NUL) {
/* It's long enough - do nothing.
- Specfically Perl_newCONSTSUB is relying on this. */
+ Specifically Perl_newCONSTSUB is relying on this. */
} else {
#ifdef DEBUGGING
/* Force a move to shake out bugs in callers. */
then a copy-on-write scalar drops its PV buffer (if any) and becomes
SvPOK_off rather than making a copy. (Used where this scalar is about to be
set to some other value.) In addition, the C<flags> parameter gets passed to
-C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
+C<sv_unref_flags()> when unreffing. C<sv_force_normal> calls this function
with flags set to 0.
=cut
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
+ /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
*/
void
-Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, I32 flags)
+Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
{
PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
mg->mg_ptr = savepvn(name, namlen);
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
+ HEf_SVKEY. I think we need to document this aberation 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);
case PERL_MAGIC_overload_table:
vtable = &PL_vtbl_ovrld;
break;
- case PERL_MAGIC_bm:
- vtable = &PL_vtbl_bm;
- break;
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
case PERL_MAGIC_env:
vtable = &PL_vtbl_env;
break;
- case PERL_MAGIC_fm:
- vtable = &PL_vtbl_fm;
- break;
case PERL_MAGIC_envelem:
vtable = &PL_vtbl_envelem;
break;
case PERL_MAGIC_nkeys:
vtable = &PL_vtbl_nkeys;
break;
- case PERL_MAGIC_dbfile:
- vtable = NULL;
- break;
case PERL_MAGIC_dbline:
vtable = &PL_vtbl_dbline;
break;
case PERL_MAGIC_tiedscalar:
vtable = &PL_vtbl_packelem;
break;
+ case PERL_MAGIC_fm:
+ case PERL_MAGIC_bm:
case PERL_MAGIC_qr:
vtable = &PL_vtbl_regexp;
break;
- case PERL_MAGIC_sig:
- vtable = &PL_vtbl_sig;
- break;
+#ifndef PERL_MICRO
case PERL_MAGIC_sigelem:
vtable = &PL_vtbl_sigelem;
break;
+#endif
case PERL_MAGIC_taint:
vtable = &PL_vtbl_taint;
break;
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_dbfile:
+ case PERL_MAGIC_sig:
case PERL_MAGIC_arylen_p:
case PERL_MAGIC_rhash:
case PERL_MAGIC_symtab:
}
}
-/*
-=for apidoc sv_unmagic
-
-Removes all magic of type C<type> from an SV.
-
-=cut
-*/
-
-int
-Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+static int
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
MAGIC** mgp;
- PERL_ARGS_ASSERT_SV_UNMAGIC;
+ assert(flags <= 1);
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
for (mg = *mgp; mg; mg = *mgp) {
- if (mg->mg_type == type) {
- const MGVTBL* const vtbl = mg->mg_virtual;
+ const MGVTBL* const virt = mg->mg_virtual;
+ if (mg->mg_type == type && (!flags || virt == vtbl)) {
*mgp = mg->mg_moremagic;
- if (vtbl && vtbl->svt_free)
- vtbl->svt_free(aTHX_ sv, mg);
+ if (virt && virt->svt_free)
+ virt->svt_free(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len > 0)
Safefree(mg->mg_ptr);
}
/*
+=for apidoc sv_unmagic
+
+Removes all magic of type C<type> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+{
+ PERL_ARGS_ASSERT_SV_UNMAGIC;
+ return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc sv_unmagicext
+
+Removes all magic of type C<type> with the specified C<vtbl> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+ PERL_ARGS_ASSERT_SV_UNMAGICEXT;
+ return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
+}
+
+/*
=for apidoc sv_rvweaken
Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
* store it directly in the HvAUX or mg_obj slot, avoiding the need to
* allocate an AV. (Whether the slot holds an AV tells us whether this is
* active.)
- *
- * If an HV's backref is stored in magic, it is moved back to HvAUX.
*/
/* 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
+ * PERL_MAGIC_backref, or in the specific case of a HV, from the
+ * xhv_backreferences field. The array is created with a refcount
* of 2. This means that if during global destruction the array gets
* picked on before its parent to have its refcount decremented by the
* random zapper, it won't actually be freed, meaning it's still there for
if (SvTYPE(tsv) == SVt_PVHV) {
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
-
- if (!*svp) {
- if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
- /* Aha. They've got it stowed in magic instead.
- * Move it back to xhv_backreferences */
- *svp = mg->mg_obj;
- /* Stop mg_free decreasing the reference count. */
- mg->mg_obj = NULL;
- /* Stop mg_free even calling the destructor, given that
- there's no AV to free up. */
- mg->mg_virtual = 0;
- sv_unmagic(tsv, PERL_MAGIC_backref);
- mg = NULL;
- }
- }
} else {
if (! ((mg =
(SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
{
dVAR;
SV **svp = NULL;
- I32 i;
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
- if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ if (SvOOK(tsv))
+ svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
- if (!svp || !*svp) {
+ else {
MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
svp = mg ? &(mg->mg_obj) : NULL;
Perl_croak(aTHX_ "panic: del_backref");
if (SvTYPE(*svp) == SVt_PVAV) {
- int count = 0;
+#ifdef DEBUGGING
+ int count = 1;
+#endif
AV * const av = (AV*)*svp;
+ SSize_t fill;
assert(!SvIS_FREED(av));
+ fill = AvFILLp(av);
+ assert(fill > -1);
svp = AvARRAY(av);
- for (i = AvFILLp(av); i >= 0; i--) {
- if (svp[i] == sv) {
- const SSize_t fill = AvFILLp(av);
- if (i != fill) {
- /* We weren't the last entry.
- An unordered list has this property that you can take the
- last element off the end to fill the hole, and it's still
- an unordered list :-)
- */
- svp[i] = svp[fill];
- }
- svp[fill] = NULL;
- AvFILLp(av) = fill - 1;
- count++;
-#ifndef DEBUGGING
- break; /* should only be one */
+ /* for an SV with N weak references to it, if all those
+ * weak refs are deleted, then sv_del_backref will be called
+ * N times and O(N^2) compares will be done within the backref
+ * array. To ameliorate this potential slowness, we:
+ * 1) make sure this code is as tight as possible;
+ * 2) when looking for SV, look for it at both the head and tail of the
+ * array first before searching the rest, since some create/destroy
+ * patterns will cause the backrefs to be freed in order.
+ */
+ if (*svp == sv) {
+ AvARRAY(av)++;
+ AvMAX(av)--;
+ }
+ else {
+ SV **p = &svp[fill];
+ SV *const topsv = *p;
+ if (topsv != sv) {
+#ifdef DEBUGGING
+ count = 0;
+#endif
+ while (--p > svp) {
+ if (*p == sv) {
+ /* We weren't the last entry.
+ An unordered list has this property that you
+ can take the last element off the end to fill
+ the hole, and it's still an unordered list :-)
+ */
+ *p = topsv;
+#ifdef DEBUGGING
+ count++;
+#else
+ break; /* should only be one */
#endif
+ }
+ }
}
}
- assert(count == 1);
+ assert(count ==1);
+ AvFILLp(av) = fill-1;
}
else {
/* optimisation: only a single backref, stored directly */
if (!av)
return;
+ /* after multiple passes through Perl_sv_clean_all() for a thinngy
+ * that has badly leaked, the backref array may have gotten freed,
+ * since we only protect it against 1 round of cleanup */
+ if (SvIS_FREED(av)) {
+ if (PL_in_clean_all) /* All is fair */
+ return;
+ Perl_croak(aTHX_
+ "panic: magic_killbackrefs (freed backref AV/SV)");
+ }
+
+
is_array = (SvTYPE(av) == SVt_PVAV);
if (is_array) {
assert(!SvIS_FREED(av));
/* You lookin' at me? */
assert(CvSTASH(referrer));
assert(CvSTASH(referrer) == (const HV *)sv);
- CvSTASH(referrer) = 0;
+ SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
}
else {
assert(SvTYPE(sv) == SVt_PVGV);
}
/* if not, anonymise: */
- stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
+ ? HvENAME(GvSTASH(gv)) : NULL;
gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
stash ? stash : "__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
SV* iter_sv = NULL;
SV* next_sv = NULL;
register SV *sv = orig_sv;
+ STRLEN hash_index;
PERL_ARGS_ASSERT_SV_CLEAR;
goto free_head;
}
- if (SvOBJECT(sv)) {
- if (PL_defstash && /* Still have a symbol table? */
- SvDESTROYABLE(sv))
- {
- dSP;
- HV* stash;
- do {
- CV* destructor;
- stash = SvSTASH(sv);
- destructor = StashHANDLER(stash,DESTROY);
- if (destructor
- /* A constant subroutine can have no side effects, so
- don't bother calling it. */
- && !CvCONST(destructor)
- /* Don't bother calling an empty destructor */
- && (CvISXSUB(destructor)
- || (CvSTART(destructor)
- && (CvSTART(destructor)->op_next->op_type
- != OP_LEAVESUB))))
- {
- SV* const tmpref = newRV(sv);
- SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
- ENTER;
- PUSHSTACKi(PERLSI_DESTROY);
- EXTEND(SP, 2);
- PUSHMARK(SP);
- PUSHs(tmpref);
- PUTBACK;
- call_sv(MUTABLE_SV(destructor),
- G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
- POPSTACK;
- SPAGAIN;
- LEAVE;
- if(SvREFCNT(tmpref) < 2) {
- /* tmpref is not kept alive! */
- SvREFCNT(sv)--;
- SvRV_set(tmpref, NULL);
- SvROK_off(tmpref);
- }
- SvREFCNT_dec(tmpref);
- }
- } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
-
-
- if (SvREFCNT(sv)) {
- if (PL_in_clean_objs)
- Perl_croak(aTHX_
- "DESTROY created new reference to dead object '%s'",
- HvNAME_get(stash));
- /* DESTROY gave object new lease on life */
- goto get_next_sv;
- }
- }
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+ if (type >= SVt_PVMG) {
if (SvOBJECT(sv)) {
- SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
- SvOBJECT_off(sv); /* Curse the object. */
- if (type != SVt_PVIO)
- --PL_sv_objcount;/* XXX Might want something more general */
+ if (!curse(sv, 1)) goto get_next_sv;
+ type = SvTYPE(sv); /* destructor may have changed it */
}
- }
- if (type >= SVt_PVMG) {
- if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ /* Free back-references before magic, in case the magic calls
+ * Perl code that has weak references to sv. */
+ if (type == SVt_PVHV) {
+ Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ }
+ else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(SvOURSTASH(sv));
- } else if (SvMAGIC(sv))
+ } else if (SvMAGIC(sv)) {
+ /* Free back-references before other types of magic. */
+ sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
+ }
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(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));
+ if (HvTOTALKEYS((HV*)sv) > 0) {
+ const char *name;
+ /* this statement should match the one at the beginning of
+ * hv_undef_flags() */
+ if ( PL_phase != PERL_PHASE_DESTRUCT
+ && (name = HvNAME((HV*)sv)))
+ {
+ if (PL_stashcache)
+ (void)hv_delete(PL_stashcache, name,
+ HvNAMELEN_get((HV*)sv), G_DISCARD);
+ hv_name_set((HV*)sv, NULL, 0, 0);
+ }
+
+ /* save old iter_sv in unused SvSTASH field */
+ assert(!SvOBJECT(sv));
+ SvSTASH(sv) = (HV*)iter_sv;
+ iter_sv = sv;
+
+ /* XXX ideally we should save the old value of hash_index
+ * too, but I can't think of any place to hide it. The
+ * effect of not saving it is that for freeing hashes of
+ * hashes, we become quadratic in scanning the HvARRAY of
+ * the top hash looking for new entries to free; but
+ * hopefully this will be dwarfed by the freeing of all
+ * the nested hashes. */
+ hash_index = 0;
+ next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
+ goto get_next_sv; /* process this new sv */
+ }
+ /* free empty hash */
+ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+ assert(!HvARRAY((HV*)sv));
break;
case SVt_PVAV:
{
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
- && HvNAME_get(stash))
+ && HvENAME_get(stash))
mro_method_changed_in(stash);
gp_free(MUTABLE_GV(sv));
if (GvNAME_HEK(sv))
Safefree(AvALLOC(av));
goto free_body;
}
+ } else if (SvTYPE(iter_sv) == SVt_PVHV) {
+ sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
+ if (!sv) { /* no more elements of current HV to free */
+ sv = iter_sv;
+ type = SvTYPE(sv);
+ /* Restore previous value of iter_sv, squirrelled away */
+ assert(!SvOBJECT(sv));
+ iter_sv = (SV*)SvSTASH(sv);
+
+ /* ideally we should restore the old hash_index here,
+ * but we don't currently save the old value */
+ hash_index = 0;
+
+ /* free any remaining detritus from the hash struct */
+ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+ assert(!HvARRAY((HV*)sv));
+ goto free_body;
+ }
}
/* unrolled SvREFCNT_dec and sv_free2 follows: */
} /* while sv */
}
+/* This routine curses the sv itself, not the object referenced by sv. So
+ sv does not have to be ROK. */
+
+static bool
+S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
+ dVAR;
+
+ PERL_ARGS_ASSERT_CURSE;
+ assert(SvOBJECT(sv));
+
+ if (PL_defstash && /* Still have a symbol table? */
+ SvDESTROYABLE(sv))
+ {
+ dSP;
+ HV* stash;
+ do {
+ CV* destructor;
+ stash = SvSTASH(sv);
+ destructor = StashHANDLER(stash,DESTROY);
+ if (destructor
+ /* A constant subroutine can have no side effects, so
+ don't bother calling it. */
+ && !CvCONST(destructor)
+ /* Don't bother calling an empty destructor */
+ && (CvISXSUB(destructor)
+ || (CvSTART(destructor)
+ && (CvSTART(destructor)->op_next->op_type
+ != OP_LEAVESUB))))
+ {
+ SV* const tmpref = newRV(sv);
+ SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+ ENTER;
+ PUSHSTACKi(PERLSI_DESTROY);
+ EXTEND(SP, 2);
+ PUSHMARK(SP);
+ PUSHs(tmpref);
+ PUTBACK;
+ call_sv(MUTABLE_SV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+ POPSTACK;
+ SPAGAIN;
+ LEAVE;
+ if(SvREFCNT(tmpref) < 2) {
+ /* tmpref is not kept alive! */
+ SvREFCNT(sv)--;
+ SvRV_set(tmpref, NULL);
+ SvROK_off(tmpref);
+ }
+ SvREFCNT_dec(tmpref);
+ }
+ } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+
+ if (check_refcnt && SvREFCNT(sv)) {
+ if (PL_in_clean_objs)
+ Perl_croak(aTHX_
+ "DESTROY created new reference to dead object '%s'",
+ HvNAME_get(stash));
+ /* DESTROY gave object new lease on life */
+ return FALSE;
+ }
+ }
+
+ if (SvOBJECT(sv)) {
+ SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ SvOBJECT_off(sv); /* Curse the object. */
+ if (SvTYPE(sv) != SVt_PVIO)
+ --PL_sv_objcount;/* XXX Might want something more general */
+ }
+ return TRUE;
+}
+
/*
=for apidoc sv_newref
/* Cache has 2 slots in use, and we know three potential pairs.
Keep the two that give the lowest RMS distance. Do the
- calcualation in bytes simply because we always know the byte
+ calculation in bytes simply because we always know the byte
length. squareroot has the same ordering as the positive value,
so don't bother with the actual square root. */
const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
*/
I32
-Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const I32 flags)
+Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
{
dVAR;
const char *pv1;
}
}
else {
- bool is_utf8 = TRUE;
-
if (SvUTF8(sv1)) {
- /* sv1 is the UTF-8 one,
- * if is equal it must be downgrade-able */
- char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
- &cur1, &is_utf8);
- if (pv != pv1)
- pv1 = tpv = pv;
+ /* sv1 is the UTF-8 one */
+ return bytes_cmp_utf8((const U8*)pv2, cur2,
+ (const U8*)pv1, cur1) == 0;
}
else {
- /* sv2 is the UTF-8 one,
- * if is equal it must be downgrade-able */
- char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
- &cur2, &is_utf8);
- if (pv != pv2)
- pv2 = tpv = pv;
- }
- if (is_utf8) {
- /* Downgrade not possible - cannot be eq */
- assert (tpv == 0);
- return FALSE;
+ /* sv2 is the UTF-8 one */
+ return bytes_cmp_utf8((const U8*)pv1, cur1,
+ (const U8*)pv2, cur2) == 0;
}
}
}
}
I32
-Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+ const U32 flags)
{
dVAR;
STRLEN cur1, cur2;
pv2 = SvPV_const(svrecode, cur2);
}
else {
- pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
+ const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
+ (const U8*)pv1, cur1);
+ return retval ? retval < 0 ? -1 : +1 : 0;
}
}
else {
pv1 = SvPV_const(svrecode, cur1);
}
else {
- pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
+ const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
+ (const U8*)pv2, cur2);
+ return retval ? retval < 0 ? -1 : +1 : 0;
}
}
}
}
I32
-Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+ const U32 flags)
{
dVAR;
#ifdef USE_LOCALE_COLLATE
#endif /* USE_LOCALE_COLLATE */
+static char *
+S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+ SV * const tsv = newSV(0);
+ ENTER;
+ SAVEFREESV(tsv);
+ sv_gets(tsv, fp, 0);
+ sv_utf8_upgrade_nomg(tsv);
+ SvCUR_set(sv,append);
+ sv_catsv(sv,tsv);
+ LEAVE;
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+
+static char *
+S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+ I32 bytesread;
+ const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+ /* Grab the size of the record we're getting */
+ char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+#ifdef VMS
+ int fd;
+#endif
+
+ /* Go yank in */
+#ifdef VMS
+ /* VMS wants read instead of fread, because fread doesn't respect */
+ /* RMS record boundaries. This is not necessarily a good thing to be */
+ /* doing, but we've got no other real choice - except avoid stdio
+ as implementation - perhaps write a :vms layer ?
+ */
+ fd = PerlIO_fileno(fp);
+ if (fd != -1) {
+ bytesread = PerlLIO_read(fd, buffer, recsize);
+ }
+ else /* in-memory file from PerlIO::Scalar */
+#endif
+ {
+ bytesread = PerlIO_read(fp, buffer, recsize);
+ }
+
+ if (bytesread < 0)
+ bytesread = 0;
+ SvCUR_set(sv, bytesread + append);
+ buffer[bytesread] = '\0';
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+
/*
=for apidoc sv_gets
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV * const tsv = newSV(0);
- sv_gets(tsv, fp, 0);
- sv_utf8_upgrade_nomg(tsv);
- SvCUR_set(sv,append);
- sv_catsv(sv,tsv);
- sv_free(tsv);
- goto return_string_or_null;
+ return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
}
}
rslen = 0;
}
else if (RsRECORD(PL_rs)) {
- 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. */
- buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
- /* Go yank in */
-#ifdef VMS
- /* VMS wants read instead of fread, because fread doesn't respect */
- /* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice - except avoid stdio
- as implementation - perhaps write a :vms layer ?
- */
- 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);
- buffer[bytesread] = '\0';
- goto return_string_or_null;
+ return S_sv_gets_read_record(aTHX_ sv, fp, append);
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
+ assert (!shortbuffered);
+ goto cannot_be_shortbuffered;
}
}
continue;
}
+ cannot_be_shortbuffered:
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
PTR2UV(ptr),(long)cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
-#if 0
- DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+ DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
-#endif
+
/* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
-#if 0
- DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+ DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
-#endif
+
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
}
else {
cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
- /* Accomodate broken VAXC compiler, which applies U8 cast to
+ /* Accommodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
if (cnt > 0)
}
}
-return_string_or_null:
return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
}
}
if (SvROK(sv)) {
IV i;
- if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
+ if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
return;
i = PTR2IV(SvRV(sv));
sv_unref(sv);
}
if (SvROK(sv)) {
IV i;
- if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
+ if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
return;
i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setpvn(sv,s,len);
/* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
- * and do what it does outselves here.
+ * and do what it does ourselves here.
* Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
* set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
* in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
- * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
+ * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
*/
SvFLAGS(sv) |= flags;
Andreas would like keys he put in as utf8 to come back as utf8
*/
STRLEN utf8_len = HEK_LEN(hek);
- const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
- SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
-
+ SV * const sv = newSV_type(SVt_PV);
+ char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+ /* bytes_to_utf8() allocates a new string, which we can repurpose: */
+ sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
- Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
return sv;
} else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
/* We don't have a pointer to the hv, so we have to replicate the
default:
if (SvROK(sv)) {
- SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
SvGETMAGIC(sv);
- tryAMAGICunDEREF(to_cv);
+ if (SvAMAGIC(sv))
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* At this point I'd like to do SPAGAIN, but really I need to
+ force it upon my callers. Hmmm. This is a mess... */
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
}
if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
|| isGV_with_GP(sv))
+ /* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
s = sv_2pv_flags(sv, &len, flags);
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
- * scalars for backwards compatitbility */
+ * scalars for backwards compatibility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
width = expect_number(&q);
}
- if (vectorize) {
- if (vectorarg) {
- if (args)
- vecsv = va_arg(*args, SV*);
- else if (evix) {
- vecsv = (evix > 0 && evix <= svmax)
- ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
- } else {
- vecsv = svix < svmax
- ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
- }
- dotstr = SvPV_const(vecsv, dotstrlen);
- /* Keep the DO_UTF8 test *after* the SvPV call, else things go
- bad with tied or overloaded values that return UTF8. */
- if (DO_UTF8(vecsv))
- is_utf8 = TRUE;
- else if (has_utf8) {
- vecsv = sv_mortalcopy(vecsv);
- sv_utf8_upgrade(vecsv);
- dotstr = SvPV_const(vecsv, dotstrlen);
- is_utf8 = TRUE;
- }
- }
- if (args) {
- VECTORIZE_ARGS
+ if (vectorize && vectorarg) {
+ /* vectorizing, but not with the default "." */
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else if (evix) {
+ vecsv = (evix > 0 && evix <= svmax)
+ ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
+ } else {
+ vecsv = svix < svmax
+ ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
}
- else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
- vecsv = svargs[efix ? efix-1 : svix++];
- vecstr = (U8*)SvPV_const(vecsv,veclen);
- vec_utf8 = DO_UTF8(vecsv);
-
- /* if this is a version object, we need to convert
- * back into v-string notation and then let the
- * vectorize happen normally
- */
- if (sv_derived_from(vecsv, "version")) {
- char *version = savesvpv(vecsv);
- if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "vector argument not supported with alpha versions");
- goto unknown;
- }
- vecsv = sv_newmortal();
- scan_vstring(version, version + veclen, vecsv);
- vecstr = (U8*)SvPV_const(vecsv, veclen);
- vec_utf8 = DO_UTF8(vecsv);
- Safefree(version);
- }
- }
- else {
- vecstr = (U8*)"";
- veclen = 0;
- }
- }
+ dotstr = SvPV_const(vecsv, dotstrlen);
+ /* Keep the DO_UTF8 test *after* the SvPV call, else things go
+ bad with tied or overloaded values that return UTF8. */
+ if (DO_UTF8(vecsv))
+ is_utf8 = TRUE;
+ else if (has_utf8) {
+ vecsv = sv_mortalcopy(vecsv);
+ sv_utf8_upgrade(vecsv);
+ dotstr = SvPV_const(vecsv, dotstrlen);
+ is_utf8 = TRUE;
+ }
+ }
if (asterisk) {
if (args)
}
}
+ if (vectorize) {
+ if (args) {
+ VECTORIZE_ARGS
+ }
+ else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
+ vecsv = svargs[efix ? efix-1 : svix++];
+ vecstr = (U8*)SvPV_const(vecsv,veclen);
+ vec_utf8 = DO_UTF8(vecsv);
+
+ /* if this is a version object, we need to convert
+ * back into v-string notation and then let the
+ * vectorize happen normally
+ */
+ if (sv_derived_from(vecsv, "version")) {
+ char *version = savesvpv(vecsv);
+ if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "vector argument not supported with alpha versions");
+ goto unknown;
+ }
+ vecsv = sv_newmortal();
+ scan_vstring(version, version + veclen, vecsv);
+ vecstr = (U8*)SvPV_const(vecsv, veclen);
+ vec_utf8 = DO_UTF8(vecsv);
+ Safefree(version);
+ }
+ }
+ else {
+ vecstr = (U8*)"";
+ veclen = 0;
+ }
+ }
+
/* SIZE */
switch (*q) {
break;
#endif
case 'l':
+ ++q;
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
- if (*(q + 1) == 'l') { /* lld, llf */
+ if (*q == 'l') { /* lld, llf */
intsize = 'q';
- q += 2;
- break;
- }
+ ++q;
+ }
+ else
#endif
- /*FALLTHROUGH*/
+ intsize = 'l';
+ break;
case 'h':
- /*FALLTHROUGH*/
+ if (*++q == 'h') { /* hhd, hhu */
+ intsize = 'c';
+ ++q;
+ }
+ else
+ intsize = 'h';
+ break;
case 'V':
+ case 'z':
+ case 't':
+#if HAS_C99
+ case 'j':
+#endif
intsize = *q++;
break;
}
}
else if (args) {
switch (intsize) {
+ case 'c': iv = (char)va_arg(*args, int); break;
case 'h': iv = (short)va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ case 'z': iv = va_arg(*args, SSize_t); break;
+ case 't': iv = va_arg(*args, ptrdiff_t); break;
default: iv = va_arg(*args, int); break;
+#if HAS_C99
+ case 'j': iv = va_arg(*args, intmax_t); break;
+#endif
case 'q':
#ifdef HAS_QUAD
iv = va_arg(*args, Quad_t); break;
else {
IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
+ case 'c': iv = (char)tiv; break;
case 'h': iv = (short)tiv; break;
case 'l': iv = (long)tiv; break;
case 'V':
}
else if (args) {
switch (intsize) {
+ case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ case 'z': uv = va_arg(*args, Size_t); break;
+ case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
+#if HAS_C99
+ case 'j': uv = va_arg(*args, uintmax_t); break;
+#endif
default: uv = va_arg(*args, unsigned); break;
case 'q':
#ifdef HAS_QUAD
else {
UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
+ case 'c': uv = (unsigned char)tuv; break;
case 'h': uv = (unsigned short)tuv; break;
case 'l': uv = (unsigned long)tuv; break;
case 'V':
#else
/*FALLTHROUGH*/
#endif
+ case 'c':
case 'h':
+ case 'z':
+ case 't':
+ case 'j':
goto unknown;
}
i = SvCUR(sv) - origlen;
if (args) {
switch (intsize) {
+ case 'c': *(va_arg(*args, char*)) = i; break;
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
+ case 'z': *(va_arg(*args, SSize_t*)) = i; break;
+ case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
+#if HAS_C99
+ case 'j': *(va_arg(*args, intmax_t*)) = i; break;
+#endif
case 'q':
#ifdef HAS_QUAD
*(va_arg(*args, Quad_t*)) = i; break;
/* duplicate a directory handle */
DIR *
-Perl_dirp_dup(pTHX_ DIR *const dp)
+Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
{
-#ifdef HAS_FCHDIR
DIR *ret;
+
+#ifdef HAS_FCHDIR
DIR *pwd;
register const Direntry_t *dirent;
char smallbuf[256];
#endif
PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_DIRP_DUP;
-#ifdef HAS_FCHDIR
if (!dp)
return (DIR*)NULL;
+
/* look for it in the table first */
ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
if (ret)
return ret;
+#ifdef HAS_FCHDIR
+
+ PERL_UNUSED_ARG(param);
+
/* create anew */
/* open the current directory (so we can switch back) */
if (name && name != smallbuf)
Safefree(name);
+#endif
+
+#ifdef WIN32
+ ret = win32_dirp_dup(dp, param);
+#endif
/* pop it in the pointer table */
- ptr_table_store(PL_ptr_table, dp, ret);
+ if (ret)
+ ptr_table_store(PL_ptr_table, dp, ret);
return ret;
-#else
- return (DIR*)NULL;
-#endif
}
/* duplicate a typeglob */
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* Not that normal - actually sstr is copy on write.
- But we are a true, independant SV, so: */
+ But we are a true, independent SV, so: */
SvREADONLY_off(dstr);
SvFAKE_off(dstr);
}
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
if (param->flags & CLONEf_JOIN_IN)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
- GvGP(dstr) = gp_dup(GvGP(sstr), param);
+ GvGP_set(dstr, gp_dup(GvGP(sstr), param));
(void)GpREFCNT_inc(GvGP(dstr));
}
break;
IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
if (IoDIRP(dstr)) {
- IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
+ IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
} else {
NOOP;
/* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
++i;
}
if (SvOOK(sstr)) {
- HEK *hvname;
const struct xpvhv_aux * const saux = HvAUX(sstr);
struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
/* SvOOK_on(hv) attacks the IV flags. */
SvFLAGS(dstr) |= SVf_OOK;
- hvname = saux->xhv_name;
- daux->xhv_name = hek_dup(hvname, param);
+ if (saux->xhv_name_count) {
+ HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
+ const I32 count
+ = saux->xhv_name_count < 0
+ ? -saux->xhv_name_count
+ : saux->xhv_name_count;
+ HEK **shekp = sname + count;
+ HEK **dhekp;
+ Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
+ dhekp = daux->xhv_name_u.xhvnameu_names + count;
+ while (shekp-- > sname) {
+ dhekp--;
+ *dhekp = hek_dup(*shekp, param);
+ }
+ }
+ else {
+ daux->xhv_name_u.xhvnameu_name
+ = hek_dup(saux->xhv_name_u.xhvnameu_name,
+ param);
+ }
+ daux->xhv_name_count = saux->xhv_name_count;
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
: 0;
/* Record stashes for possible cloning in Perl_clone(). */
- if (hvname)
+ if (HvNAME(sstr))
av_push(param->stashes, dstr);
}
}
/*FALLTHROUGH*/
case SVt_PVFM:
/* NOTE: not refcounted */
- CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
+ SvANY(MUTABLE_CV(dstr))->xcv_stash =
+ hv_dup(CvSTASH(dstr), param);
if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
- OP_REFCNT_LOCK;
- if (!CvISXSUB(dstr))
+ if (!CvISXSUB(dstr)) {
+ OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
- OP_REFCNT_UNLOCK;
- if (CvCONST(dstr) && CvISXSUB(dstr)) {
+ OP_REFCNT_UNLOCK;
+ CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ } else if (CvCONST(dstr)) {
CvXSUBANY(dstr).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
}
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
: cv_dup_inc(CvOUTSIDE(dstr), param);
- if (!CvISXSUB(dstr))
- CvFILE(dstr) = SAVEPV(CvFILE(dstr));
break;
}
}
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
+ actually being the same function, and order equivalence of
the two unions.
We can assert the later [but only at run time :-(] */
assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
TOPPTR(nss,ix) = pv_dup(c);
break;
case SAVEt_GP: /* scalar reference */
- gv = (const GV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
gp = (GP*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
+ gv = (const GV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
else
TOPPTR(nss,ix) = NULL;
break;
+ case SAVEt_FREECOPHH:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
+ break;
case SAVEt_DELETE:
hv = (const HV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
break;
case SAVEt_HINTS:
ptr = POPPTR(ss,ix);
- if (ptr) {
- HINTS_REFCNT_LOCK;
- ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
- HINTS_REFCNT_UNLOCK;
- }
+ ptr = cophh_copy((COPHH*)ptr);
TOPPTR(nss,ix) = ptr;
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
+ PL_defstash = NULL; /* may be used by perl malloc() */
PL_markstack = 0;
PL_scopestack = 0;
PL_scopestack_name = 0;
param->proto_perl = proto_perl;
/* Likely nothing will use this, but it is initialised to be consistent
with Perl_clone_params_new(). */
- param->proto_perl = my_perl;
+ param->new_perl = my_perl;
param->unreferenced = NULL;
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
PL_hash_seed = proto_perl->Ihash_seed;
PL_rehash_seed = proto_perl->Irehash_seed;
-#ifdef USE_REENTRANT_API
- /* XXX: things like -Dm will segfault here in perlio, but doing
- * PERL_SET_CONTEXT(proto_perl);
- * breaks too many other things
- */
- Perl_reentrant_init(aTHX);
-#endif
-
- /* create SV map for pointer relocation */
- PL_ptr_table = ptr_table_new();
-
- /* initialize these special pointers as early as possible */
SvANY(&PL_sv_undef) = NULL;
SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
-
- SvANY(&PL_sv_no) = new_XPVNV();
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
- SvCUR_set(&PL_sv_no, 0);
- SvLEN_set(&PL_sv_no, 1);
- SvIV_set(&PL_sv_no, 0);
- SvNV_set(&PL_sv_no, 0);
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
SvANY(&PL_sv_yes) = new_XPVNV();
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
- SvCUR_set(&PL_sv_yes, 1);
- SvLEN_set(&PL_sv_yes, 2);
- SvIV_set(&PL_sv_yes, 1);
- SvNV_set(&PL_sv_yes, 1);
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
/* dbargs array probably holds garbage */
PL_dbargs = NULL;
- /* create (a non-shared!) shared string table */
- PL_strtab = newHV();
- HvSHAREKEYS_off(PL_strtab);
- hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
- ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
-
PL_compiling = proto_perl->Icompiling;
- /* These two PVs will be free'd special way so must set them same way op.c does */
- PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
-
- PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
-
- ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
- if (PL_compiling.cop_hints_hash) {
- HINTS_REFCNT_LOCK;
- PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
- HINTS_REFCNT_UNLOCK;
- }
- PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
#ifdef PERL_DEBUG_READONLY_OPS
PL_slabs = NULL;
PL_slab_count = 0;
PL_origargc = proto_perl->Iorigargc;
PL_origargv = proto_perl->Iorigargv;
- param->stashes = newAV(); /* Setup array of objects to call clone on */
- /* This makes no difference to the implementation, as it always pushes
- and shifts pointers to other SVs without changing their reference
- count, with the array becoming empty before it is freed. However, it
- makes it conceptually clear what is going on, and will avoid some
- work inside av.c, filling slots between AvFILL() and AvMAX() with
- &PL_sv_undef, and SvREFCNT_dec()ing those. */
- AvREAL_off(param->stashes);
-
- if (!(flags & CLONEf_COPY_STACKS)) {
- param->unreferenced = newAV();
- }
-
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
PL_taint_warn = proto_perl->Itaint_warn;
-#ifdef PERLIO_LAYERS
- /* Clone PerlIO tables as soon as we can handle general xx_dup() */
- PerlIO_clone(aTHX_ proto_perl, param);
-#endif
-
- PL_envgv = gv_dup(proto_perl->Ienvgv, param);
- PL_incgv = gv_dup(proto_perl->Iincgv, param);
- PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
- PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
- PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
- PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
-
- /* switches */
PL_minus_c = proto_perl->Iminus_c;
- PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
- PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
+
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_minus_n = proto_perl->Iminus_n;
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
- PL_doextract = proto_perl->Idoextract;
PL_sawampersand = proto_perl->Isawampersand;
PL_unsafe = proto_perl->Iunsafe;
- PL_inplace = SAVEPV(proto_perl->Iinplace);
- PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
PL_exit_flags = proto_perl->Iexit_flags;
- /* magical thingies */
/* XXX time(&PL_basetime) when asked for? */
PL_basetime = proto_perl->Ibasetime;
- PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_statusvalue = proto_perl->Istatusvalue;
#else
PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
#endif
- PL_encoding = sv_dup(proto_perl->Iencoding, param);
-
- 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 */
Zero(&PL_reg_state, 1, struct re_save_state);
PL_reginterp_cnt = 0;
PL_regmatch_slab = NULL;
-
- /* Clone the regex array */
- /* ORANGE FIXME for plugins, probably in the SV dup code.
- newSViv(PTR2IV(CALLREGDUPE(
- INT2PTR(REGEXP *, SvIVX(regex)), param))))
- */
- PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
- PL_regex_pad = AvARRAY(PL_regex_padav);
-
- /* shortcuts to various I/O objects */
- 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);
- PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
- PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
- PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
-
- /* shortcuts to regexp stuff */
- PL_replgv = gv_dup(proto_perl->Ireplgv, param);
-
- /* shortcuts to misc objects */
- PL_errgv = gv_dup(proto_perl->Ierrgv, param);
-
- /* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv, param);
- PL_DBline = gv_dup(proto_perl->IDBline, param);
- PL_DBsub = gv_dup(proto_perl->IDBsub, param);
- PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
- PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
- PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
-
- /* symbol tables */
- PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
- PL_curstash = hv_dup(proto_perl->Icurstash, param);
- PL_debstash = hv_dup(proto_perl->Idebstash, param);
- PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
- PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
-
- PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
- PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
- PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
- PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
- PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
- PL_endav = av_dup_inc(proto_perl->Iendav, param);
- PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
- PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
- PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
/* funky return mechanisms */
PL_forkprocess = proto_perl->Iforkprocess;
- /* subprocess state */
- PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
-
/* internal state */
PL_maxo = proto_perl->Imaxo;
- if (proto_perl->Iop_mask)
- PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
- else
- PL_op_mask = NULL;
- /* PL_asserting = proto_perl->Iasserting; */
- /* current interpreter roots */
- PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
- OP_REFCNT_LOCK;
- PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
- OP_REFCNT_UNLOCK;
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_eval_start = proto_perl->Ieval_start;
- /* runtime control stuff */
- PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
-
PL_filemode = proto_perl->Ifilemode;
PL_lastfd = proto_perl->Ilastfd;
PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
PL_Argv = NULL;
PL_Cmd = NULL;
PL_gensym = proto_perl->Igensym;
- PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
+
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
PL_mess_sv = NULL;
- PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
+ PL_profiledata = NULL;
- /* interpreter atexit processing */
- PL_exitlistlen = proto_perl->Iexitlistlen;
- if (PL_exitlistlen) {
- Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
- Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
- }
- else
- PL_exitlist = (PerlExitListEntry*)NULL;
-
- PL_my_cxt_size = proto_perl->Imy_cxt_size;
- if (PL_my_cxt_size) {
- Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
- Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
-#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
- Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
-#endif
- }
- else {
- PL_my_cxt_list = (void**)NULL;
-#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- PL_my_cxt_keys = (const char**)NULL;
-#endif
- }
- PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
- PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
- PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
-
- PL_profiledata = NULL;
-
- PL_compcv = cv_dup(proto_perl->Icompcv, param);
-
- PAD_CLONE_VARS(proto_perl, param);
-
-#ifdef HAVE_INTERP_INTERN
- sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
-#endif
-
- /* more statics moved here */
- PL_generation = proto_perl->Igeneration;
- PL_DBcv = cv_dup(proto_perl->IDBcv, param);
+ PL_generation = proto_perl->Igeneration;
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
-#ifdef PERL_USES_PL_PIDSTATUS
- PL_pidstatus = newHV(); /* XXX flag for cloning? */
-#endif
- PL_osname = SAVEPV(proto_perl->Iosname);
+
PL_sighandlerp = proto_perl->Isighandlerp;
PL_runops = proto_perl->Irunops;
- PL_parser = parser_dup(proto_perl->Iparser, param);
-
- /* XXX this only works if the saved cop has already been cloned */
- if (proto_perl->Iparser) {
- PL_parser->saved_curcop = (COP*)any_dup(
- proto_perl->Iparser->saved_curcop,
- proto_perl);
- }
-
PL_subline = proto_perl->Isubline;
- PL_subname = sv_dup_inc(proto_perl->Isubname, param);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
- PL_collation_name = SAVEPV(proto_perl->Icollation_name);
PL_collation_standard = proto_perl->Icollation_standard;
PL_collxfrm_base = proto_perl->Icollxfrm_base;
PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
- /* utf8 character classes */
- PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
- PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
- PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
- PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
- PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
- PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
- PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
- PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
- PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
- PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
- PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
- PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
- PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
- PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
- PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
- PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
- PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
- PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
- PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
- PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
-
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
/* Unicode features (see perlrun/-C) */
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
+ if (flags & CLONEf_COPY_STACKS) {
+ /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
+ PL_tmps_ix = proto_perl->Itmps_ix;
+ PL_tmps_max = proto_perl->Itmps_max;
+ PL_tmps_floor = proto_perl->Itmps_floor;
+
+ /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+ * NOTE: unlike the others! */
+ PL_scopestack_ix = proto_perl->Iscopestack_ix;
+ PL_scopestack_max = proto_perl->Iscopestack_max;
+
+ /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+ * NOTE: unlike the others! */
+ PL_savestack_ix = proto_perl->Isavestack_ix;
+ PL_savestack_max = proto_perl->Isavestack_max;
+ }
+
+ PL_start_env = proto_perl->Istart_env; /* XXXXXX */
+ PL_top_env = &PL_start_env;
+
+ PL_op = proto_perl->Iop;
+
+ PL_Sv = NULL;
+ PL_Xpv = (XPV*)NULL;
+ my_perl->Ina = proto_perl->Ina;
+
+ PL_statbuf = proto_perl->Istatbuf;
+ PL_statcache = proto_perl->Istatcache;
+
+#ifdef HAS_TIMES
+ PL_timesbuf = proto_perl->Itimesbuf;
+#endif
+
+ PL_tainted = proto_perl->Itainted;
+ PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
+
+ PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
+
+ PL_restartjmpenv = proto_perl->Irestartjmpenv;
+ PL_restartop = proto_perl->Irestartop;
+ PL_in_eval = proto_perl->Iin_eval;
+ PL_delaymagic = proto_perl->Idelaymagic;
+ PL_phase = proto_perl->Iphase;
+ PL_localizing = proto_perl->Ilocalizing;
+
+ PL_hv_fetch_ent_mh = NULL;
+ PL_modcount = proto_perl->Imodcount;
+ PL_lastgotoprobe = NULL;
+ PL_dumpindent = proto_perl->Idumpindent;
+
+ PL_efloatbuf = NULL; /* reinits on demand */
+ PL_efloatsize = 0; /* reinits on demand */
+
+ /* regex stuff */
+
+ PL_screamfirst = NULL;
+ PL_screamnext = NULL;
+ PL_maxscream = -1; /* reinits on demand */
+ PL_lastscream = NULL;
+
+
+ PL_regdummy = proto_perl->Iregdummy;
+ PL_colorset = 0; /* reinits PL_colors[] */
+ /*PL_colors[6] = {0,0,0,0,0,0};*/
+
+ /* Pluggable optimizer */
+ PL_peepp = proto_perl->Ipeepp;
+ PL_rpeepp = proto_perl->Irpeepp;
+ /* op_free() hook */
+ PL_opfreehook = proto_perl->Iopfreehook;
+
+#ifdef USE_REENTRANT_API
+ /* XXX: things like -Dm will segfault here in perlio, but doing
+ * PERL_SET_CONTEXT(proto_perl);
+ * breaks too many other things
+ */
+ Perl_reentrant_init(aTHX);
+#endif
+
+ /* create SV map for pointer relocation */
+ PL_ptr_table = ptr_table_new();
+
+ /* initialize these special pointers as early as possible */
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+
+ SvANY(&PL_sv_no) = new_XPVNV();
+ SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 1);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+
+ SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 2);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+
+ /* create (a non-shared!) shared string table */
+ PL_strtab = newHV();
+ HvSHAREKEYS_off(PL_strtab);
+ hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
+ ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+
+ /* These two PVs will be free'd special way so must set them same way op.c does */
+ PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+
+ PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+
+ ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
+ PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
+
+ param->stashes = newAV(); /* Setup array of objects to call clone on */
+ /* This makes no difference to the implementation, as it always pushes
+ and shifts pointers to other SVs without changing their reference
+ count, with the array becoming empty before it is freed. However, it
+ makes it conceptually clear what is going on, and will avoid some
+ work inside av.c, filling slots between AvFILL() and AvMAX() with
+ &PL_sv_undef, and SvREFCNT_dec()ing those. */
+ AvREAL_off(param->stashes);
+
+ if (!(flags & CLONEf_COPY_STACKS)) {
+ param->unreferenced = newAV();
+ }
+
+#ifdef PERLIO_LAYERS
+ /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+ PerlIO_clone(aTHX_ proto_perl, param);
+#endif
+
+ PL_envgv = gv_dup(proto_perl->Ienvgv, param);
+ PL_incgv = gv_dup(proto_perl->Iincgv, param);
+ PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
+ PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
+ PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
+ PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+
+ /* switches */
+ PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
+ PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
+ PL_inplace = SAVEPV(proto_perl->Iinplace);
+ PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
+
+ /* magical thingies */
+ PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
+
+ PL_encoding = sv_dup(proto_perl->Iencoding, param);
+
+ 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. */
+
+
+ /* Clone the regex array */
+ /* ORANGE FIXME for plugins, probably in the SV dup code.
+ newSViv(PTR2IV(CALLREGDUPE(
+ INT2PTR(REGEXP *, SvIVX(regex)), param))))
+ */
+ PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
+ PL_regex_pad = AvARRAY(PL_regex_padav);
+
+ /* shortcuts to various I/O objects */
+ 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);
+ PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
+ PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
+
+ /* shortcuts to regexp stuff */
+ PL_replgv = gv_dup(proto_perl->Ireplgv, param);
+
+ /* shortcuts to misc objects */
+ PL_errgv = gv_dup(proto_perl->Ierrgv, param);
+
+ /* shortcuts to debugging objects */
+ PL_DBgv = gv_dup(proto_perl->IDBgv, param);
+ PL_DBline = gv_dup(proto_perl->IDBline, param);
+ PL_DBsub = gv_dup(proto_perl->IDBsub, param);
+ PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
+ PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
+ PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+
+ /* symbol tables */
+ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
+ PL_curstash = hv_dup(proto_perl->Icurstash, param);
+ PL_debstash = hv_dup(proto_perl->Idebstash, param);
+ PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
+ PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
+
+ PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
+ PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
+ PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
+ PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
+ PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
+ PL_endav = av_dup_inc(proto_perl->Iendav, param);
+ PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
+ PL_initav = av_dup_inc(proto_perl->Iinitav, param);
+
+ PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
+
+ /* subprocess state */
+ PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
+
+ if (proto_perl->Iop_mask)
+ PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
+ else
+ PL_op_mask = NULL;
+ /* PL_asserting = proto_perl->Iasserting; */
+
+ /* current interpreter roots */
+ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
+ OP_REFCNT_LOCK;
+ PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
+ OP_REFCNT_UNLOCK;
+
+ /* runtime control stuff */
+ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
+
+ PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
+
+ PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
+
+ /* interpreter atexit processing */
+ PL_exitlistlen = proto_perl->Iexitlistlen;
+ if (PL_exitlistlen) {
+ Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ }
+ else
+ PL_exitlist = (PerlExitListEntry*)NULL;
+
+ PL_my_cxt_size = proto_perl->Imy_cxt_size;
+ if (PL_my_cxt_size) {
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+ Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
+#endif
+ }
+ else {
+ PL_my_cxt_list = (void**)NULL;
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ PL_my_cxt_keys = (const char**)NULL;
+#endif
+ }
+ PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
+ PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
+ PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+ PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
+
+ PL_compcv = cv_dup(proto_perl->Icompcv, param);
+
+ PAD_CLONE_VARS(proto_perl, param);
+
+#ifdef HAVE_INTERP_INTERN
+ sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
+#endif
+
+ PL_DBcv = cv_dup(proto_perl->IDBcv, param);
+
+#ifdef PERL_USES_PL_PIDSTATUS
+ PL_pidstatus = newHV(); /* XXX flag for cloning? */
+#endif
+ PL_osname = SAVEPV(proto_perl->Iosname);
+ PL_parser = parser_dup(proto_perl->Iparser, param);
+
+ /* XXX this only works if the saved cop has already been cloned */
+ if (proto_perl->Iparser) {
+ PL_parser->saved_curcop = (COP*)any_dup(
+ proto_perl->Iparser->saved_curcop,
+ proto_perl);
+ }
+
+ PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+
+#ifdef USE_LOCALE_COLLATE
+ PL_collation_name = SAVEPV(proto_perl->Icollation_name);
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+ PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+#endif /* !USE_LOCALE_NUMERIC */
+
+ /* utf8 character classes */
+ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
+ PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
+ PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
+ PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
+ PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
+ PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
+ PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
+ PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
+ PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
+ PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
+ PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
+ PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
+ PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
+ PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
+ PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
+ PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
+ PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
+ PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
+ PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
+ PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
+ PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
+ PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
+ PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
+ PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
+ PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+ PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+ PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
+ PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+ PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
+ PL_utf8_foldable = hv_dup_inc(proto_perl->Iutf8_foldable, param);
+
+
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
}
PL_psig_name = (SV**)NULL;
}
- /* intrpvar.h stuff */
-
if (flags & CLONEf_COPY_STACKS) {
- /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
- PL_tmps_ix = proto_perl->Itmps_ix;
- PL_tmps_max = proto_perl->Itmps_max;
- PL_tmps_floor = proto_perl->Itmps_floor;
Newx(PL_tmps_stack, PL_tmps_max, SV*);
sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
PL_tmps_ix+1, param);
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
- PL_scopestack_ix = proto_perl->Iscopestack_ix;
- PL_scopestack_max = proto_perl->Iscopestack_max;
Newxz(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
- proto_perl->Istack_base);
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
- /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
- * NOTE: unlike the others! */
- PL_savestack_ix = proto_perl->Isavestack_ix;
- PL_savestack_max = proto_perl->Isavestack_max;
/*Newxz(PL_savestack, PL_savestack_max, ANY);*/
PL_savestack = ss_dup(proto_perl, param);
}
ENTER; /* perl_destruct() wants to LEAVE; */
}
- PL_start_env = proto_perl->Istart_env; /* XXXXXX */
- PL_top_env = &PL_start_env;
-
- PL_op = proto_perl->Iop;
-
- PL_Sv = NULL;
- PL_Xpv = (XPV*)NULL;
- my_perl->Ina = proto_perl->Ina;
-
- PL_statbuf = proto_perl->Istatbuf;
- PL_statcache = proto_perl->Istatcache;
PL_statgv = gv_dup(proto_perl->Istatgv, param);
PL_statname = sv_dup_inc(proto_perl->Istatname, param);
-#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Itimesbuf;
-#endif
- PL_tainted = proto_perl->Itainted;
- PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_rs = sv_dup_inc(proto_perl->Irs, param);
PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
- PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
- PL_restartjmpenv = proto_perl->Irestartjmpenv;
- PL_restartop = proto_perl->Irestartop;
- PL_in_eval = proto_perl->Iin_eval;
- PL_delaymagic = proto_perl->Idelaymagic;
- PL_dirty = proto_perl->Idirty;
- PL_localizing = proto_perl->Ilocalizing;
-
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
- PL_hv_fetch_ent_mh = NULL;
- PL_modcount = proto_perl->Imodcount;
- PL_lastgotoprobe = NULL;
- PL_dumpindent = proto_perl->Idumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
PL_sortstash = hv_dup(proto_perl->Isortstash, param);
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
- PL_efloatbuf = NULL; /* reinits on demand */
- PL_efloatsize = 0; /* reinits on demand */
-
- /* regex stuff */
-
- PL_screamfirst = NULL;
- PL_screamnext = NULL;
- PL_maxscream = -1; /* reinits on demand */
- PL_lastscream = NULL;
-
-
- PL_regdummy = proto_perl->Iregdummy;
- PL_colorset = 0; /* reinits PL_colors[] */
- /*PL_colors[6] = {0,0,0,0,0,0};*/
-
-
-
- /* Pluggable optimizer */
- PL_peepp = proto_perl->Ipeepp;
- PL_rpeepp = proto_perl->Irpeepp;
- /* op_free() hook */
- PL_opfreehook = proto_perl->Iopfreehook;
PL_stashcache = newHV();
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
+ PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
}
FREETMPS;
LEAVE;
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* clear pos and any utf8 cache */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg)
+ mg->mg_len = -1;
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
SvUTF8_on(sv);
return SvPVX(sv);
}
case OP_GVSV:
gv = cGVOPx_gv(obase);
- if (!gv || (match && GvSV(gv) != uninit_sv))
+ if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
break;
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (
+ /* @$a and %$a, but not @a or %a */
+ (type == OP_RV2AV || type == OP_RV2HV)
+ && cUNOPx(kid)->op_first
+ && cUNOPx(kid)->op_first->op_type != OP_GV
+ )
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff