register const SV * const svend = &sva[SvREFCNT(sva)];
register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
static void
do_report_used(pTHX_ SV *const sv)
{
- if (SvTYPE(sv) != SVTYPEMASK) {
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "****\n");
sv_dump(sv);
}
}
/* Void wrapper to pass to visit() */
-/* XXX
static void
do_curse(pTHX_ SV * const sv) {
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
return;
(void)curse(sv, 0);
}
-*/
/*
=for apidoc sv_clean_objs
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.... */
- /* XXX This line breaks Tk and Gtk2. See [perl #82542].
visit(do_curse, SVs_OBJECT, SVs_OBJECT);
- */
olddef = PL_defoutgv;
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
if (olddef && isGV_with_GP(olddef))
NOARENA /* IVS don't need an arena */, 0
},
- /* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(NV), sizeof(NV),
STRUCT_OFFSET(XPVNV, xnv_u),
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
- /* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 12 */
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PVIV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 20 */
{ sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PVNV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 28 */
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- /* something big */
{ sizeof(regexp),
sizeof(regexp),
0,
FIT_ARENA(0, sizeof(regexp))
},
- /* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
- /* 64 */
{ sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
SVt_PVHV, TRUE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPVHV)) },
- /* 56 */
{ sizeof(XPVCV),
sizeof(XPVCV),
0,
SVt_PVFM, TRUE, NONV, NOARENA,
FIT_ARENA(20, sizeof(XPVFM)) },
- /* XPVIO is 84 bytes, fits 48x */
{ sizeof(XPVIO),
sizeof(XPVIO),
0,
Upgrade an SV to a more complex form. Generally adds a new body type to the
SV, then copies across as much information as possible from the old body.
-You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
+It croaks if the SV is already in a more complex form than requested. You
+generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
+before calling C<sv_upgrade>, and hence does not croak. See also
+C<svtype>.
=cut
*/
if (DO_UTF8(sv)) {
dsv = newSVpvs_flags("", SVs_TEMP);
- pv = sv_uni_display(dsv, sv, 10, 0);
+ pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
Test if the content of an SV looks like a number (or is a number).
C<Inf> and C<Infinity> are treated as numbers (so will not issue a
-non-numeric warning), even if your atof() doesn't grok them.
+non-numeric warning), even if your atof() doesn't grok them. Get-magic is
+ignored.
=cut
*/
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
- if (SvPOK(sv)) {
- sbegin = SvPVX_const(sv);
- len = SvCUR(sv);
+ if (SvPOK(sv) || SvPOKp(sv)) {
+ sbegin = SvPV_nomg_const(sv, len);
}
- else if (SvPOKp(sv))
- sbegin = SvPV_const(sv, len);
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
return grok_number(sbegin, len, NULL);
STATIC bool
S_glob_2number(pTHX_ GV * const gv)
{
- const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
PERL_ARGS_ASSERT_GLOB_2NUMBER;
- /* FAKE globs can get coerced, so need to turn this off temporarily if it
- is on. */
- SvFAKE_off(gv);
gv_efullname3(buffer, gv, "*");
- SvFLAGS(gv) |= wasfake;
/* We know that all GVs stringify to something that is not-a-number,
so no need to test that. */
if (isGV_with_GP(sv))
return glob_2number(MUTABLE_GV(sv));
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!SvPADTMP(sv)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
}
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))
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))
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))
return 0.0;
}
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
assert (SvTYPE(sv) >= SVt_NV);
/* Typically the caller expects that sv_any is not NULL now. */
else {
if (isGV_with_GP(sv)) {
GV *const gv = MUTABLE_GV(sv);
- const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
- /* FAKE globs can get coerced, so need to turn this off temporarily
- if it is on. */
- SvFAKE_off(gv);
gv_efullname3(buffer, gv, "*");
- SvFLAGS(gv) |= wasfake;
- if (SvPOK(buffer)) {
- if (lp) {
+ assert(SvPOK(buffer));
+ if (lp) {
*lp = SvCUR(buffer);
- }
- return SvPVX(buffer);
- }
- else {
- if (lp)
- *lp = 0;
- return (char *)"";
}
+ if ( SvUTF8(buffer) ) SvUTF8_on(sv);
+ return SvPVX(buffer);
}
if (lp)
*lp = 0;
if (flags & SV_UNDEF_RETURNS_NULL)
return NULL;
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
/* utf8 conversion not needed because all are invariants. Mark as
* UTF-8 even if no variant - saves scanning loop */
SvUTF8_on(sv);
+ if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
must_be_utf8:
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
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
- gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
+ gv_name_set(MUTABLE_GV(dstr), name, len,
+ GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
SvFAKE_on(dstr); /* can coerce to non-glob */
}
mro_changes = 1;
}
- /* We don’t need to check the name of the destination if it was not a
+ /* We don't need to check the name of the destination if it was not a
glob to begin with. */
if(dtype == SVt_PVGV) {
const char * const name = GvNAME((const GV *)dstr);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
(const char *)
(CvCONST(cv)
- ? "Constant subroutine %s::%s redefined"
- : "Subroutine %s::%s redefined"),
- HvNAME_get(GvSTASH((const GV *)dstr)),
- GvENAME(MUTABLE_GV(dstr)));
+ ? "Constant subroutine %"HEKf
+ "::%"HEKf" redefined"
+ : "Subroutine %"HEKf"::%"HEKf
+ " redefined"),
+ HEKfARG(
+ HvNAME_HEK(GvSTASH((const GV *)dstr))
+ ),
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))));
}
}
if (!intro)
- cv_ckproto_len(cv, (const GV *)dstr,
- SvPOK(sref) ? SvPVX_const(sref) : NULL,
- SvPOK(sref) ? SvCUR(sref) : 0);
+ cv_ckproto_len_flags(cv, (const GV *)dstr,
+ SvPOK(sref) ? CvPROTO(sref) : NULL,
+ SvPOK(sref) ? CvPROTOLEN(sref) : 0,
+ SvPOK(sref) ? SvUTF8(sref) : 0);
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
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
+ 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);
/* case SVt_BIND: */
case SVt_PVLV:
case SVt_PVGV:
- /* SvVALID means that this PVGV is playing at being an FBM. */
-
case SVt_PVMG:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
SvCUR_set(dstr, len);
SvPOK_only(dstr);
SvFLAGS(dstr) |= sflags & SVf_UTF8;
+ CvAUTOLOAD_off(dstr);
} else {
SvOK_off(dstr);
}
"Undefined value assigned to typeglob");
}
else {
- GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
+ GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
if (dstr != (const SV *)gv) {
const char * const name = GvNAME((const GV *)dstr);
const STRLEN len = GvNAMELEN(dstr);
}
else {
if (isGV_with_GP(sstr)) {
- /* This stringification rule for globs is spread in 3 places.
- This feels bad. FIXME. */
- const U32 wasfake = sflags & SVf_FAKE;
-
- /* FAKE globs can get coerced, so need to turn this off
- temporarily if it is on. */
- SvFAKE_off(sstr);
gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
- SvFLAGS(sstr) |= wasfake;
}
else
(void)SvOK_off(dstr);
SvCUR_set(sv, len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
}
/*
SvCUR_set(sv, len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
}
/*
SvSETMAGIC(sv);
}
+void
+Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETHEK;
+
+ if (!hek) {
+ return;
+ }
+
+ if (HEK_LEN(hek) == HEf_SVKEY) {
+ sv_setsv(sv, *(SV**)HEK_KEY(hek));
+ return;
+ } else {
+ const int flags = HEK_FLAGS(hek);
+ if (flags & HVhek_WASUTF8) {
+ STRLEN utf8_len = HEK_LEN(hek);
+ char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
+ sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
+ SvUTF8_on(sv);
+ return;
+ } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
+ sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ else SvUTF8_off(sv);
+ return;
+ }
+ {
+ SvUPGRADE(sv, SVt_PV);
+ sv_usepvn_flags(sv, (char *)HEK_KEY(share_hek_hek(hek)), HEK_LEN(hek), SV_HAS_TRAILING_NUL);
+ SvLEN_set(sv, 0);
+ SvREADONLY_on(sv);
+ SvFAKE_on(sv);
+ SvPOK_on(sv);
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ else SvUTF8_off(sv);
+ return;
+ }
+ }
+}
+
+
/*
=for apidoc sv_usepvn_flags
}
#else
if (SvREADONLY(sv)) {
- if (SvFAKE(sv)) {
+ if (SvFAKE(sv) && !isGV_with_GP(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
string. Uses the "OOK hack".
+
Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
refer to the same chunk of data.
+The unfortunate similarity of this function's name to that of Perl's C<chop>
+operator is strictly coincidental. This function works from the left;
+C<chop> works from the right.
+
=cut
*/
STRLEN old_delta;
U8 *p;
#ifdef DEBUGGING
- const U8 *real_start;
+ const U8 *evacp;
+ STRLEN evacn;
#endif
STRLEN max_delta;
/* Nothing to do. */
return;
}
- /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
- nothing uses the value of ptr any more. */
max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
- if (ptr <= SvPVX_const(sv))
+ if (delta > max_delta)
Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
+ /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
SV_CHECK_THINKFIRST(sv);
- if (delta > max_delta)
- Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
- SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
- SvPVX_const(sv) + max_delta);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
p = (U8 *)SvPVX_const(sv);
- delta += old_delta;
-
#ifdef DEBUGGING
- real_start = p - delta;
+ /* how many bytes were evacuated? we will fill them with sentinel
+ bytes, except for the part holding the new offset of course. */
+ evacn = delta;
+ if (old_delta)
+ evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
+ assert(evacn);
+ assert(evacn <= delta + old_delta);
+ evacp = p - evacn;
#endif
+ delta += old_delta;
assert(delta);
if (delta < 0x100) {
*--p = (U8) delta;
#ifdef DEBUGGING
/* Fill the preceding buffer with sentinals to verify that no-one is
using it. */
- while (p > real_start) {
+ while (p > evacp) {
--p;
*p = (U8)PTR2UV(p);
}
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
+ assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
- SvGROW(dsv, dlen + slen + 1);
- if (sstr == dstr)
+ if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
+ if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
+ sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
+ dlen = SvCUR(dsv);
+ }
+ else SvGROW(dsv, dlen + slen + 1);
+ if (sstr == dstr)
sstr = SvPVX_const(dsv);
- Move(sstr, SvPVX(dsv) + dlen, slen, char);
- SvCUR_set(dsv, SvCUR(dsv) + slen);
+ Move(sstr, SvPVX(dsv) + dlen, slen, char);
+ SvCUR_set(dsv, SvCUR(dsv) + slen);
+ }
+ else {
+ /* We inline bytes_to_utf8, to avoid an extra malloc. */
+ const char * const send = sstr + slen;
+ U8 *d;
+
+ /* Something this code does not account for, which I think is
+ impossible; it would require the same pv to be treated as
+ bytes *and* utf8, which would indicate a bug elsewhere. */
+ assert(sstr != dstr);
+
+ SvGROW(dsv, dlen + slen * 2 + 1);
+ d = (U8 *)SvPVX(dsv) + dlen;
+
+ while (sstr < send) {
+ const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
+ if (UNI_IS_INVARIANT(uv))
+ *d++ = (U8)UTF_TO_NATIVE(uv);
+ else {
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
+ }
+ }
+ SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
+ }
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
STRLEN 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
- Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
- dsv->sv_flags doesn't have that bit set.
- Andy Dougherty 12 Oct 2001
- */
- const I32 sutf8 = DO_UTF8(ssv);
- I32 dutf8;
-
if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
mg_get(dsv);
- dutf8 = DO_UTF8(dsv);
-
- if (dutf8 != sutf8) {
- if (dutf8) {
- /* Not modifying source SV, so taking a temporary copy. */
- SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
-
- sv_utf8_upgrade(csv);
- spv = SvPV_const(csv, slen);
- }
- else
- /* Leave enough space for the cat that's about to happen */
- sv_utf8_upgrade_flags_grow(dsv, 0, slen);
- }
- sv_catpvn_nomg(dsv, spv, slen);
+ sv_catpvn_flags(dsv, spv, slen,
+ DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
}
}
if (flags & SV_SMAGIC)
In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
parameter, I<x>, a debug aid which allowed callers to identify themselves.
This aid has been superseded by a new build option, PERL_MEM_LOG (see
-L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
+L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
modules supporting older perls.
=cut
dVAR;
const MGVTBL *vtable;
MAGIC* mg;
+ unsigned int flags;
+ unsigned int vtable_index;
PERL_ARGS_ASSERT_SV_MAGIC;
+ if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
+ || ((flags = PL_magic_data[how]),
+ (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
+ > magic_vtable_max))
+ Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
+
+ /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
+ Useful for attaching extension internal data to perl vars.
+ Note that multiple extensions may clash if magical scalars
+ etc holding private data from one are passed to another. */
+
+ vtable = (vtable_index == magic_vtable_max)
+ ? NULL : PL_magic_vtables + vtable_index;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
!(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
&& IN_PERL_RUNTIME
- && how != PERL_MAGIC_regex_global
- && how != PERL_MAGIC_bm
- && how != PERL_MAGIC_fm
- && how != PERL_MAGIC_sv
- && how != PERL_MAGIC_backref
+ && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
Perl_croak_no_modify(aTHX);
}
}
- switch (how) {
- case PERL_MAGIC_sv:
- vtable = &PL_vtbl_sv;
- break;
- case PERL_MAGIC_overload:
- vtable = &PL_vtbl_amagic;
- break;
- case PERL_MAGIC_overload_elem:
- vtable = &PL_vtbl_amagicelem;
- break;
- 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_regdatum:
- vtable = &PL_vtbl_regdatum;
- 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_regex_global:
- vtable = &PL_vtbl_mglob;
- break;
- case PERL_MAGIC_isa:
- vtable = &PL_vtbl_isa;
- break;
- case PERL_MAGIC_isaelem:
- vtable = &PL_vtbl_isaelem;
- 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;
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
- vtable = &PL_vtbl_collxfrm;
- break;
-#endif /* USE_LOCALE_COLLATE */
- case PERL_MAGIC_tied:
- vtable = &PL_vtbl_pack;
- break;
- case PERL_MAGIC_tiedelem:
- case PERL_MAGIC_tiedscalar:
- vtable = &PL_vtbl_packelem;
- break;
- case PERL_MAGIC_qr:
- vtable = &PL_vtbl_regexp;
- break;
- case PERL_MAGIC_sig:
- vtable = &PL_vtbl_sig;
- break;
- case PERL_MAGIC_sigelem:
- vtable = &PL_vtbl_sigelem;
- break;
- case PERL_MAGIC_taint:
- vtable = &PL_vtbl_taint;
- break;
- case PERL_MAGIC_uvar:
- vtable = &PL_vtbl_uvar;
- break;
- case PERL_MAGIC_vec:
- vtable = &PL_vtbl_vec;
- break;
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_checkcall:
- vtable = NULL;
- break;
- case PERL_MAGIC_utf8:
- vtable = &PL_vtbl_utf8;
- break;
- case PERL_MAGIC_substr:
- vtable = &PL_vtbl_substr;
- break;
- case PERL_MAGIC_defelem:
- vtable = &PL_vtbl_defelem;
- break;
- case PERL_MAGIC_arylen:
- vtable = &PL_vtbl_arylen;
- break;
- case PERL_MAGIC_pos:
- vtable = &PL_vtbl_pos;
- break;
- case PERL_MAGIC_backref:
- vtable = &PL_vtbl_backref;
- break;
- case PERL_MAGIC_hintselem:
- vtable = &PL_vtbl_hintselem;
- break;
- case PERL_MAGIC_hints:
- vtable = &PL_vtbl_hints;
- break;
- case PERL_MAGIC_ext:
- /* Reserved for use by extensions not perl internals. */
- /* Useful for attaching extension internal data to perl vars. */
- /* Note that multiple extensions may clash if magical scalars */
- /* etc holding private data from one are passed to another. */
- vtable = NULL;
- break;
- default:
- Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
- }
-
/* Rest of work is done else where */
mg = sv_magicext(sv,obj,how,vtable,name,namlen);
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
+ else if (SvREADONLY(sv)) croak_no_modify();
tsv = SvRV(sv);
Perl_sv_add_backref(aTHX_ tsv, sv);
SvWEAKREF_on(sv);
* 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))))
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;
register char *mid;
register char *midend;
register char *bigend;
- register I32 i;
+ register SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
STRLEN curlen;
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
STATIC void
S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
{
- char *stash;
SV *gvname;
GV *anongv;
}
/* if not, anonymise: */
- stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
- ? HvENAME(GvSTASH(gv)) : NULL;
- gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
- stash ? stash : "__ANON__");
+ gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
+ ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
+ : newSVpvn_flags( "__ANON__", 8, 0 );
+ sv_catpvs(gvname, "::__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
SvREFCNT_dec(gvname);
SV* iter_sv = NULL;
SV* next_sv = NULL;
register SV *sv = orig_sv;
+ STRLEN hash_index;
PERL_ARGS_ASSERT_SV_CLEAR;
type = SvTYPE(sv);
assert(SvREFCNT(sv) == 0);
- assert(SvTYPE(sv) != SVTYPEMASK);
+ assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
if (type <= SVt_IV) {
/* See the comment in sv.h about the collusion between this
goto free_head;
}
- if (SvOBJECT(sv)) {
- if (!curse(sv, 1)) goto get_next_sv;
- }
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+
if (type >= SVt_PVMG) {
+ if (SvOBJECT(sv)) {
+ if (!curse(sv, 1)) goto get_next_sv;
+ type = SvTYPE(sv); /* destructor may have changed it */
+ }
/* Free back-references before magic, in case the magic calls
* Perl code that has weak references to sv. */
- if (type == SVt_PVHV)
+ if (type == SVt_PVHV) {
Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
- if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ }
+ else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(SvOURSTASH(sv));
} else if (SvMAGIC(sv)) {
/* Free back-references before other types of magic. */
if (PL_last_swash_hv == (const HV *)sv) {
PL_last_swash_hv = NULL;
}
+ 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,
+ HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : 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:
{
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 && !HvTOTALKEYS((HV *)iter_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: */
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 created new reference to dead object '%"HEKf"'",
+ HEKfARG(HvNAME_HEK(stash)));
/* DESTROY gave object new lease on life */
return FALSE;
}
const char *pv2;
STRLEN cur2;
I32 eq = 0;
- char *tpv = NULL;
SV* svrecode = NULL;
if (!sv1) {
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
SvREFCNT_dec(svrecode);
- if (tpv)
- Safefree(tpv);
return eq;
}
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv))
+ if (SvIsCOW(sv) || isGV_with_GP(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv))
+ if (SvIsCOW(sv) || isGV_with_GP(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
into an hv routine with a regular hash.
Similarly, a hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
- share_hek_kek on it. */
+ share_hek_hek on it. */
SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
if (!old)
return NULL;
- if (SvTYPE(old) == SVTYPEMASK) {
+ if (SvTYPE(old) == (svtype)SVTYPEMASK) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
gv = MUTABLE_GV(sv);
io = GvIO(gv);
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
+ HEKfARG(GvNAME_HEK(gv)));
break;
}
/* FALL THROUGH */
*st = NULL;
*gvp = NULL;
return NULL;
- case SVt_PVGV:
- if (isGV_with_GP(sv)) {
- gv = MUTABLE_GV(sv);
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
- }
- /* FALL THROUGH */
-
default:
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- SvGETMAGIC(sv);
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
Perl_croak(aTHX_ "Not a subroutine reference");
}
else if (isGV_with_GP(sv)) {
- SvGETMAGIC(sv);
gv = MUTABLE_GV(sv);
}
- else
- gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
+ else {
+ gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
+ }
*gvp = gv;
if (!gv) {
*st = NULL;
return NULL;
}
*st = GvESTASH(gv);
- fix_gv:
- if (lref && !GvCVu(gv)) {
+ if (lref & ~GV_ADDMG && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
tmpsv = newSV(0);
Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
{
PERL_ARGS_ASSERT_SV_REFTYPE;
-
- /* The fact that I don't need to downcast to char * everywhere, only in ?:
- inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char * const name = HvNAME_get(SvSTASH(sv));
- return name ? name : (char *) "__ANON__";
+ return SvPV_nolen_const(sv_ref(NULL, sv, ob));
}
else {
switch (SvTYPE(sv)) {
}
/*
+=for apidoc sv_ref
+
+Returns a SV describing what the SV passed in is a reference to.
+
+=cut
+*/
+
+SV *
+Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
+{
+ PERL_ARGS_ASSERT_SV_REF;
+
+ if (!dst)
+ dst = sv_newmortal();
+
+ if (ob && SvOBJECT(sv)) {
+ HvNAME_get(SvSTASH(sv))
+ ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
+ : sv_setpvn(dst, "__ANON__", 8);
+ }
+ else {
+ const char * reftype = sv_reftype(sv, 0);
+ sv_setpv(dst, reftype);
+ }
+ return dst;
+}
+
+/*
=for apidoc sv_isobject
Returns a boolean indicating whether the SV is an RV pointing to a blessed
return sv;
}
-/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
+/* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
* as it is after unglobbing it.
*/
=for apidoc sv_untaint
Untaint an SV. Use C<SvTAINTED_off> instead.
+
=cut
*/
=for apidoc sv_tainted
Test an SV for taintedness. Use C<SvTAINTED> instead.
+
=cut
*/
%p include pointer address (standard)
%-p (SVf) include an SV (previously %_)
%-<num>p include an SV with precision <num>
- %<num>p reserved for future extensions
+ %2p include a HEK
+ %3p include a HEK with precision of 256
+ %<num>p (where num != 2 or 3) reserved for future
+ extensions
- Robin Barker 2005-07-14
+ Robin Barker 2005-07-14 (but modified since)
%1p (VDf) removed. RMB 2007-10-19
*/
is_utf8 = TRUE;
goto string;
}
+ else if (n==2 || n==3) { /* HEKf */
+ HEK * const hek = va_arg(*args, HEK *);
+ eptr = HEK_KEY(hek);
+ elen = HEK_LEN(hek);
+ if (HEK_UTF8(hek)) is_utf8 = TRUE;
+ if (n==3) precis = 256, has_precis = TRUE;
+ goto string;
+ }
else if (n) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"internal %%<num>p might conflict with future printf extensions");
PERL_ARGS_ASSERT_SV_DUP_COMMON;
- if (SvTYPE(sstr) == SVTYPEMASK) {
+ if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
#ifdef DEBUG_LEAKING_SCALARS_ABORT
abort();
#endif
const HEK * const hvname = HvNAME_HEK(sstr);
if (hvname) {
/** don't clone stashes if they already exist **/
- dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+ HEK_UTF8(hvname) ? SVf_UTF8 : 0));
ptr_table_store(PL_ptr_table, sstr, dstr);
return dstr;
}
OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(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);
}
+ if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
SvANY(MUTABLE_CV(dstr))->xcv_gv =
TOPLONG(nss,ix) = longval;
break;
case SAVEt_I32: /* I32 reference */
- case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
i = POPINT(ss,ix);
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;
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);
- CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
- 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_dowarn = proto_perl->Idowarn;
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_sub_generation = proto_perl->Isub_generation;
+
+ /* funky return mechanisms */
+ PL_forkprocess = proto_perl->Iforkprocess;
+
+ /* internal state */
+ PL_maxo = proto_perl->Imaxo;
+
+ PL_main_start = proto_perl->Imain_start;
+ PL_eval_root = proto_perl->Ieval_root;
+ PL_eval_start = proto_perl->Ieval_start;
+
+ 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_laststatval = proto_perl->Ilaststatval;
+ PL_laststype = proto_perl->Ilaststype;
+ PL_mess_sv = NULL;
+
+ PL_profiledata = NULL;
+
+ PL_generation = proto_perl->Igeneration;
+
+ PL_in_clean_objs = proto_perl->Iin_clean_objs;
+ PL_in_clean_all = proto_perl->Iin_clean_all;
+
+ PL_uid = proto_perl->Iuid;
+ PL_euid = proto_perl->Ieuid;
+ PL_gid = proto_perl->Igid;
+ PL_egid = proto_perl->Iegid;
+ PL_nomemok = proto_perl->Inomemok;
+ PL_an = proto_perl->Ian;
+ PL_evalseq = proto_perl->Ievalseq;
+ PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
+ PL_origalen = proto_perl->Iorigalen;
+
+ PL_sighandlerp = proto_perl->Isighandlerp;
+
+ PL_runops = proto_perl->Irunops;
+
+ PL_subline = proto_perl->Isubline;
+
+#ifdef FCRYPT
+ PL_cryptseen = proto_perl->Icryptseen;
+#endif
+
+ PL_hints = proto_perl->Ihints;
+
+ PL_amagic_generation = proto_perl->Iamagic_generation;
+
+#ifdef USE_LOCALE_COLLATE
+ PL_collation_ix = proto_perl->Icollation_ix;
+ 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_standard = proto_perl->Inumeric_standard;
+ PL_numeric_local = proto_perl->Inumeric_local;
+#endif /* !USE_LOCALE_NUMERIC */
+
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
+
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
+
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
+
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+
+ /* Not really needed/useful since the reenrant_retint is "volatile",
+ * but do it for consistency's sake. */
+ PL_reentrant_retint = proto_perl->Ireentrant_retint;
+
+ /* Hooks to shared SVs and locks. */
+ PL_sharehook = proto_perl->Isharehook;
+ PL_lockhook = proto_perl->Ilockhook;
+ PL_unlockhook = proto_perl->Iunlockhook;
+ PL_threadhook = proto_perl->Ithreadhook;
+ PL_destroyhook = proto_perl->Idestroyhook;
+ PL_signalhook = proto_perl->Isignalhook;
+
+ PL_globhook = proto_perl->Iglobhook;
+
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = proto_perl->Ippid;
+#endif
+
+ /* swatch cache */
+ PL_last_swash_hv = NULL; /* reinits on demand */
+ PL_last_swash_klen = 0;
+ PL_last_swash_key[0]= '\0';
+ PL_last_swash_tmps = (U8*)NULL;
+ PL_last_swash_slen = 0;
+
+ 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_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);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
- PL_curstash = hv_dup(proto_perl->Icurstash, param);
+ PL_curstash = hv_dup_inc(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_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
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_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
- PL_profiledata = NULL;
-
PL_compcv = cv_dup(proto_perl->Icompcv, param);
PAD_CLONE_VARS(proto_perl, param);
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_in_clean_objs = proto_perl->Iin_clean_objs;
- PL_in_clean_all = proto_perl->Iin_clean_all;
-
- PL_uid = proto_perl->Iuid;
- PL_euid = proto_perl->Ieuid;
- PL_gid = proto_perl->Igid;
- PL_egid = proto_perl->Iegid;
- PL_nomemok = proto_perl->Inomemok;
- PL_an = proto_perl->Ian;
- 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 */
proto_perl);
}
- PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
-#ifdef FCRYPT
- PL_cryptseen = proto_perl->Icryptseen;
-#endif
-
- PL_hints = proto_perl->Ihints;
-
- PL_amagic_generation = proto_perl->Iamagic_generation;
-
#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_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_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, 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);
-
- /* Did the locale setup indicate UTF-8? */
- PL_utf8locale = proto_perl->Iutf8locale;
- /* Unicode features (see perlrun/-C) */
- PL_unicode = proto_perl->Iunicode;
-
- /* Pre-5.8 signals control */
- PL_signals = proto_perl->Isignals;
-
- /* times() ticks per second */
- PL_clocktick = proto_perl->Iclocktick;
+ PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
- /* Recursion stopper for PerlIO_find_layer */
- PL_in_load_module = proto_perl->Iin_load_module;
-
- /* sort() routine */
- PL_sort_RealCmp = proto_perl->Isort_RealCmp;
-
- /* Not really needed/useful since the reenrant_retint is "volatile",
- * but do it for consistency's sake. */
- PL_reentrant_retint = proto_perl->Ireentrant_retint;
-
- /* Hooks to shared SVs and locks. */
- PL_sharehook = proto_perl->Isharehook;
- PL_lockhook = proto_perl->Ilockhook;
- PL_unlockhook = proto_perl->Iunlockhook;
- PL_threadhook = proto_perl->Ithreadhook;
- PL_destroyhook = proto_perl->Idestroyhook;
- PL_signalhook = proto_perl->Isignalhook;
-
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = proto_perl->Ippid;
-#endif
-
- /* swatch cache */
- PL_last_swash_hv = NULL; /* reinits on demand */
- PL_last_swash_klen = 0;
- PL_last_swash_key[0]= '\0';
- PL_last_swash_tmps = (U8*)NULL;
- PL_last_swash_slen = 0;
-
- PL_glob_index = proto_perl->Iglob_index;
- PL_srand_called = proto_perl->Isrand_called;
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_phase = proto_perl->Iphase;
- 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();
return NULL;
av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
sv = *av_fetch(av, targ, FALSE);
- sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
+ sv_setsv(name, sv);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
keysv, index, subscript_type);
}
+ case OP_RV2SV:
+ if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+ /* $global */
+ gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+ if (!gv || !GvSTASH(gv))
+ break;
+ if (match && (GvSV(gv) != uninit_sv))
+ break;
+ return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ }
+ /* ${expr} */
+ return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
+
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
break;
break;
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
- case OP_AELEMFAST:
- if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
- if (match) {
- SV **svp;
- AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
- if (!av || SvRMAGICAL(av))
- break;
- svp = av_fetch(av, (I32)obase->op_private, FALSE);
- if (!svp || *svp != uninit_sv)
- break;
- }
- return varname(NULL, '$', obase->op_targ,
- NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ case OP_AELEMFAST_LEX:
+ if (match) {
+ SV **svp;
+ AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
+ if (!av || SvRMAGICAL(av))
+ break;
+ svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
}
- else {
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ case OP_AELEMFAST:
+ {
gv = cGVOPx_gv(obase);
if (!gv)
break;
case OP_AELEM:
case OP_HELEM:
+ {
+ bool negate = FALSE;
+
if (PL_op == obase)
/* $a[uninit_expr] or $h{uninit_expr} */
return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
if (!sv)
break;
+ if (kid && kid->op_type == OP_NEGATE) {
+ negate = TRUE;
+ kid = cUNOPx(kid)->op_first;
+ }
+
if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
/* index is constant */
+ SV* kidsv;
+ if (negate) {
+ kidsv = sv_2mortal(newSVpvs("-"));
+ sv_catsv(kidsv, cSVOPx_sv(kid));
+ }
+ else
+ kidsv = cSVOPx_sv(kid);
if (match) {
if (SvMAGICAL(sv))
break;
if (obase->op_type == OP_HELEM) {
- HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
if (!he || HeVAL(he) != uninit_sv)
break;
}
else {
- SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(sv),
+ negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+ FALSE);
if (!svp || *svp != uninit_sv)
break;
}
}
if (obase->op_type == OP_HELEM)
return varname(gv, '%', o->op_targ,
- cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+ kidsv, 0, FUV_SUBSCRIPT_HASH);
else
return varname(gv, '@', o->op_targ, NULL,
- SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
+ negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+ FUV_SUBSCRIPT_ARRAY);
}
else {
/* index is an expression;
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
break;
+ }
case OP_AASSIGN:
/* only examine RHS */
case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
- case OP_RV2SV:
case OP_CUSTOM: /* XS or custom code could trigger random warnings */
/* the following ops are capable of returning PL_sv_undef even for
dVAR;
if (PL_op) {
SV* varname = NULL;
- if (uninit_sv) {
+ if (uninit_sv && PL_curpad) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- varname ? SvPV_nolen_const(varname) : "",
+ /* diag_listed_as: Use of uninitialized value%s */
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
+ SVfARG(varname ? varname : &PL_sv_no),
" in ", OP_DESC(PL_op));
}
else
https://perl5.git.perl.org / perl5.git / blobdiff