#endif
#ifdef DEBUG_LEAKING_SCALARS
-# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
+# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
+ if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+ } STMT_END
# define DEBUG_SV_SERIAL(sv) \
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
PTR2UV(sv), (long)(sv)->sv_debug_serial))
);
sv->sv_debug_inpad = 0;
sv->sv_debug_parent = NULL;
- sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
sv->sv_debug_serial = PL_sv_serial++;
{
dVAR;
SV *const sva = MUTABLE_SV(ptr);
- register SV* sv;
- register SV* svend;
+ SV* sv;
+ SV* svend;
PERL_ARGS_ASSERT_SV_ADD_ARENA;
PERL_ARGS_ASSERT_VISIT;
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
- register const SV * const svend = &sva[SvREFCNT(sva)];
- register SV* sv;
+ const SV * const svend = &sva[SvREFCNT(sva)];
+ SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != (svtype)SVTYPEMASK
&& (sv->sv_flags & mask) == flags
no longer need to unshare so as to free up the IVX slot for its proper
purpose. So it's safe to move the early return earlier. */
- if (new_type != SVt_PV && SvIsCOW(sv)) {
+ if (new_type > SVt_PVMG && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
}
break;
-
- case SVt_REGEXP:
- /* This ensures that SvTHINKFIRST(sv) is true, and hence that
- sv_force_normal_flags(sv) is called. */
- SvFAKE_on(sv);
case SVt_PVIV:
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
name */
+ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
hv_clear(PL_stashcache);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (old_type < SVt_PV) {
+ if (new_type == SVt_REGEXP)
+ sv->sv_u.svu_rx = (regexp *)new_body;
+ else if (old_type < SVt_PV) {
/* referant will be NULL unless the old type was SVt_IV emulating
SVt_RV */
sv->sv_u.svu_rv = referant;
char *
Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
{
- register char *s;
+ char *s;
PERL_ARGS_ASSERT_SV_GROW;
I32
Perl_looks_like_number(pTHX_ SV *const sv)
{
- register const char *sbegin;
+ const char *sbegin;
STRLEN len;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
SvUVX(sv)));
}
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV * tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
+ }
+
+ if (SvVALID(sv) || isREGEXP(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.
+
+ Regexps have no SvIVX and SvNVX fields.
*/
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvIOKp(sv))
- return SvIVX(sv);
- if (SvNOKp(sv)) {
- return I_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv)) {
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return I_V(Atof(SvPVX_const(sv)));
- }
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV * tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvIV(tmpstr);
- }
- }
- return PTR2IV(SvRV(sv));
+ return I_V(Atof(ptr));
}
+ }
+
+ if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
}
+
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
PTR2UV(sv),SvIVX(sv)));
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
/*
-=for apidoc sv_gmagical_2iv_please
-
-Used internally by C<SvIV_please_nomg>, this function sets the C<SvIVX>
-slot if C<sv_2iv> would have made the scalar C<SvIOK> had it not been
-magical. In that case it returns true.
-
-=cut
-*/
-
-bool
-Perl_sv_gmagical_2iv_please(pTHX_ register SV *sv)
-{
- bool has_int;
- PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE;
- assert(SvGMAGICAL(sv) && !SvIOKp(sv) && (SvNOKp(sv) || SvPOKp(sv)));
- if (S_sv_2iuv_common(aTHX_ sv)) { SvNIOK_off(sv); return 0; }
- has_int = !!SvIOK(sv);
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
- return has_int;
-}
-
-/*
=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvUV(tmpstr);
+ }
+ }
+ return PTR2UV(SvRV(sv));
+ }
+
+ if (SvVALID(sv) || isREGEXP(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))
- return SvUVX(sv);
- if (SvNOKp(sv))
- return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv)) {
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return U_V(Atof(SvPVX_const(sv)));
- }
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvUV(tmpstr);
- }
- }
- return PTR2UV(SvRV(sv));
+ return U_V(Atof(ptr));
}
+ }
+
+ if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+ if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(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. */
+ the same flag bit as SVf_IVisUV, so must not let them cache NVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ const char *ptr;
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
- if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
+ if (SvPOKp(sv) && !SvIOKp(sv)) {
+ ptr = SvPVX_const(sv);
+ grokpv:
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
- !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
+ !grok_number(ptr, SvCUR(sv), NULL))
not_a_number(sv);
- return Atof(SvPVX_const(sv));
+ return Atof(ptr);
}
if (SvIOKp(sv)) {
if (SvIsUV(sv))
if (SvROK(sv)) {
goto return_rok;
}
+ if (isREGEXP(sv)) {
+ ptr = RX_WRAPPED((REGEXP *)sv);
+ goto grokpv;
+ }
assert(SvTYPE(sv) >= SVt_PVMG);
/* This falls through to the report_uninit near the end of the
function. */
}
return PTR2NV(SvRV(sv));
}
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
SvNOKp_on(sv);
#endif
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
- register char *s;
+ char *s;
if (!sv) {
if (lp)
*lp = 0;
return (char *)"";
}
- if (SvGMAGICAL(sv)) {
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvPOKp(sv)) {
- if (lp)
- *lp = SvCUR(sv);
- if (flags & SV_MUTABLE_RETURN)
- return SvPVX_mutable(sv);
- if (flags & SV_CONST_RETURN)
- return (char *)SvPVX_const(sv);
- return SvPVX(sv);
- }
- if (SvIOKp(sv) || SvNOKp(sv)) {
- char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
- STRLEN len;
-
- if (SvIOKp(sv)) {
- 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);
- }
- assert(!SvROK(sv));
- {
- dVAR;
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return NULL;
+ tmpstr = AMG_CALLunary(sv, string_amg);
+ TAINT_IF(tmpstr && SvTAINTED(tmpstr));
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
- SvUPGRADE(sv, SVt_PV);
- if (lp)
- *lp = len;
- s = SvGROW_mutable(sv, len + 1);
- SvCUR_set(sv, len);
- SvPOKp_on(sv);
- return (char*)memcpy(s, tbuf, len + 1);
- }
- }
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit near the end of the
- function. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return NULL;
- tmpstr = AMG_CALLunary(sv, string_amg);
- TAINT_IF(tmpstr && SvTAINTED(tmpstr));
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- /* Unwrap this: */
- /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
- */
-
- char *pv;
- if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
- if (flags & SV_CONST_RETURN) {
- pv = (char *) SvPVX_const(tmpstr);
- } else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
- }
- if (lp)
- *lp = SvCUR(tmpstr);
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
} else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
}
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
+ if (lp)
+ *lp = SvCUR(tmpstr);
+ } else {
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- {
- STRLEN len;
- char *retval;
- char *buffer;
- SV *const referent = SvRV(sv);
-
- if (!referent) {
- len = 7;
- retval = buffer = savepvn("NULLREF", len);
- } else if (SvTYPE(referent) == SVt_REGEXP && (
- !(PL_curcop->cop_hints & HINT_NO_AMAGIC)
- || amagic_is_enabled(string_amg)
- )) {
- REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
-
- assert(re);
+ }
+ {
+ STRLEN len;
+ char *retval;
+ char *buffer;
+ SV *const referent = SvRV(sv);
+
+ if (!referent) {
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
+ } else if (SvTYPE(referent) == SVt_REGEXP &&
+ (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
+ amagic_is_enabled(string_amg))) {
+ REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
+
+ assert(re);
- /* If the regex is UTF-8 we want the containing scalar to
- have an UTF-8 flag too */
- if (RX_UTF8(re))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
+ /* If the regex is UTF-8 we want the containing scalar to
+ have an UTF-8 flag too */
+ if (RX_UTF8(re))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
- if (lp)
- *lp = RX_WRAPLEN(re);
+ if (lp)
+ *lp = RX_WRAPLEN(re);
- return RX_WRAPPED(re);
- } else {
- const char *const typestr = sv_reftype(referent, 0);
- const STRLEN typelen = strlen(typestr);
- UV addr = PTR2UV(referent);
- const char *stashname = NULL;
- STRLEN stashnamelen = 0; /* hush, gcc */
- const char *buffer_end;
-
- if (SvOBJECT(referent)) {
- const HEK *const name = HvNAME_HEK(SvSTASH(referent));
-
- if (name) {
- stashname = HEK_KEY(name);
- stashnamelen = HEK_LEN(name);
-
- if (HEK_UTF8(name)) {
- SvUTF8_on(sv);
- } else {
- SvUTF8_off(sv);
- }
+ return RX_WRAPPED(re);
+ } else {
+ const char *const typestr = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
+
+ if (SvOBJECT(referent)) {
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
} else {
- stashname = "__ANON__";
- stashnamelen = 8;
+ SvUTF8_off(sv);
}
- len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
} else {
- len = typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
+ stashname = "__ANON__";
+ stashnamelen = 8;
}
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ }
- Newx(buffer, len, char);
- buffer_end = retval = buffer + len;
-
- /* Working backwards */
- *--retval = '\0';
- *--retval = ')';
- do {
- *--retval = PL_hexdigit[addr & 15];
- } while (addr >>= 4);
- *--retval = 'x';
- *--retval = '0';
- *--retval = '(';
-
- retval -= typelen;
- memcpy(retval, typestr, typelen);
-
- if (stashname) {
- *--retval = '=';
- retval -= stashnamelen;
- memcpy(retval, stashname, stashnamelen);
- }
- /* retval may not necessarily have reached the start of the
- buffer here. */
- assert (retval >= buffer);
-
- len = buffer_end - retval - 1; /* -1 for that \0 */
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
}
- if (lp)
- *lp = len;
- SAVEFREEPV(buffer);
- return retval;
+ /* retval may not necessarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
if (lp)
- *lp = 0;
- if (flags & SV_UNDEF_RETURNS_NULL)
- return NULL;
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return (char *)"";
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
- if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+
+ if (SvPOKp(sv)) {
+ if (lp)
+ *lp = SvCUR(sv);
+ if (flags & SV_MUTABLE_RETURN)
+ return SvPVX_mutable(sv);
+ if (flags & SV_CONST_RETURN)
+ return (char *)SvPVX_const(sv);
+ return SvPVX(sv);
+ }
+
+ if (SvIOK(sv)) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
const U32 isUIOK = SvIsUV(sv);
s += len;
*s = '\0';
}
- else if (SvNOKp(sv)) {
+ else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
if (SvNVX(sv) == 0.0) {
*--s = '\0';
#endif
}
- else {
- if (isGV_with_GP(sv)) {
- GV *const gv = MUTABLE_GV(sv);
- SV *const buffer = sv_newmortal();
-
- gv_efullname3(buffer, gv, "*");
+ else if (isGV_with_GP(sv)) {
+ GV *const gv = MUTABLE_GV(sv);
+ SV *const buffer = sv_newmortal();
- assert(SvPOK(buffer));
- if (lp) {
- *lp = SvCUR(buffer);
- }
- if ( SvUTF8(buffer) ) SvUTF8_on(sv);
- return SvPVX(buffer);
- }
+ gv_efullname3(buffer, gv, "*");
+ assert(SvPOK(buffer));
+ if (SvUTF8(buffer))
+ SvUTF8_on(sv);
+ if (lp)
+ *lp = SvCUR(buffer);
+ return SvPVX(buffer);
+ }
+ else if (isREGEXP(sv)) {
+ if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+ return RX_WRAPPED((REGEXP *)sv);
+ }
+ else {
if (lp)
*lp = 0;
if (flags & SV_UNDEF_RETURNS_NULL)
return NULL;
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. */
+ /* Typically the caller expects that sv_any is not NULL now. */
+ if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
sv_upgrade(sv, SVt_PV);
return (char *)"";
}
+
{
const STRLEN len = s - SvPVX_const(sv);
if (lp)
string. Mostly uses sv_2pv_flags to do its work, except when that
would lose the UTF-8'ness of the PV.
+=for apidoc sv_copypv_nomg
+
+Like sv_copypv, but doesn't invoke get magic first.
+
+=for apidoc sv_copypv_flags
+
+Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
+include SV_GMAGIC.
+
=cut
*/
void
Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
{
+ PERL_ARGS_ASSERT_SV_COPYPV;
+
+ sv_copypv_flags(dsv, ssv, 0);
+}
+
+void
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+{
STRLEN len;
- const char * const s = SvPV_const(ssv,len);
+ const char *s;
- PERL_ARGS_ASSERT_SV_COPYPV;
+ PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
+ if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
+ mg_get(ssv);
+ s = SvPV_nomg_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
- if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) {
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv)) {
SV *sv2 = sv_newmortal();
sv_copypv(sv2,sv);
sv = sv2;
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
- if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv))
sv = sv_mortalcopy(sv);
- sv_utf8_upgrade(sv);
- if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK;
- assert(SvPOKp(sv));
+ else
+ SvGETMAGIC(sv);
+ sv_utf8_upgrade_nomg(sv);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
}
return SvRV(sv) != 0;
}
- if (SvPOKp(sv)) {
- register XPV* const Xpvtmp = (XPV*)SvANY(sv);
- if (Xpvtmp &&
- (*sv->sv_u.svu_pv > '0' ||
- Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
- return 1;
- else
- return 0;
- }
- else {
- if (SvIOKp(sv))
- return SvIVX(sv) != 0;
- else {
- if (SvNOKp(sv))
- return SvNVX(sv) != 0.0;
- else {
- if (isGV_with_GP(sv))
- return TRUE;
- else
- return FALSE;
- }
- }
- }
+ return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
/*
if the whole string is the same in UTF-8 as not.
Returns the number of bytes in the converted string
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=for apidoc sv_utf8_upgrade_nomg
C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=cut
if (sv == &PL_sv_undef)
return 0;
- if (!SvPOK(sv)) {
+ if (!SvPOK_nog(sv)) {
STRLEN len = 0;
if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
(void) sv_2pv_flags(sv,&len, flags);
in this case, either returns false or, if C<fail_ok> is not
true, croaks.
-This is not as a general purpose Unicode to byte encoding interface:
+This is not a general purpose Unicode to byte encoding interface:
use the Encode extension for that.
=cut
/* 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 {
}
GvMULTI_on(dstr);
if(mro_changes == 2) {
+ if (GvAV((const GV *)sstr)) {
MAGIC *mg;
SV * const sref = (SV *)GvAV((const GV *)dstr);
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
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));
+ }
+ mro_isa_changed_in(GvSTASH(dstr));
}
else if(mro_changes == 3) {
HV * const stash = GvHV(dstr);
assert(mg);
Perl_magic_clearisa(aTHX_ NULL, mg);
}
+ else if (stype == SVt_PVIO) {
+ DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
break;
}
SvREFCNT_dec(dref);
Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
{
dVAR;
- register U32 sflags;
- register int dtype;
- register svtype stype;
+ U32 sflags;
+ int dtype;
+ svtype stype;
PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
- if ( SvVOK(dstr) )
- {
- /* need to nuke the magic */
- sv_unmagic(dstr, PERL_MAGIC_vstring);
- }
-
/* There's a lot of redundancy below but we're going for speed here */
switch (stype) {
}
goto undef_sstr;
- case SVt_PVFM:
-#ifdef PERL_OLD_COPY_ON_WRITE
- if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
- if (dtype < SVt_PVIV)
- sv_upgrade(dstr, SVt_PVIV);
- break;
- }
- /* Fall through */
-#endif
case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
break;
case SVt_REGEXP:
+ upgregexp:
if (dtype < SVt_REGEXP)
+ {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_REGEXP);
+ }
break;
/* case SVt_BIND: */
return;
}
if (stype == SVt_PVLV)
+ {
+ if (isREGEXP(sstr)) goto upgregexp;
SvUPGRADE(dstr, SVt_PVNV);
+ }
else
SvUPGRADE(dstr, (svtype)stype);
}
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
+ if (dtype == SVt_PVCV) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
} else {
SvOK_off(dstr);
}
- } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
+ }
+ else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
/* diag_listed_as: Cannot copy to %s */
}
}
}
- else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+ else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+ && (stype == SVt_REGEXP || isREGEXP(sstr))) {
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
}
else if (sflags & SVp_POK) {
in a newer implementation. */
/* If we are COW and dstr is a suitable target then we drop down
into the else and make dest a COW of us. */
- || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
+ || (SvFLAGS(dstr) & SVf_BREAK)
#endif
)
&&
&& ((flags & SV_COW_SHARED_HASH_KEYS)
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
+ && SvTYPE(sstr) >= SVt_PVIV))
: 1)
#endif
) {
{
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
- register char *new_pv;
+ char *new_pv;
PERL_ARGS_ASSERT_SV_SETSV_COW;
if (SvTHINKFIRST(dstr))
sv_force_normal_flags(dstr, SV_COW_DROP_PV);
else if (SvPVX_const(dstr))
- Safefree(SvPVX_const(dstr));
+ Safefree(SvPVX_mutable(dstr));
}
else
new_SV(dstr);
Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
{
dVAR;
- register char *dptr;
+ char *dptr;
PERL_ARGS_ASSERT_SV_SETPVN;
Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
{
dVAR;
- register STRLEN len;
+ STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
{
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
+ Safefree(SvPVX(sv));
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
/*
=for apidoc sv_force_normal_flags
-Undo various types of fakery on an SV: if the PV is a shared string, make
+Undo various types of fakery on an SV, where fakery means
+"more than" a string: if the PV is a shared string, make
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
-we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
+we do the copy, and is also used locally; if this is a
+vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
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,
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
- if (SvFAKE(sv)) {
+ if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
}
}
else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
#else
if (SvREADONLY(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && isGV_with_GP(sv))
sv_unglob(sv, flags);
- else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ else if (SvFAKE(sv) && isREGEXP(sv)) {
/* 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;
+ const bool islv = SvTYPE(sv) == SVt_PVLV;
+ const svtype new_type =
+ islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
- void *const temp_p = SvANY(sv);
+ regexp *const temp_p = ReANY((REGEXP *)sv);
if (new_type == SVt_PVMG) {
SvMAGIC_set(temp, SvMAGIC(sv));
SvSTASH_set(temp, SvSTASH(sv));
SvSTASH_set(sv, NULL);
}
- SvCUR_set(temp, SvCUR(sv));
- /* Remember that SvPVX is in the head, not the body. */
- if (SvLEN(temp)) {
- SvLEN_set(temp, SvLEN(sv));
- /* This signals "buffer is owned by someone else" in sv_clear,
- which is the least effort way to stop it freeing the buffer.
- */
- SvLEN_set(sv, SvLEN(sv)+1);
- } else {
- /* Their buffer is already owned by someone else. */
- SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
- SvLEN_set(temp, SvCUR(sv)+1);
+ if (!islv) SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. But
+ RX_WRAPPED is in the body. */
+ assert(ReANY((REGEXP *)sv)->mother_re);
+ /* Their buffer is already owned by someone else. */
+ if (flags & SV_COW_DROP_PV) {
+ /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
+ zeroed body. For SVt_PVLV, it should have been set to 0
+ before turning into a regexp. */
+ assert(!SvLEN(islv ? sv : temp));
+ sv->sv_u.svu_pv = 0;
+ }
+ else {
+ sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+ SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+ SvPOK_on(sv);
}
/* Now swap the rest of the bodies. */
- SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
- SvFLAGS(sv) |= new_type;
- SvANY(sv) = SvANY(temp);
+ SvFAKE_off(sv);
+ if (!islv) {
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+ }
SvFLAGS(temp) &= ~(SVTYPEMASK);
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
SvANY(temp) = temp_p;
+ temp->sv_u.svu_rx = (regexp *)temp_p;
SvREFCNT_dec(temp);
}
+ else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
}
/*
=for apidoc sv_chop
Efficient removal of characters from the beginning of the string buffer.
-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".
+SvPOK(sv), or at least SvPOKp(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". On return, only
+SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
refer to the same chunk of data.
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);
+ SvPOK_only_UTF8(sv);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
/*
=for apidoc sv_catsv
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
-not 'set' magic. See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
+C<sv_catsv_nomg>.
=for apidoc sv_catsv_flags
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
-bit set, will C<mg_get> on the C<ssv>, if appropriate, before
-reading it. If the C<flags> contain C<SV_SMAGIC>, C<mg_set> will be
-called on the modified SV afterward, if appropriate. C<sv_catsv>
-and C<sv_catsv_nomg> are implemented in terms of this function.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
+appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
+the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
+and C<sv_catsv_mg> are implemented in terms of this function.
=cut */
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
- if (ssv) {
+ if (ssv) {
STRLEN slen;
const char *spv = SvPV_flags_const(ssv, slen, flags);
if (spv) {
- if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
- mg_get(dsv);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(dsv);
sv_catpvn_flags(dsv, spv, slen,
DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
- }
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
+ }
}
- if (flags & SV_SMAGIC)
- SvSETMAGIC(dsv);
}
/*
Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
{
dVAR;
- register STRLEN len;
+ STRLEN len;
STRLEN tlen;
char *junk;
Perl_newSV(pTHX_ const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
if (len) {
mg->mg_virtual = (MGVTBL *) vtable;
mg_magical(sv);
- if (SvGMAGICAL(sv))
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
return mg;
}
&& !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
/* sv_magic() refuses to add a magic of the same 'how' as an
existing one
*/
- if (how == PERL_MAGIC_taint) {
+ if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
- /* Any scalar which already had taint magic on which someone
- (erroneously?) did SvIOK_on() or similar will now be
- incorrectly sporting public "OK" flags. */
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
- }
return;
}
}
if (!av)
return;
- /* after multiple passes through Perl_sv_clean_all() for a thinngy
+ /* after multiple passes through Perl_sv_clean_all() for a thingy
* 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)) {
Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
dVAR;
- register char *big;
- register char *mid;
- register char *midend;
- register char *bigend;
- register SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
+ char *big;
+ char *mid;
+ char *midend;
+ char *bigend;
+ SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
STRLEN curlen;
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
assert(GvGP(gv));
assert(!CvANON(cv));
assert(CvGV(cv) == gv);
+ assert(!CvNAMED(cv));
/* will the CV shortly be freed by gp_free() ? */
if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
- SvANY(cv)->xcv_gv = NULL;
+ SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
return;
}
CvANON_on(cv);
CvCVGV_RC_on(cv);
- SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+ SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
}
const struct body_details *sv_type_details;
SV* iter_sv = NULL;
SV* next_sv = NULL;
- register SV *sv = orig_sv;
+ SV *sv = orig_sv;
STRLEN hash_index;
PERL_ARGS_ASSERT_SV_CLEAR;
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
+ freeregexp:
pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
if ( PL_phase != PERL_PHASE_DESTRUCT
&& (name = HvNAME((HV*)sv)))
{
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
+ sv));
(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);
}
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
+ if (isREGEXP(sv)) goto freeregexp;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
SvFAKE_off(sv);
} else if (SvLEN(sv)) {
- Safefree(SvPVX_const(sv));
+ Safefree(SvPVX_mutable(sv));
}
}
#else
iter_sv = (SV*)SvSTASH(sv);
assert(!SvMAGICAL(sv));
hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
+#ifdef DEBUGGING
+ /* perl -DA does not like rubbish in SvMAGIC. */
+ SvMAGIC_set(sv, 0);
+#endif
/* free any remaining detritus from the hash struct */
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
=for apidoc sv_len
Returns the length of the string in the SV. Handles magic and type
-coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
+coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
+gives raw access to the xpv_cur slot.
=cut
*/
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- len = mg_length(sv);
- else
- (void)SvPV_const(sv, len);
+ (void)SvPV_const(sv, len);
return len;
}
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- return mg_length(sv);
- else
- {
- STRLEN len;
- const U8 *s = (U8*)SvPV_const(sv, len);
+ SvGETMAGIC(sv);
+ return sv_len_utf8_nomg(sv);
+}
- if (PL_utf8cache) {
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+ dVAR;
+ STRLEN len;
+ const U8 *s = (U8*)SvPV_nomg_const(sv, len);
+
+ PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
+
+ if (PL_utf8cache && SvUTF8(sv)) {
STRLEN ulen;
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
utf8_mg_len_cache_update(sv, &mg, ulen);
}
return ulen;
- }
- return Perl_utf8_length(aTHX_ s, s + len);
}
+ return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
}
/* Walk forwards to find the byte corresponding to the passed in UTF-8
if (!uoffset)
return 0;
- if (!SvREADONLY(sv)
+ if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
&& PL_utf8cache
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
(*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
boffset = real_boffset;
}
- if (PL_utf8cache) {
+ if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
if (at_end)
utf8_mg_len_cache_update(sv, mgp, uoffset);
else
const STRLEN ulen)
{
PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
- if (SvREADONLY(sv))
+ if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
return;
if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
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);
if (byte > cache[1]) {
/* New position is after the existing pair of pairs. */
const float keep_earlier
= THREEWAY_SQUARE(0, cache[1], byte, blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = cache[0];
- cache[3] = cache[1];
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[2] = cache[0];
+ cache[3] = cache[1];
+ cache[0] = utf8;
+ cache[1] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[0] = utf8;
+ cache[1] = byte;
}
}
else if (byte > cache[3]) {
= THREEWAY_SQUARE(0, byte, cache[1], blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[2] = utf8;
+ cache[3] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = utf8;
- cache[1] = byte;
- }
+ cache[0] = utf8;
+ cache[1] = byte;
}
}
else {
= THREEWAY_SQUARE(0, byte, cache[1], blen);
if (keep_later < keep_earlier) {
- if (keep_later < existing) {
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[2] = utf8;
+ cache[3] = byte;
}
else {
- if (keep_earlier < existing) {
- cache[0] = cache[2];
- cache[1] = cache[3];
- cache[2] = utf8;
- cache[3] = byte;
- }
+ cache[0] = cache[2];
+ cache[1] = cache[3];
+ cache[2] = utf8;
+ cache[3] = byte;
}
}
}
=for apidoc sv_gets
Get a line from the filehandle and store it into the SV, optionally
-appending to the currently-stored string.
+appending to the currently-stored string. If C<append> is not 0, the
+line is appended to the SV instead of overwriting it. C<append> should
+be set to the byte offset that the appended string should start at
+in the SV (typically, C<SvCUR(sv)> is a suitable choice).
=cut
*/
dVAR;
const char *rsptr;
STRLEN rslen;
- register STDCHAR rslast;
- register STDCHAR *bp;
- register I32 cnt;
+ STDCHAR rslast;
+ STDCHAR *bp;
+ I32 cnt;
I32 i = 0;
I32 rspara = 0;
* We're going to steal some values from the stdio struct
* and put EVERYTHING in the innermost loop into registers.
*/
- register STDCHAR *ptr;
+ STDCHAR *ptr;
STRLEN bpx;
I32 shortbuffered;
screamer2:
if (rslen) {
- register const STDCHAR * const bpe = buf + sizeof(buf);
+ const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
if (cnt < 0)
cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
if (append)
- sv_catpvn(sv, (char *) buf, cnt);
+ sv_catpvn_nomg(sv, (char *) buf, cnt);
else
- sv_setpvn(sv, (char *) buf, cnt);
+ sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
if (i != EOF && /* joy */
(!rslen ||
Perl_sv_inc_nomg(pTHX_ register SV *const sv)
{
dVAR;
- register char *d;
+ char *d;
int flags;
if (!sv)
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
* permanent location. */
SV *
-Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
dVAR;
- register SV *sv;
+ SV *sv;
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
new_SV(sv);
- sv_setsv(sv,oldstr);
+ sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
return sv;
Perl_sv_newmortal(pTHX)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
SvFLAGS(sv) = SVs_TEMP;
Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
{
dVAR;
- register SV *sv;
+ SV *sv;
/* All the flags we don't support must be zero.
And we're new code so I'm going to assert this from the start. */
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setpvn(sv,buffer,len);
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
dVAR;
- register SV *sv;
+ SV *sv;
bool is_utf8 = FALSE;
const char *const orig_src = src;
Perl_newSVpvf_nocontext(const char *const pat, ...)
{
dTHX;
- register SV *sv;
+ SV *sv;
va_list args;
PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
SV *
Perl_newSVpvf(pTHX_ const char *const pat, ...)
{
- register SV *sv;
+ SV *sv;
va_list args;
PERL_ARGS_ASSERT_NEWSVPVF;
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
dVAR;
- register SV *sv;
+ SV *sv;
PERL_ARGS_ASSERT_VNEWSVPVF;
Perl_newSVnv(pTHX_ const NV n)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setnv(sv,n);
Perl_newSViv(pTHX_ const IV i)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setiv(sv,i);
Perl_newSVuv(pTHX_ const UV u)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setuv(sv,u);
SV *
Perl_newSV_type(pTHX_ const svtype type)
{
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_upgrade(sv, type);
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
dVAR;
- register SV *sv = newSV_type(SVt_IV);
+ SV *sv = newSV_type(SVt_IV);
PERL_ARGS_ASSERT_NEWRV_NOINC;
Perl_newSVsv(pTHX_ register SV *const old)
{
dVAR;
- register SV *sv;
+ SV *sv;
if (!old)
return NULL;
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
+ /* Do this here, otherwise we leak the new SV if this croaks. */
+ SvGETMAGIC(old);
new_SV(sv);
- /* SV_GMAGIC is the default for sv_setv()
- SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
- sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
+ sv_setsv_flags(sv, old, SV_NOSTEAL);
return sv;
}
void
Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
{
+ PERL_ARGS_ASSERT_SV_RESET;
+
+ sv_resetpvn(*s ? s : NULL, strlen(s), stash);
+}
+
+void
+Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
+{
dVAR;
char todo[PERL_UCHAR_MAX+1];
-
- PERL_ARGS_ASSERT_SV_RESET;
+ const char *send;
if (!stash)
return;
- if (!*s) { /* reset ?? searches */
+ if (!s) { /* reset ?? searches */
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
if (mg) {
const U32 count = mg->mg_len / sizeof(PMOP**);
return;
Zero(todo, 256, char);
- while (*s) {
+ send = s + len;
+ while (s < send) {
I32 max;
I32 i = (unsigned char)*s;
if (s[1] == '-') {
entry;
entry = HeNEXT(entry))
{
- register GV *gv;
- register SV *sv;
+ GV *gv;
+ SV *sv;
if (!todo[(U8)*HeKEY(entry)])
continue;
if (!sv)
return 0;
if (SvPOK(sv)) {
- register const XPV* const tXpv = (XPV*)SvANY(sv);
+ const XPV* const tXpv = (XPV*)SvANY(sv);
if (tXpv &&
(tXpv->xpv_cur > 1 ||
(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
else
Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
- if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+ if (SvTYPE(sv) > SVt_PVLV
|| 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),
PTR2UV(sv),SvPVX_const(sv)));
}
}
+ (void)SvPOK_only_UTF8(sv);
return SvPVX_mutable(sv);
}
{
PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
- sv_pvn_force(sv,lp);
- sv_utf8_upgrade(sv);
+ sv_pvn_force(sv,0);
+ sv_utf8_upgrade_nomg(sv);
*lp = SvCUR(sv);
return SvPVX(sv);
}
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvIsCOW(tmpRef))
- sv_force_normal_flags(tmpRef, 0);
- if (SvREADONLY(tmpRef))
- Perl_croak_no_modify(aTHX);
+ if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
+ Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
PERL_ARGS_ASSERT_SV_VSETPVFN;
sv_setpvs(sv, "");
- sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
}
/*
=for apidoc sv_vcatpvfn
+=for apidoc sv_vcatpvfn_flags
+
Processes its arguments like C<vsprintf> and appends the formatted output
to an SV. Uses an array of SVs if the C style variable argument list is
missing (NULL). When running with taint checks enabled, indicates via
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+
Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
=cut
*/
-
#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
vecstr = (U8*)SvPV_const(vecsv,veclen);\
vec_utf8 = DO_UTF8(vecsv);
Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
+
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+}
+
+void
+Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
+ const U32 flags)
+{
dVAR;
char *p;
char *q;
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
- PERL_ARGS_ASSERT_SV_VCATPVFN;
+ PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(sv);
+
/* no matter what, this is a string now */
- (void)SvPV_force(sv, origlen);
+ (void)SvPV_force_nomg(sv, origlen);
/* special-case "", "%s", and "%-p" (SVf - see below) */
if (patlen == 0)
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
const char * const s = va_arg(*args, char*);
- sv_catpv(sv, s ? s : nullstr);
+ sv_catpv_nomg(sv, s ? s : nullstr);
}
else if (svix < svmax) {
- sv_catsv(sv, *svargs);
+ /* we want get magic on the source but not the target. sv_catsv can't do that, though */
+ SvGETMAGIC(*svargs);
+ sv_catsv_nomg(sv, *svargs);
}
else
S_vcatpvfn_missing_argument(aTHX);
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
argsv = MUTABLE_SV(va_arg(*args, void*));
- sv_catsv(sv, argsv);
+ sv_catsv_nomg(sv, argsv);
return;
}
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
Gconvert(nv, (int)digits, 0, ebuf);
- sv_catpv(sv, ebuf);
+ sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
}
STRLEN l;
if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn(sv, p, l);
+ sv_catpvn_nomg(sv, p, l);
return;
}
}
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
if (has_utf8 && !pat_utf8)
- sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
+ sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
else
- sv_catpvn(sv, p, q - p);
+ sv_catpvn_nomg(sv, p, q - p);
p = q;
}
if (q++ >= patend)
* vectorize happen normally
*/
if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
- char *version = savesvpv(vecsv);
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
"vector argument not supported with alpha versions");
- goto unknown;
+ goto vdblank;
}
vecsv = sv_newmortal();
- scan_vstring(version, version + veclen, vecsv);
+ scan_vstring((char *)vecstr, (char *)vecstr + veclen,
+ vecsv);
vecstr = (U8*)SvPV_const(vecsv, veclen);
vec_utf8 = DO_UTF8(vecsv);
- Safefree(version);
}
}
else {
+ vdblank:
vecstr = (U8*)"";
veclen = 0;
}
switch (*q) {
#ifdef WIN32
case 'I': /* Ix, I32x, and I64x */
-# ifdef WIN64
+# ifdef USE_64_BIT_INT
if (q[1] == '6' && q[2] == '4') {
q += 3;
intsize = 'q';
q += 3;
break;
}
-# ifdef WIN64
+# ifdef USE_64_BIT_INT
intsize = 'q';
# endif
q++;
if (DO_UTF8(argsv)) {
STRLEN old_precis = precis;
if (has_precis && precis < elen) {
- STRLEN ulen = sv_len_utf8(argsv);
- I32 p = precis > ulen ? ulen : precis;
- sv_pos_u2b(argsv, &p, 0); /* sticks at end */
- precis = p;
+ STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
+ STRLEN p = precis > ulen ? ulen : precis;
+ precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
+ /* sticks at end */
}
if (width) { /* fudge width (can't fudge elen) */
if (has_precis && precis < elen)
width += precis - old_precis;
else
- width += elen - sv_len_utf8(argsv);
+ width +=
+ elen - sv_or_pv_len_utf8(argsv,eptr,elen);
}
is_utf8 = TRUE;
}
sv_catpvs(msg, "\"%");
for (f = fmtstart; f < fmtend; f++) {
if (isPRINT(*f)) {
- sv_catpvn(msg, f, 1);
+ sv_catpvn_nomg(msg, f, 1);
} else {
Perl_sv_catpvf(aTHX_ msg,
"\\%03"UVof, (UV)*f & 0xFF);
have = esignlen + zeros + elen;
if (have < zeros)
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ croak_memory_wrap();
need = (have > width ? have : width);
gap = need - have;
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ croak_memory_wrap();
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
parser->multi_open = proto->multi_open;
parser->multi_start = proto->multi_start;
parser->multi_end = proto->multi_end;
- parser->pending_ident = proto->pending_ident;
parser->preambled = proto->preambled;
parser->sublex_info = proto->sublex_info; /* XXX not quite right */
parser->linestr = sv_dup_inc(proto->linestr, param);
#ifdef HAS_FCHDIR
DIR *pwd;
- register const Direntry_t *dirent;
+ const Direntry_t *dirent;
char smallbuf[256];
char *name = NULL;
STRLEN len = 0;
{
PERL_ARGS_ASSERT_RVPV_DUP;
+ assert(!isREGEXP(sstr));
if (SvROK(sstr)) {
if (SvWEAKREF(sstr)) {
SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
dstr->sv_debug_parent = (SV*)sstr;
FREE_SV_DEBUG_FILE(dstr);
- dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
#endif
ptr_table_store(PL_ptr_table, sstr, dstr);
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
&& !isGV_with_GP(dstr)
+ && !isREGEXP(dstr)
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
case SVt_PVMG:
break;
case SVt_REGEXP:
+ duprex:
/* FIXME for plugins */
+ dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+ if (isREGEXP(sstr)) goto duprex;
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
daux->xhv_mro_meta = saux->xhv_mro_meta
? mro_meta_dup(saux->xhv_mro_meta, param)
: 0;
+ daux->xhv_super = NULL;
/* Record stashes for possible cloning in Perl_clone(). */
if (HvNAME(sstr))
}
assert(!CvSLABBED(dstr));
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ if (CvNAMED(dstr))
+ SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+ share_hek_hek(CvNAME_HEK((CV *)sstr));
/* 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 =
+ else
+ SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
CvCVGV_RC(dstr)
? gv_dup_inc(CvGV(sstr), param)
: (param->flags & CLONEf_JOIN_IN)
TOPUV(nss,ix) = uv;
switch (type) {
case SAVEt_CLEARSV:
+ case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
new_state->re_state_bostr
= pv_dup(old_state->re_state_bostr);
- new_state->re_state_reginput
- = pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
#ifdef PERL_OLD_COPY_ON_WRITE
PL_hash_seed = proto_perl->Ihash_seed;
PL_rehash_seed = proto_perl->Irehash_seed;
- SvANY(&PL_sv_undef) = NULL;
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
- 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;
-
- 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;
-
/* dbargs array probably holds garbage */
PL_dbargs = NULL;
PL_compiling = proto_perl->Icompiling;
-#ifdef PERL_DEBUG_READONLY_OPS
- PL_slabs = NULL;
- PL_slab_count = 0;
-#endif
-
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
PL_origargv = proto_perl->Iorigargv;
+#if !NO_TAINT_SUPPORT
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
PL_taint_warn = proto_perl->Itaint_warn;
+#else
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
+#endif
PL_minus_c = proto_perl->Iminus_c;
PL_timesbuf = proto_perl->Itimesbuf;
#endif
+#if !NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
+#else
+ PL_tainted = FALSE;
+#endif
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_ptr_table = ptr_table_new();
/* initialize these special pointers as early as possible */
+ init_constants();
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_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);
PL_VertSpace = sv_dup_inc(proto_perl->IVertSpace, param);
+ PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
+ PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+
/* utf8 character class swashes */
PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, 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_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_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_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
- PL_utf8_quotemeta = sv_dup_inc(proto_perl->Iutf8_quotemeta, param);
+ PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+ PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
-
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
}
#endif /* USE_ITHREADS */
+void
+Perl_init_constants(pTHX)
+{
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
+ SvANY(&PL_sv_undef) = NULL;
+
+ SvANY(&PL_sv_no) = new_XPVNV();
+ SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
+ |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK;
+
+ SvANY(&PL_sv_yes) = new_XPVNV();
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
+ |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK;
+
+ SvPV_set(&PL_sv_no, (char*)PL_No);
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 0);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
+
+ SvPV_set(&PL_sv_yes, (char*)PL_Yes);
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 0);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
+}
+
/*
=head1 Unicode Support
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
- XPUSHs(encoding);
- XPUSHs(sv);
+ PUSHs(encoding);
+ PUSHs(sv);
/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
- XPUSHs(encoding);
- XPUSHs(dsv);
- XPUSHs(ssv);
+ PUSHs(encoding);
+ PUSHs(dsv);
+ PUSHs(ssv);
offsv = newSViv(*offset);
- mXPUSHs(offsv);
- mXPUSHp(tstr, tlen);
+ mPUSHs(offsv);
+ mPUSHp(tstr, tlen);
PUTBACK;
call_method("cat_decode", G_SCALAR);
SPAGAIN;
S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
{
dVAR;
- register HE **array;
+ HE **array;
I32 i;
PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
array = HvARRAY(hv);
- for (i=HvMAX(hv); i>0; i--) {
- register HE *entry;
+ for (i=HvMAX(hv); i>=0; i--) {
+ HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) != val)
continue;
return -1;
}
-/* S_varname(): return the name of a variable, optionally with a subscript.
+/* varname(): return the name of a variable, optionally with a subscript.
* If gv is non-zero, use the name of that global, along with gvtype (one
* of "$", "@", "%"); otherwise use the name of the lexical at pad offset
* targ. Depending on the value of the subscript_type flag, return:
SV *sv;
AV *av;
- assert(!cv || SvTYPE(cv) == SVt_PVCV);
+ assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
if (!cv || !CvPADLIST(cv))
return NULL;
- av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
+ av = *PadlistARRAY(CvPADLIST(cv));
sv = *av_fetch(av, targ, FALSE);
- sv_setsv(name, sv);
+ sv_setsv_flags(name, sv, 0);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
case OP_PADAV:
case OP_PADHV:
{
- const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = ( obase->op_type == OP_PADAV
+ || obase->op_type == OP_PADHV
+ || obase->op_type == OP_PADRANGE
+ );
+
+ const bool hash = ( obase->op_type == OP_PADHV
+ || obase->op_type == OP_RV2HV
+ || (obase->op_type == OP_PADRANGE
+ && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+ );
I32 index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
case OP_OPEN:
o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
+ if ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ )
o = o->op_sibling;
if (!o->op_sibling) {
match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ if ((obase->op_flags & OPf_STACKED)
+ &&
+ ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
o = o->op_sibling->op_sibling;
goto do_op2;
* left that is not skipped, then we *know* it is responsible for
* the uninitialized value. If there is more than one op left, we
* have to look for an exact match in the while() loop below.
+ * Note that we skip padrange, because the individual pad ops that
+ * it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (type == OP_PADRANGE)
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff