{
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
char *
Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
{
- register char *s;
+ char *s;
PERL_ARGS_ASSERT_SV_GROW;
{
PERL_ARGS_ASSERT_SV_SETUV;
- /* With these two if statements:
+ /* With the if statement to ensure that integers are stored as IVs whenever
+ possible:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
- If you wish to remove them, please benchmark to see what the effect is
+ If you wish to remove the following if statement, so that this routine
+ (and its callers) always return UVs, please benchmark to see what the
+ effect is. Modern CPUs may be different. Or may not :-)
*/
if (u <= (UV)IV_MAX) {
sv_setiv(sv, (IV)u);
if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ /* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
I32
Perl_looks_like_number(pTHX_ SV *const sv)
{
- register const char *sbegin;
+ const char *sbegin;
STRLEN len;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
STATIC bool
S_glob_2number(pTHX_ GV * const gv)
{
- SV *const buffer = sv_newmortal();
-
PERL_ARGS_ASSERT_GLOB_2NUMBER;
- gv_efullname3(buffer, gv, "*");
-
/* We know that all GVs stringify to something that is not-a-number,
so no need to test that. */
if (ckWARN(WARN_NUMERIC))
+ {
+ SV *const buffer = sv_newmortal();
+ gv_efullname3(buffer, gv, "*");
not_a_number(buffer);
+ }
/* We just want something true to return, so that S_sv_2iuv_common
can tail call us and return true. */
return TRUE;
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)) {
/* 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))
return SvIVX(sv);
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv))
return I_V(SvNVX(sv));
- }
if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
const int numtype
}
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));
- }
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+
+ if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
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);
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)) {
/* 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(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));
- }
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+
+ if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
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) {
- REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
- I32 seen_evals = 0;
-
- 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 ((seen_evals = RX_SEEN_EVALS(re)))
- PL_reginterp_cnt += seen_evals;
+ /* 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();
+ else if (isGV_with_GP(sv)) {
+ GV *const gv = MUTABLE_GV(sv);
+ SV *const buffer = sv_newmortal();
- gv_efullname3(buffer, gv, "*");
-
- 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 (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);
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
- SvGETMAGIC(sv);
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv)) {
+ SV *sv2 = sv_newmortal();
+ sv_copypv(sv2,sv);
+ sv = sv2;
+ }
+ else SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
- sv_utf8_upgrade(sv);
- return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+ if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+ || isGV_with_GP(sv) || SvROK(sv))
+ sv = sv_mortalcopy(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);
}
/*
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
-if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
+if all the bytes are invariant in UTF-8.
+If C<flags> has C<SV_GMAGIC> bit set,
will C<mg_get> on C<sv> if appropriate, else not.
Returns the number of bytes in the converted string
C<sv_utf8_upgrade> and
{
PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
if (SvREADONLY(sv)) {
- Perl_croak_no_modify(aTHX);
+ sv_force_normal_flags(sv, 0);
}
(void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
* we want to make sure everything inside is valid utf8 first.
*/
c = start = (const U8 *) SvPVX_const(sv);
- if (!is_utf8_string(c, SvCUR(sv)+1))
+ if (!is_utf8_string(c, SvCUR(sv)))
return FALSE;
e = (const U8 *) SvEND(sv);
while (c < e) {
}
SvUPGRADE(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- /* We have to turn this on here (even though we turn it off
+ /* We have to turn this on here, even though we turn it off
below, as GvSTASH will fail an assertion otherwise. */
isGV_with_GP_on(dstr);
}
/* 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);
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);
- (void)SvAMAGIC_off(dstr);
- if ( SvVOK(dstr) )
- {
- /* need to nuke the magic */
- mg_free(dstr);
- }
-
/* 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);
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
+ /* diag_listed_as: Bizarre copy of %s */
Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
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 */
Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Cannot copy to %s", type);
&& ((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;
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;
/* len is STRLEN which is unsigned, need to copy to signed */
const IV iv = len;
if (iv < 0)
- Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
+ IVdf, iv);
}
SvUPGRADE(sv, SVt_PV);
Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
{
dVAR;
- register STRLEN len;
+ STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
return;
}
{
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
- sv_usepvn_flags(sv, (char *)HEK_KEY(share_hek_hek(hek)), HEK_LEN(hek), SV_HAS_TRAILING_NUL);
+ Safefree(SvPVX(sv));
+ SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
SvREADONLY_on(sv);
SvFAKE_on(sv);
Tells an SV to use C<ptr> to find its string value. Normally the
string is stored inside the SV but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by C<malloc>. The string length, C<len>, must be supplied. By default
+by C<malloc>. It must be the start of a mallocked block
+of memory, and not a pointer to the middle of it. The
+string length, C<len>, must be supplied. By default
this function will realloc (i.e. move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
giving it to sv_usepvn, and neither should any pointers from "behind"
/*
=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,
}
#else
if (SvREADONLY(sv)) {
- if (SvFAKE(sv) && !isGV_with_GP(sv)) {
+ if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
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 */
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
- SvFLAGS(sv) |= SVf_OOK;
+ SvOOK_on(sv);
old_delta = 0;
} else {
SvOOK_offset(sv, old_delta);
/*
=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;
}
#endif
if (SvREADONLY(sv)) {
if (
- /* its okay to attach magic to shared strings; the subsequent
- * upgrade to PVMG will unshare the string */
- !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
+ /* its okay to attach magic to shared strings */
+ !SvIsCOW(sv)
&& IN_PERL_RUNTIME
&& !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
/* 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 (SvOOK(tsv))
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
+ else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* It's possible for the the last (strong) reference to tsv to have
+ become freed *before* the last thing holding a weak reference.
+ If both survive longer than the backreferences array, then when
+ the referent's reference count drops to 0 and it is freed, it's
+ not able to chase the backreferences, so they aren't NULLed.
+
+ For example, a CV holds a weak reference to its stash. If both the
+ CV and the stash survive longer than the backreferences array,
+ and the CV gets picked for the SvBREAK() treatment first,
+ *and* it turns out that the stash is only being kept alive because
+ of an our variable in the pad of the CV, then midway during CV
+ destruction the stash gets freed, but CvSTASH() isn't set to NULL.
+ It ends up pointing to the freed HV. Hence it's chased in here, and
+ if this block wasn't here, it would hit the !svp panic just below.
+
+ I don't believe that "better" destruction ordering is going to help
+ here - during global destruction there's always going to be the
+ chance that something goes out of order. We've tried to make it
+ foolproof before, and it only resulted in evolutionary pressure on
+ fools. Which made us look foolish for our hubris. :-(
+ */
+ return;
+ }
else {
MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
svp = mg ? &(mg->mg_obj) : NULL;
}
- if (!svp || !*svp)
- Perl_croak(aTHX_ "panic: del_backref");
+ if (!svp)
+ Perl_croak(aTHX_ "panic: del_backref, svp=0");
+ if (!*svp) {
+ /* It's possible that sv is being freed recursively part way through the
+ freeing of tsv. If this happens, the backreferences array of tsv has
+ already been freed, and so svp will be NULL. If this is the case,
+ we should not panic. Instead, nothing needs doing, so return. */
+ if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
+ return;
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
+ *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
+ }
if (SvTYPE(*svp) == SVt_PVAV) {
#ifdef DEBUGGING
assert(count ==1);
AvFILLp(av) = fill-1;
}
+ else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* freed AV; skip */
+ }
else {
/* optimisation: only a single backref, stored directly */
if (*svp != sv)
- Perl_croak(aTHX_ "panic: del_backref");
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
*svp = NULL;
}
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;
if (!bigstr)
- Perl_croak(aTHX_ "Can't modify non-existent substring");
+ Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
bigend = big + SvCUR(bigstr);
if (midend > bigend)
- Perl_croak(aTHX_ "panic: sv_insert");
+ Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
+ midend, bigend);
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
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;
sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
}
+ SvMAGICAL_off(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
+ if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
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. */
+ /* save old hash_index in unused SvMAGIC field */
+ assert(!SvMAGICAL(sv));
+ assert(!SvMAGIC(sv));
+ ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
hash_index = 0;
+
next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
goto get_next_sv; /* process this new sv */
}
/* FIXME. There are probably more unreferenced pointers to SVs
* in the interpreter struct that we should check and tidy in
* a similar fashion to this: */
+ /* See also S_sv_unglob, which does the same thing. */
if ((const GV *)sv == PL_last_in_gv)
PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
&& !(SvTYPE(sv) == SVt_PVIO
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
Safefree(SvPVX_mutable(sv));
- else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
+ else if (SvPVX_const(sv) && SvIsCOW(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
SvFAKE_off(sv);
}
/* no more elements of current HV to free */
sv = iter_sv;
type = SvTYPE(sv);
- /* Restore previous value of iter_sv, squirrelled away */
+ /* Restore previous values of iter_sv and hash_index,
+ * 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;
+ 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
+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.
=cut
return mg_length(sv);
else
{
- STRLEN len;
- const U8 *s = (U8*)SvPV_const(sv, len);
+ SvGETMAGIC(sv);
+ return sv_len_utf8_nomg(sv);
+ }
+}
+
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+ dVAR;
+ STRLEN len;
+ const U8 *s = (U8*)SvPV_nomg_const(sv, len);
- if (PL_utf8cache) {
+ PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
+
+ if (PL_utf8cache) {
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 Perl_utf8_length(aTHX_ s, s + len);
}
/* Walk forwards to find the byte corresponding to the passed in UTF-8
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles type coercion.
+the offset, rather than from the start
+of the string. Handles type coercion.
I<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
+the offset, rather than from the start of the string. Handles magic and
type coercion.
Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
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;
}
}
}
s = (const U8*)SvPV_const(sv, blen);
if (blen < byte)
- Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
+ ", byte=%"UVuf, (UV)blen, (UV)byte);
send = s + 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;
Swings and roundabouts. */
SvUPGRADE(sv, SVt_PV);
- SvSCREAM_off(sv);
-
if (append) {
if (PerlIO_isutf8(fp)) {
if (!SvUTF8(sv)) {
* 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)
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when incrementing %" NVff " by 1",
was);
const NV was = SvNVX(sv);
if (NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
+ /* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
"Lost precision when decrementing %" NVff " by 1",
was);
Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
sv_setsv(sv,oldstr);
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. */
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
statement boundaries. SvTEMP() is turned on which means that the SV's
-string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
and C<sv_mortalcopy>.
=cut
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));
/*
=for apidoc newSVpvn
-Creates a new SV and copies a string into it. The reference count for the
-SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
-string. You are responsible for ensuring that the source string is at least
-C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
+Creates a new SV and copies a buffer into it, which may contain NUL characters
+(C<\0>) and other binary data. The reference count for the SV is set to 1.
+Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
+are responsible for ensuring that the source buffer is at least
+C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
+undefined.
=cut
*/
SV *
-Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
+Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
dVAR;
- register SV *sv;
+ SV *sv;
new_SV(sv);
- sv_setpvn(sv,s,len);
+ sv_setpvn(sv,buffer,len);
return sv;
}
table. If the string does not already exist in the table, it is
created first. Turns on READONLY and FAKE. If the C<hash> parameter
is non-zero, that value is used; otherwise the hash is computed.
-The string's hash can be later be retrieved from the SV
+The string's hash can later be retrieved from the SV
with the C<SvSHARED_HASH()> macro. The idea here is
that as the string table is used for shared hash keys these strings will have
SvPVX_const == HeKEY and hash lookup will avoid string compare.
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;
entry;
entry = HeNEXT(entry))
{
- register GV *gv;
- register SV *sv;
+ GV *gv;
+ SV *sv;
if (!todo[(U8)*HeKEY(entry)])
continue;
}
*st = GvESTASH(gv);
if (lref & ~GV_ADDMG && !GvCVu(gv)) {
- SV *tmpsv;
- ENTER;
- tmpsv = newSV(0);
- gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, tmpsv),
- NULL, NULL);
- LEAVE;
- if (!GvCVu(gv))
- Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(SvOK(sv) ? sv : &PL_sv_no));
+ newSTUB(gv,0);
}
return GvCVu(gv);
}
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),
OP_DESC(PL_op));
s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
+ if (!s) {
+ s = (char *)"";
+ }
if (lp)
*lp = len;
PTR2UV(sv),SvPVX_const(sv)));
}
}
+ (void)SvPOK_only_UTF8(sv);
return SvPVX_mutable(sv);
}
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
- (void)SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
const U32 refcnt = SvREFCNT(rv);
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
- if (Gv_AMG(stash))
- SvAMAGIC_on(sv);
- else
- (void)SvAMAGIC_off(sv);
-
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
mg_set(tmpRef);
dVAR;
void *xpvmg;
HV *stash;
- SV * const temp = sv_newmortal();
+ SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
PERL_ARGS_ASSERT_SV_UNGLOB;
set operation as merely an internal storage change. */
if (flags & SV_COW_DROP_PV) SvOK_off(sv);
else sv_setsv_flags(sv, temp, 0);
+
+ if ((const GV *)sv == PL_last_in_gv)
+ PL_last_in_gv = NULL;
+ else if ((const GV *)sv == PL_statgv)
+ PL_statgv = NULL;
}
/*
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)
* back into v-string notation and then let the
* vectorize happen normally
*/
- if (sv_derived_from(vecsv, "version") && SvROK(vecsv)) {
+ 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),
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_len_utf8_nomg(argsv);
+ STRLEN p = precis > ulen ? ulen : precis;
+ precis = sv_pos_u2b_flags(argsv, p, 0, 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_len_utf8_nomg(argsv);
}
is_utf8 = TRUE;
}
}
}
else
- sv_setuv_mg(argsv, (UV)i);
+ sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
continue; /* not "break" */
/* UNKNOWN */
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);
The foo_dup() functions make an exact copy of an existing foo thingy.
During the course of a cloning, a hash table is used to map old addresses
-to new addresses. The table is created and manipulated with the
+to new addresses. The table is created and manipulated with the
ptr_table_* functions.
=cut
#ifdef HAS_FCHDIR
DIR *pwd;
- register const Direntry_t *dirent;
+ const Direntry_t *dirent;
char smallbuf[256];
char *name = NULL;
- STRLEN len = -1;
+ STRLEN len = 0;
long pos;
#endif
return dstr;
}
}
+ else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
+ HV *stash = GvSTASH(sstr);
+ const HEK * hvname;
+ if (stash && (hvname = HvNAME_HEK(stash))) {
+ /** don't clone GVs if they already exist **/
+ SV **svp;
+ stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
+ HEK_UTF8(hvname) ? SVf_UTF8 : 0);
+ svp = hv_fetch(
+ stash, GvNAME(sstr),
+ GvNAMEUTF8(sstr)
+ ? -GvNAMELEN(sstr)
+ : GvNAMELEN(sstr),
+ 0
+ );
+ if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
+ ptr_table_store(PL_ptr_table, sstr, *svp);
+ return *svp;
+ }
+ }
+ }
}
/* create anew and remember what it is */
const struct xpvhv_aux * const saux = HvAUX(sstr);
struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(dstr) |= SVf_OOK;
+ SvOOK_on(dstr);
if (saux->xhv_name_count) {
HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
OP_REFCNT_UNLOCK;
+ CvSLABBED_off(dstr);
} else if (CvCONST(dstr)) {
CvXSUBANY(dstr).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
}
+ assert(!CvSLABBED(dstr));
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 */
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
}
else {
+ ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
switch (CxTYPE(ncx)) {
case CXt_SUB:
ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
param);
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
+ ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
break;
case CXt_BLOCK:
case CXt_NULL:
+ case CXt_WHEN:
+ case CXt_GIVEN:
break;
}
}
= pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
- new_state->re_state_regoffs
- = (regexp_paren_pair*)
- any_dup(old_state->re_state_regoffs, proto_perl);
- new_state->re_state_reglastparen
- = (U32*) any_dup(old_state->re_state_reglastparen,
- proto_perl);
- new_state->re_state_reglastcloseparen
- = (U32*)any_dup(old_state->re_state_reglastcloseparen,
- proto_perl);
- /* XXX This just has to be broken. The old save_re_context
- code did SAVEGENERICPV(PL_reg_start_tmp);
- PL_reg_start_tmp is char **.
- Look above to what the dup code does for
- SAVEt_GENERIC_PVREF
- It can never have worked.
- So this is merely a faithful copy of the exiting bug: */
- new_state->re_state_reg_start_tmp
- = (char **) pv_dup((char *)
- old_state->re_state_reg_start_tmp);
- /* I assume that it only ever "worked" because no-one called
- (pseudo)fork while the regexp engine had re-entered itself.
- */
#ifdef PERL_OLD_COPY_ON_WRITE
new_state->re_state_nrs
= sv_dup(old_state->re_state_nrs, param);
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;
/* RE engine related */
Zero(&PL_reg_state, 1, struct re_save_state);
- PL_reginterp_cnt = 0;
PL_regmatch_slab = NULL;
PL_sub_generation = proto_perl->Isub_generation;
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_delaymagic_uid = proto_perl->Idelaymagic_uid;
+ PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
+ PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
+ PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
PL_evalseq = proto_perl->Ievalseq;
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_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_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 */
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);
-
+ /* This PV will be free'd special way so must set it same way op.c does */
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
PL_regex_pad = AvARRAY(PL_regex_padav);
+ PL_stashpadmax = proto_perl->Istashpadmax;
+ PL_stashpadix = proto_perl->Istashpadix ;
+ Newx(PL_stashpad, PL_stashpadmax, HV *);
+ {
+ PADOFFSET o = 0;
+ for (; o < PL_stashpadmax; ++o)
+ PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
+ }
+
/* shortcuts to various I/O objects */
PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
- /* utf8 character classes */
+ /* Unicode inversion lists */
+ PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+
+ PL_PerlSpace = sv_dup_inc(proto_perl->IPerlSpace, param);
+ PL_XPerlSpace = sv_dup_inc(proto_perl->IXPerlSpace, param);
+
+ PL_L1PosixAlnum = sv_dup_inc(proto_perl->IL1PosixAlnum, param);
+ PL_PosixAlnum = sv_dup_inc(proto_perl->IPosixAlnum, param);
+
+ PL_L1PosixAlpha = sv_dup_inc(proto_perl->IL1PosixAlpha, param);
+ PL_PosixAlpha = sv_dup_inc(proto_perl->IPosixAlpha, param);
+
+ PL_PosixBlank = sv_dup_inc(proto_perl->IPosixBlank, param);
+ PL_XPosixBlank = sv_dup_inc(proto_perl->IXPosixBlank, param);
+
+ PL_L1Cased = sv_dup_inc(proto_perl->IL1Cased, param);
+
+ PL_PosixCntrl = sv_dup_inc(proto_perl->IPosixCntrl, param);
+ PL_XPosixCntrl = sv_dup_inc(proto_perl->IXPosixCntrl, param);
+
+ PL_PosixDigit = sv_dup_inc(proto_perl->IPosixDigit, param);
+
+ PL_L1PosixGraph = sv_dup_inc(proto_perl->IL1PosixGraph, param);
+ PL_PosixGraph = sv_dup_inc(proto_perl->IPosixGraph, param);
+
+ PL_L1PosixLower = sv_dup_inc(proto_perl->IL1PosixLower, param);
+ PL_PosixLower = sv_dup_inc(proto_perl->IPosixLower, param);
+
+ PL_L1PosixPrint = sv_dup_inc(proto_perl->IL1PosixPrint, param);
+ PL_PosixPrint = sv_dup_inc(proto_perl->IPosixPrint, param);
+
+ PL_L1PosixPunct = sv_dup_inc(proto_perl->IL1PosixPunct, param);
+ PL_PosixPunct = sv_dup_inc(proto_perl->IPosixPunct, param);
+
+ PL_PosixSpace = sv_dup_inc(proto_perl->IPosixSpace, param);
+ PL_XPosixSpace = sv_dup_inc(proto_perl->IXPosixSpace, param);
+
+ PL_L1PosixUpper = sv_dup_inc(proto_perl->IL1PosixUpper, param);
+ PL_PosixUpper = sv_dup_inc(proto_perl->IPosixUpper, param);
+
+ PL_L1PosixWord = sv_dup_inc(proto_perl->IL1PosixWord, param);
+ PL_PosixWord = sv_dup_inc(proto_perl->IPosixWord, param);
+
+ PL_PosixXDigit = sv_dup_inc(proto_perl->IPosixXDigit, param);
+ PL_XPosixXDigit = sv_dup_inc(proto_perl->IXPosixXDigit, param);
+
+ PL_VertSpace = sv_dup_inc(proto_perl->IVertSpace, param);
+
+ PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, 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_blank = sv_dup_inc(proto_perl->Iutf8_blank, param);
PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, 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_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_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) {
#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
from the position which (PV + *offset) pointed to. The dsv will be
concatenated the decoded UTF-8 string from ssv. Decoding will terminate
when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
+the PV of the ssv. The value which the offset points will be modified
to the last input position on the ssv.
Returns TRUE if the terminator was found, else returns FALSE.
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;
+ 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 * const name = sv_newmortal();
- if (gv) {
+ if (gv && isGV(gv)) {
char buffer[2];
buffer[0] = gvtype;
buffer[1] = 0;
}
}
else {
- CV * const cv = find_runcv(NULL);
+ CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
SV *sv;
AV *av;
+ 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 * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
+ pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
SvREFCNT_dec(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
if (!o)
break;
- /* if all except one arg are constant, or have no side-effects,
- * or are optimized away, then it's unambiguous */
+ /* This loop checks all the kid ops, skipping any that cannot pos-
+ * sibly be responsible for the uninitialized value; i.e., defined
+ * constants and ops that return nothing. If there is only one op
+ * 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.
+ */
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if (kid) {
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff