/* sv.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "regcomp.h"
#define FCALL *f
-#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
+#ifdef PERL_UTF8_CACHE_ASSERT
+/* The cache element 0 is the Unicode offset;
+ * the cache element 1 is the byte offset of the element 0;
+ * the cache element 2 is the Unicode length of the substring;
+ * the cache element 3 is the byte length of the substring;
+ * The checking of the substring side would be good
+ * but substr() has enough code paths to make my head spin;
+ * if adding more checks watch out for the following tests:
+ * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
+ * lib/utf8.t lib/Unicode/Collate/t/index.t
+ * --jhi
+ */
+#define ASSERT_UTF8_CACHE(cache) \
+ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
+#else
+#define ASSERT_UTF8_CACHE(cache) NOOP
+#endif
+
+#ifdef PERL_COPY_ON_WRITE
+#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
+#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
+ on-write. */
+#endif
/* ============================================================================
/* new_SV(): return a new, empty SV head */
-#define new_SV(p) \
+#ifdef DEBUG_LEAKING_SCALARS
+/* provide a real function for a debugger to play with */
+STATIC SV*
+S_new_SV(pTHX)
+{
+ SV* sv;
+
+ LOCK_SV_MUTEX;
+ if (PL_sv_root)
+ uproot_SV(sv);
+ else
+ sv = more_sv();
+ UNLOCK_SV_MUTEX;
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ return sv;
+}
+# define new_SV(p) (p)=S_new_SV(aTHX)
+
+#else
+# define new_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
if (PL_sv_root) \
SvREFCNT(p) = 1; \
SvFLAGS(p) = 0; \
} STMT_END
+#endif
/* del_SV(): return an empty SV head to the free list */
Safefree(arena);
}
PL_xiv_arenaroot = 0;
+ PL_xiv_root = 0;
for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xnv_arenaroot = 0;
+ PL_xnv_root = 0;
for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xrv_arenaroot = 0;
+ PL_xrv_root = 0;
for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpv_arenaroot = 0;
+ PL_xpv_root = 0;
for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpviv_arenaroot = 0;
+ PL_xpviv_root = 0;
for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvnv_arenaroot = 0;
+ PL_xpvnv_root = 0;
for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvcv_arenaroot = 0;
+ PL_xpvcv_root = 0;
for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvav_arenaroot = 0;
+ PL_xpvav_root = 0;
for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvhv_arenaroot = 0;
+ PL_xpvhv_root = 0;
for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvmg_arenaroot = 0;
+ PL_xpvmg_root = 0;
for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvlv_arenaroot = 0;
+ PL_xpvlv_root = 0;
for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvbm_arenaroot = 0;
+ PL_xpvbm_root = 0;
for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_he_arenaroot = 0;
+ PL_he_root = 0;
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
xpvbm->xpv_pv = 0;
}
-#ifdef LEAKTEST
-# define my_safemalloc(s) (void*)safexmalloc(717,s)
-# define my_safefree(p) safexfree((char*)p)
-#else
-# define my_safemalloc(s) (void*)safemalloc(s)
-# define my_safefree(p) safefree((char*)p)
-#endif
+#define my_safemalloc(s) (void*)safemalloc(s)
+#define my_safefree(p) safefree((char*)p)
#ifdef PURIFY
MAGIC* magic = NULL;
HV* stash = Nullhv;
- if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (mt != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvTYPE(sv) == mt)
{
register char *s;
-
-
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
-#if defined(MYMALLOC) && !defined(LEAKTEST)
+#ifdef MYMALLOC
STRLEN l = malloced_size((void*)SvPVX(sv));
if (newlen <= l) {
SvLEN_set(sv, l);
Renew(s,newlen,char);
}
else {
- /* sv_force_normal_flags() must not try to unshare the new
- PVX we allocate below. AMS 20010713 */
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
- }
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
+ (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else {
/* IN_UV NOT_INT
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
+ (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else
sv_2iuv_non_preserve (sv, numtype);
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
+ (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
return ptr;
}
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
+{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_2pv_flags
{
register char *s;
int olderrno;
- SV *tsv;
+ SV *tsv, *origsv;
char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
char *tmpbuf = tbuf;
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
- return SvPV(tmpstr,*lp);
+ (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ char *pv = SvPV(tmpstr, *lp);
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
+ }
+ origsv = sv;
sv = (SV*)SvRV(sv);
if (!sv)
s = "NULLREF";
case SVt_PVMG:
if ( ((SvFLAGS(sv) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
- == (SVs_OBJECT|SVs_RMG))
- && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
+ == (SVs_OBJECT|SVs_SMG))
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
need a newline */
mg->mg_len++; /* save space for it */
need_newline = 1; /* note to add it */
+ break;
}
}
}
mg->mg_ptr[mg->mg_len] = 0;
}
PL_reginterp_cnt += re->program[0].next_off;
+
+ if (re->reganch & ROPT_UTF8)
+ SvUTF8_on(origsv);
+ else
+ SvUTF8_off(origsv);
*lp = mg->mg_len;
return mg->mg_ptr;
}
s = "REF";
else
s = "SCALAR"; break;
- case SVt_PVLV: s = "LVALUE"; break;
+ case SVt_PVLV: s = SvROK(sv) ? "REF"
+ /* tied lvalues should appear to be
+ * scalars for backwards compatitbility */
+ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ ? "SCALAR" : "LVALUE"; break;
case SVt_PVAV: s = "ARRAY"; break;
case SVt_PVHV: s = "HASH"; break;
case SVt_PVCV: s = "CODE"; break;
default: s = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv)) {
- HV *svs = SvSTASH(sv);
- Perl_sv_setpvf(
- aTHX_ tsv, "%s=%s",
- /* [20011101.072] This bandaid for C<package;>
- should eventually be removed. AMS 20011103 */
- (svs ? HvNAME(svs) : "<none>"), s
- );
- }
+ if (SvOBJECT(sv))
+ if (HvNAME(SvSTASH(sv)))
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ else
+ Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
void
Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
{
- SV *tmpsv = sv_newmortal();
-
- if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
- tmpsv = AMG_CALLun(ssv,string);
- if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
- SvSetSV(dsv,tmpsv);
- return;
- }
- }
- {
- STRLEN len;
- char *s;
- s = SvPV(ssv,len);
- sv_setpvn(tmpsv,s,len);
- if (SvUTF8(ssv))
- SvUTF8_on(tmpsv);
- else
- SvUTF8_off(tmpsv);
- SvSetSV(dsv,tmpsv);
- }
+ STRLEN len;
+ char *s;
+ s = SvPV(ssv,len);
+ sv_setpvn(dsv,s,len);
+ if (SvUTF8(ssv))
+ SvUTF8_on(dsv);
+ else
+ SvUTF8_off(dsv);
}
/*
=for apidoc sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF8 as a side-effect.
+May cause the SV to be downgraded from UTF-8 as a side-effect.
Usually accessed via the C<SvPVbyte_nolen> macro.
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be downgraded from UTF8 as a
+to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
Usually accessed via the C<SvPVbyte> macro.
/*
=for apidoc sv_2pvutf8_nolen
-Return a pointer to the UTF8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8_nolen> macro.
/*
=for apidoc sv_2pvutf8
-Return a pointer to the UTF8-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
}
}
+/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
+ * this function provided for binary compatibility only
+ */
+
+
+STRLEN
+Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
+{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
/*
=for apidoc sv_utf8_upgrade
-Convert the PV of an SV to its UTF8-encoded form.
+Convert 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 have hibit clear.
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF8-encoded form.
+Convert 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 have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
if (SvUTF8(sv))
return SvCUR(sv);
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
- if (PL_encoding)
+ if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
sv_recode_to_utf8(sv, PL_encoding);
else { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
This may not be possible if the PV contains non-byte encoding characters;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
U8 *s;
STRLEN len;
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
s = (U8 *) SvPV(sv, len);
if (!utf8_to_bytes(s, &len)) {
if (fail_ok)
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
flag so that it looks like octets again. Used as a building block
for encode_utf8 in Encode.xs
return TRUE;
}
+/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_setsv
if (sstr == dstr)
return;
- SV_CHECK_THINKFIRST(dstr);
+ SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
SvAMAGIC_off(dstr);
+ if ( SvVOK(dstr) )
+ {
+ /* need to nuke the magic */
+ mg_free(dstr);
+ SvRMAGICAL_off(dstr);
+ }
/* There's a lot of redundancy below but we're going for speed here */
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
else if (dtype == SVt_PVGV &&
- SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
goto glob_assign;
}
break;
- case SVt_PV:
case SVt_PVFM:
+#ifdef PERL_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;
switch (SvTYPE(sref)) {
case SVt_PVAV:
if (intro)
- SAVESPTR(GvAV(dstr));
+ SAVEGENERICSV(GvAV(dstr));
else
dref = (SV*)GvAV(dstr);
GvAV(dstr) = (AV*)sref;
break;
case SVt_PVHV:
if (intro)
- SAVESPTR(GvHV(dstr));
+ SAVEGENERICSV(GvHV(dstr));
else
dref = (SV*)GvHV(dstr);
GvHV(dstr) = (HV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
PL_sub_generation++;
}
- SAVESPTR(GvCV(dstr));
+ SAVEGENERICSV(GvCV(dstr));
}
else
dref = (SV*)GvCV(dstr);
break;
case SVt_PVIO:
if (intro)
- SAVESPTR(GvIOp(dstr));
+ SAVEGENERICSV(GvIOp(dstr));
else
dref = (SV*)GvIOp(dstr);
GvIOp(dstr) = (IO*)sref;
break;
case SVt_PVFM:
if (intro)
- SAVESPTR(GvFORM(dstr));
+ SAVEGENERICSV(GvFORM(dstr));
else
dref = (SV*)GvFORM(dstr);
GvFORM(dstr) = (CV*)sref;
break;
default:
if (intro)
- SAVESPTR(GvSV(dstr));
+ SAVEGENERICSV(GvSV(dstr));
else
dref = (SV*)GvSV(dstr);
GvSV(dstr) = sref;
}
if (dref)
SvREFCNT_dec(dref);
- if (intro)
- SAVEFREESV(sref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
}
}
else if (sflags & SVp_POK) {
+ bool isSwipe = 0;
/*
* Check to see if we can just swipe the string. If so, it's a
* has to be allocated and SvPVX(sstr) has to be freed.
*/
- if (SvTEMP(sstr) && /* slated for free anyway? */
- SvREFCNT(sstr) == 1 && /* and no other references to it? */
- !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
- SvLEN(sstr) && /* and really is a string */
+ /* Whichever path we take through the next code, we want this true,
+ and doing it now facilitates the COW check. */
+ (void)SvPOK_only(dstr);
+
+ if (
+#ifdef PERL_COPY_ON_WRITE
+ (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+ &&
+#endif
+ !(isSwipe =
+ (sflags & SVs_TEMP) && /* slated for free anyway? */
+ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ SvREFCNT(sstr) == 1 && /* and no other references to it? */
+ SvLEN(sstr) && /* and really is a string */
/* and won't be needed again, potentially */
- !(PL_op && PL_op->op_type == OP_AASSIGN))
- {
+ !(PL_op && PL_op->op_type == OP_AASSIGN))
+#ifdef PERL_COPY_ON_WRITE
+ && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
+ && SvTYPE(sstr) >= SVt_PVIV)
+#endif
+ ) {
+ /* Failed the swipe test, and it's not a shared hash key either.
+ Have to copy the string. */
+ STRLEN len = SvCUR(sstr);
+ SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
+ Move(SvPVX(sstr),SvPVX(dstr),len,char);
+ SvCUR_set(dstr, len);
+ *SvEND(dstr) = '\0';
+ } else {
+ /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
+ be true in here. */
+#ifdef PERL_COPY_ON_WRITE
+ /* Either it's a shared hash key, or it's suitable for
+ copy-on-write or we can swipe the string. */
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
+ sv_dump(sstr);
+ sv_dump(dstr);
+ }
+ if (!isSwipe) {
+ /* I believe I should acquire a global SV mutex if
+ it's a COW sv (not a shared hash key) to stop
+ it going un copy-on-write.
+ If the source SV has gone un copy on write between up there
+ and down here, then (assert() that) it is of the correct
+ form to make it copy on write again */
+ if ((sflags & (SVf_FAKE | SVf_READONLY))
+ != (SVf_FAKE | SVf_READONLY)) {
+ SvREADONLY_on(sstr);
+ SvFAKE_on(sstr);
+ /* Make the source SV into a loop of 1.
+ (about to become 2) */
+ SV_COW_NEXT_SV_SET(sstr, sstr);
+ }
+ }
+#endif
+ /* Initial code is common. */
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
SvFLAGS(dstr) &= ~SVf_OOK;
else if (SvLEN(dstr))
Safefree(SvPVX(dstr));
}
- (void)SvPOK_only(dstr);
- SvPV_set(dstr, SvPVX(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvCUR_set(dstr, SvCUR(sstr));
-
- SvTEMP_off(dstr);
- (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
- SvPV_set(sstr, Nullch);
- SvLEN_set(sstr, 0);
- SvCUR_set(sstr, 0);
- SvTEMP_off(sstr);
- }
- else { /* have to copy actual string */
- STRLEN len = SvCUR(sstr);
- SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
- Move(SvPVX(sstr),SvPVX(dstr),len,char);
- SvCUR_set(dstr, len);
- *SvEND(dstr) = '\0';
- (void)SvPOK_only(dstr);
- }
+
+#ifdef PERL_COPY_ON_WRITE
+ if (!isSwipe) {
+ /* making another shared SV. */
+ STRLEN cur = SvCUR(sstr);
+ STRLEN len = SvLEN(sstr);
+ assert (SvTYPE(dstr) >= SVt_PVIV);
+ if (len) {
+ /* SvIsCOW_normal */
+ /* splice us in between source and next-after-source. */
+ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+ SV_COW_NEXT_SV_SET(sstr, dstr);
+ SvPV_set(dstr, SvPVX(sstr));
+ } else {
+ /* SvIsCOW_shared_hash */
+ UV hash = SvUVX(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Copy on write: Sharing hash\n"));
+ SvPV_set(dstr,
+ sharepvn(SvPVX(sstr),
+ (sflags & SVf_UTF8?-cur:cur), hash));
+ SvUVX(dstr) = hash;
+ }
+ SvLEN(dstr) = len;
+ SvCUR(dstr) = cur;
+ SvREADONLY_on(dstr);
+ SvFAKE_on(dstr);
+ /* Relesase a global SV mutex. */
+ }
+ else
+#endif
+ { /* Passes the swipe test. */
+ SvPV_set(dstr, SvPVX(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvCUR_set(dstr, SvCUR(sstr));
+
+ SvTEMP_off(dstr);
+ (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
+ SvPV_set(sstr, Nullch);
+ SvLEN_set(sstr, 0);
+ SvCUR_set(sstr, 0);
+ SvTEMP_off(sstr);
+ }
+ }
if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
SvIsUV_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
}
+ if (SvVOK(sstr)) {
+ MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
+ sv_magic(dstr, NULL, PERL_MAGIC_vstring,
+ smg->mg_ptr, smg->mg_len);
+ SvRMAGICAL_on(dstr);
+ }
}
else if (sflags & SVp_IOK) {
if (sflags & SVf_IOK)
SvSETMAGIC(dstr);
}
+#ifdef PERL_COPY_ON_WRITE
+SV *
+Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
+{
+ STRLEN cur = SvCUR(sstr);
+ STRLEN len = SvLEN(sstr);
+ register char *new_pv;
+
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
+ sstr, dstr);
+ sv_dump(sstr);
+ if (dstr)
+ sv_dump(dstr);
+ }
+
+ if (dstr) {
+ if (SvTHINKFIRST(dstr))
+ sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+ else if (SvPVX(dstr))
+ Safefree(SvPVX(dstr));
+ }
+ else
+ new_SV(dstr);
+ SvUPGRADE (dstr, SVt_PVIV);
+
+ assert (SvPOK(sstr));
+ assert (SvPOKp(sstr));
+ assert (!SvIOK(sstr));
+ assert (!SvIOKp(sstr));
+ assert (!SvNOK(sstr));
+ assert (!SvNOKp(sstr));
+
+ if (SvIsCOW(sstr)) {
+
+ if (SvLEN(sstr) == 0) {
+ /* source is a COW shared hash key. */
+ UV hash = SvUVX(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Sharing hash\n"));
+ SvUVX(dstr) = hash;
+ new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
+ goto common_exit;
+ }
+ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+ } else {
+ assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
+ SvUPGRADE (sstr, SVt_PVIV);
+ SvREADONLY_on(sstr);
+ SvFAKE_on(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Converting sstr to COW\n"));
+ SV_COW_NEXT_SV_SET(dstr, sstr);
+ }
+ SV_COW_NEXT_SV_SET(sstr, dstr);
+ new_pv = SvPVX(sstr);
+
+ common_exit:
+ SvPV_set(dstr, new_pv);
+ SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ if (SvUTF8(sstr))
+ SvUTF8_on(dstr);
+ SvLEN(dstr) = len;
+ SvCUR(dstr) = cur;
+ if (DEBUG_C_TEST) {
+ sv_dump(dstr);
+ }
+ return dstr;
+}
+#endif
+
/*
=for apidoc sv_setpvn
{
register char *dptr;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
{
register STRLEN len;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
(void)SvUPGRADE(sv, SVt_PV);
if (!ptr) {
(void)SvOK_off(sv);
SvSETMAGIC(sv);
}
+#ifdef PERL_COPY_ON_WRITE
+/* Need to do this *after* making the SV normal, as we need the buffer
+ pointer to remain valid until after we've copied it. If we let go too early,
+ another thread could invalidate it by unsharing last of the same hash key
+ (which it can do by means other than releasing copy-on-write Svs)
+ or by changing the other copy-on-write SVs in the loop. */
+STATIC void
+S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
+ U32 hash, SV *after)
+{
+ if (len) { /* this SV was SvIsCOW_normal(sv) */
+ /* we need to find the SV pointing to us. */
+ SV *current = SV_COW_NEXT_SV(after);
+
+ if (current == sv) {
+ /* The SV we point to points back to us (there were only two of us
+ in the loop.)
+ Hence other SV is no longer copy on write either. */
+ SvFAKE_off(after);
+ SvREADONLY_off(after);
+ } else {
+ /* We need to follow the pointers around the loop. */
+ SV *next;
+ while ((next = SV_COW_NEXT_SV(current)) != sv) {
+ assert (next);
+ current = next;
+ /* don't loop forever if the structure is bust, and we have
+ a pointer into a closed loop. */
+ assert (current != after);
+ assert (SvPVX(current) == pvx);
+ }
+ /* Make the SV before us point to the SV after us. */
+ SV_COW_NEXT_SV_SET(current, after);
+ }
+ } else {
+ unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
+ }
+}
+
+int
+Perl_sv_release_IVX(pTHX_ register SV *sv)
+{
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+ return SvOOK_off(sv);
+}
+#endif
/*
=for apidoc sv_force_normal_flags
Undo various types of fakery on an SV: 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. The C<flags> parameter gets passed to C<sv_unref_flags()>
-when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+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
+then a copy-on-write scalar drops its PV buffer (if any) and becomes
+SvPOK_off rather than making a copy. (Used where this scalar is about to be
+set to some other value.) In addition, the C<flags> parameter gets passed to
+C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
+with flags set to 0.
=cut
*/
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
+#ifdef PERL_COPY_ON_WRITE
+ if (SvREADONLY(sv)) {
+ /* At this point I believe I should acquire a global SV mutex. */
+ if (SvFAKE(sv)) {
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvLEN(sv);
+ STRLEN cur = SvCUR(sv);
+ U32 hash = SvUVX(sv);
+ SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log,
+ "Copy on write: Force normal %ld\n",
+ (long) flags);
+ sv_dump(sv);
+ }
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ /* This SV doesn't own the buffer, so need to New() a new one: */
+ SvPVX(sv) = 0;
+ SvLEN(sv) = 0;
+ if (flags & SV_COW_DROP_PV) {
+ /* OK, so we don't need to copy our buffer. */
+ SvPOK_off(sv);
+ } else {
+ SvGROW(sv, cur + 1);
+ Move(pvx,SvPVX(sv),cur,char);
+ SvCUR(sv) = cur;
+ *SvEND(sv) = '\0';
+ }
+ sv_release_COW(sv, pvx, cur, len, hash, next);
+ if (DEBUG_C_TEST) {
+ sv_dump(sv);
+ }
+ }
+ else if (IN_PERL_RUNTIME)
+ Perl_croak(aTHX_ PL_no_modify);
+ /* At this point I believe that I can drop the global SV mutex. */
+ }
+#else
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
+ int is_utf8 = SvUTF8(sv);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ SvPVX(sv) = 0;
+ SvLEN(sv) = 0;
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
- unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
+ unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
+#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
string. Uses the "OOK hack".
+Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
+refer to the same chunk of data.
=cut
*/
Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
{
register STRLEN delta;
-
if (!ptr || !SvPOKp(sv))
return;
+ delta = ptr - SvPVX(sv);
SV_CHECK_THINKFIRST(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv,SVt_PVIV);
*SvEND(sv) = '\0';
}
SvIVX(sv) = 0;
- SvFLAGS(sv) |= SVf_OOK;
+ /* Same SvOOK_on but SvOOK_on does a SvIOK_off
+ and we do that anyway inside the SvNIOK_off
+ */
+ SvFLAGS(sv) |= SVf_OOK;
}
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
- delta = ptr - SvPVX(sv);
+ SvNIOK_off(sv);
SvLEN(sv) -= delta;
SvCUR(sv) -= delta;
SvPVX(sv) += delta;
SvIVX(sv) += delta;
}
+/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
+{
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
SvSETMAGIC(sv);
}
+/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catsv
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-If the SV has the UTF8 status set, then the bytes appended should be
-valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
=cut */
/* Some magic sontains a reference loop, where the sv and object refer to
each other. To prevent a reference loop that would prevent such
objects being freed, we look for such loops and if we find one we
- avoid incrementing the object refcount. */
+ avoid incrementing the object refcount.
+
+ Note we cannot do this to avoid self-tie loops as intervening RV must
+ have its REFCNT incremented to keep it in existence.
+
+ */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
+
+ /* Normal self-ties simply pass a null object, and instead of
+ using mg_obj directly, use the SvTIED_obj macro to produce a
+ new RV as needed. For glob "self-ties", we are tieing the PVIO
+ with an RV obj pointing to the glob containing the PVIO. In
+ this case, to avoid a reference loop, we need to weaken the
+ reference.
+ */
+
+ if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
+ obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
+ {
+ sv_rvweaken(obj);
+ }
+
mg->mg_type = how;
mg->mg_len = namlen;
if (name) {
MAGIC* mg;
MGVTBL *vtable = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+#endif
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling
+ if (IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
&& how != PERL_MAGIC_sv
+ && how != PERL_MAGIC_backref
)
{
Perl_croak(aTHX_ PL_no_modify);
case PERL_MAGIC_dbline:
vtable = &PL_vtbl_dbline;
break;
-#ifdef USE_5005THREADS
- case PERL_MAGIC_mutex:
- vtable = &PL_vtbl_mutex;
- break;
-#endif /* USE_5005THREADS */
#ifdef USE_LOCALE_COLLATE
case PERL_MAGIC_collxfrm:
vtable = &PL_vtbl_collxfrm;
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_vstring:
+ vtable = 0;
+ break;
+ case PERL_MAGIC_utf8:
+ vtable = &PL_vtbl_utf8;
+ break;
case PERL_MAGIC_substr:
vtable = &PL_vtbl_substr;
break;
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
+ Safefree(mg->mg_ptr);
}
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
else {
av = newAV();
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- SvREFCNT_dec(av); /* for sv_magic */
+ /* av now has a refcnt of 2, which avoids it getting freed
+ * before us during global cleanup. The extra ref is removed
+ * by magic_killbackrefs() when tsv is being freed */
+ }
+ if (AvFILLp(av) >= AvMAX(av)) {
+ I32 i;
+ SV **svp = AvARRAY(av);
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (!svp[i]) {
+ svp[i] = sv; /* reuse the slot */
+ return;
+ }
+ av_extend(av, AvFILLp(av)+1);
}
- av_push(av,sv);
+ AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
}
/* delete a back-reference to ourselves from the backref magic associated
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == sv) {
- svp[i] = &PL_sv_undef; /* XXX */
- }
- i--;
- }
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (svp[i] == sv) svp[i] = Nullsv;
}
/*
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
U32 refcnt = SvREFCNT(sv);
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
sv_clear(sv);
assert(!SvREFCNT(sv));
StructCopy(nsv,sv,SV);
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW_normal(nsv)) {
+ /* We need to follow the pointers around the loop to make the
+ previous SV point to sv, rather than nsv. */
+ SV *next;
+ SV *current = nsv;
+ while ((next = SV_COW_NEXT_SV(current)) != nsv) {
+ assert(next);
+ current = next;
+ assert(SvPVX(current) == SvPVX(nsv));
+ }
+ /* Make the SV before us point to the SV after us. */
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "previous is\n");
+ sv_dump(current);
+ PerlIO_printf(Perl_debug_log,
+ "move it from 0x%"UVxf" to 0x%"UVxf"\n",
+ (UV) SV_COW_NEXT_SV(current), (UV) sv);
+ }
+ SV_COW_NEXT_SV_SET(current, sv);
+ }
+#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
+ SvREFCNT(nsv) = 0;
del_SV(nsv);
}
if (PL_defstash) { /* Still have a symbol table? */
dSP;
CV* destructor;
- SV tmpref;
- Zero(&tmpref, 1, SV);
- sv_upgrade(&tmpref, SVt_RV);
- SvROK_on(&tmpref);
- SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
- SvREFCNT(&tmpref) = 1;
+
do {
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
+ SV* tmpref = newRV(sv);
+ SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
PUSHSTACKi(PERLSI_DESTROY);
- SvRV(&tmpref) = SvREFCNT_inc(sv);
EXTEND(SP, 2);
PUSHMARK(SP);
- PUSHs(&tmpref);
+ PUSHs(tmpref);
PUTBACK;
- call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
- SvREFCNT(sv)--;
+ call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+
+
POPSTACK;
SPAGAIN;
LEAVE;
+ if(SvREFCNT(tmpref) < 2) {
+ /* tmpref is not kept alive! */
+ SvREFCNT(sv)--;
+ SvRV(tmpref) = 0;
+ SvROK_off(tmpref);
+ }
+ SvREFCNT_dec(tmpref);
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
- del_XRV(SvANY(&tmpref));
if (SvREFCNT(sv)) {
if (PL_in_clean_objs)
av_undef((AV*)sv);
break;
case SVt_PVLV:
- SvREFCNT_dec(LvTARG(sv));
+ if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
+ SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
+ HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
+ PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+ }
+ else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
+ SvREFCNT_dec(LvTARG(sv));
goto freescalar;
case SVt_PVGV:
gp_free((GV*)sv);
else
SvREFCNT_dec(SvRV(sv));
}
+#ifdef PERL_COPY_ON_WRITE
+ else if (SvPVX(sv)) {
+ if (SvIsCOW(sv)) {
+ /* I believe I need to grab the global SV mutex here and
+ then recheck the COW status. */
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
+ sv_dump(sv);
+ }
+ sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
+ SvUVX(sv), SV_COW_NEXT_SV(sv));
+ /* And drop it here. */
+ SvFAKE_off(sv);
+ } else if (SvLEN(sv)) {
+ Safefree(SvPVX(sv));
+ }
+ }
+#else
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
SvUVX(sv));
SvFAKE_off(sv);
}
+#endif
break;
/*
case SVt_NV:
Perl_sv_newref(pTHX_ SV *sv)
{
if (sv)
- ATOMIC_INC(SvREFCNT(sv));
+ (SvREFCNT(sv))++;
return sv;
}
void
Perl_sv_free(pTHX_ SV *sv)
{
- int refcount_is_zero;
-
if (!sv)
return;
if (SvREFCNT(sv) == 0) {
return;
}
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf,
+ PTR2UV(sv));
return;
}
- ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
- if (!refcount_is_zero)
+ if (--(SvREFCNT(sv)) > 0)
return;
+ Perl_sv_free2(aTHX_ sv);
+}
+
+void
+Perl_sv_free2(pTHX_ SV *sv)
+{
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
=cut
*/
+/*
+ * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
+ * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
+ * (Note that the mg_len is not the length of the mg_ptr field.)
+ *
+ */
+
STRLEN
Perl_sv_len_utf8(pTHX_ register SV *sv)
{
return mg_length(sv);
else
{
- STRLEN len;
+ STRLEN len, ulen;
U8 *s = (U8*)SvPV(sv, len);
+ MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
+
+ if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
+ ulen = mg->mg_len;
+#ifdef PERL_UTF8_CACHE_ASSERT
+ assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
+#endif
+ }
+ else {
+ ulen = Perl_utf8_length(aTHX_ s, s + len);
+ if (!mg && !SvREADONLY(sv)) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ assert(mg);
+ }
+ if (mg)
+ mg->mg_len = ulen;
+ }
+ return ulen;
+ }
+}
+
+/* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
+ * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
+ * between UTF-8 and byte offsets. There are two (substr offset and substr
+ * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
+ * and byte offset) cache positions.
+ *
+ * The mg_len field is used by sv_len_utf8(), see its comments.
+ * Note that the mg_len is not the length of the mg_ptr field.
+ *
+ */
+STATIC bool
+S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
+{
+ bool found = FALSE;
+
+ if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
+ if (!*mgp)
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ assert(*mgp);
+
+ if ((*mgp)->mg_ptr)
+ *cachep = (STRLEN *) (*mgp)->mg_ptr;
+ else {
+ Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ (*mgp)->mg_ptr = (char *) *cachep;
+ }
+ assert(*cachep);
- return Perl_utf8_length(aTHX_ s, s + len);
+ (*cachep)[i] = *offsetp;
+ (*cachep)[i+1] = s - start;
+ found = TRUE;
}
+
+ return found;
}
/*
+ * S_utf8_mg_pos() is used to query and update mg_ptr field of
+ * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
+ * between UTF-8 and byte offsets. See also the comments of
+ * S_utf8_mg_pos_init().
+ *
+ */
+STATIC bool
+S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
+{
+ bool found = FALSE;
+
+ if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
+ if (!*mgp)
+ *mgp = mg_find(sv, PERL_MAGIC_utf8);
+ if (*mgp && (*mgp)->mg_ptr) {
+ *cachep = (STRLEN *) (*mgp)->mg_ptr;
+ ASSERT_UTF8_CACHE(*cachep);
+ if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
+ found = TRUE;
+ else { /* We will skip to the right spot. */
+ STRLEN forw = 0;
+ STRLEN backw = 0;
+ U8* p = NULL;
+
+ /* The assumption is that going backward is half
+ * the speed of going forward (that's where the
+ * 2 * backw in the below comes from). (The real
+ * figure of course depends on the UTF-8 data.) */
+
+ if ((*cachep)[i] > (STRLEN)uoff) {
+ forw = uoff;
+ backw = (*cachep)[i] - (STRLEN)uoff;
+
+ if (forw < 2 * backw)
+ p = start;
+ else
+ p = start + (*cachep)[i+1];
+ }
+ /* Try this only for the substr offset (i == 0),
+ * not for the substr length (i == 2). */
+ else if (i == 0) { /* (*cachep)[i] < uoff */
+ STRLEN ulen = sv_len_utf8(sv);
+
+ if ((STRLEN)uoff < ulen) {
+ forw = (STRLEN)uoff - (*cachep)[i];
+ backw = ulen - (STRLEN)uoff;
+
+ if (forw < 2 * backw)
+ p = start + (*cachep)[i+1];
+ else
+ p = send;
+ }
+
+ /* If the string is not long enough for uoff,
+ * we could extend it, but not at this low a level. */
+ }
+
+ if (p) {
+ if (forw < 2 * backw) {
+ while (forw--)
+ p += UTF8SKIP(p);
+ }
+ else {
+ while (backw--) {
+ p--;
+ while (UTF8_IS_CONTINUATION(*p))
+ p--;
+ }
+ }
+
+ /* Update the cache. */
+ (*cachep)[i] = (STRLEN)uoff;
+ (*cachep)[i+1] = p - start;
+
+ /* Drop the stale "length" cache */
+ if (i == 0) {
+ (*cachep)[2] = 0;
+ (*cachep)[3] = 0;
+ }
+
+ found = TRUE;
+ }
+ }
+ if (found) { /* Setup the return values. */
+ *offsetp = (*cachep)[i+1];
+ *sp = start + *offsetp;
+ if (*sp >= send) {
+ *sp = send;
+ *offsetp = send - start;
+ }
+ else if (*sp < start) {
+ *sp = start;
+ *offsetp = 0;
+ }
+ }
+ }
+#ifdef PERL_UTF8_CACHE_ASSERT
+ if (found) {
+ U8 *s = start;
+ I32 n = uoff;
+
+ while (n-- && s < send)
+ s += UTF8SKIP(s);
+
+ if (i == 0) {
+ assert(*offsetp == s - start);
+ assert((*cachep)[0] == (STRLEN)uoff);
+ assert((*cachep)[1] == *offsetp);
+ }
+ ASSERT_UTF8_CACHE(*cachep);
+ }
+#endif
+ }
+
+ return found;
+}
+
+/*
=for apidoc sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF8 chars from
+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
=cut
*/
+/*
+ * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
+ * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
+ * byte offsets. See also the comments of S_utf8_mg_pos().
+ *
+ */
+
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
U8 *start;
U8 *s;
- U8 *send;
- I32 uoffset = *offsetp;
STRLEN len;
+ STRLEN *cache = 0;
+ STRLEN boffset = 0;
if (!sv)
return;
start = s = (U8*)SvPV(sv, len);
- send = s + len;
- while (s < send && uoffset--)
- s += UTF8SKIP(s);
- if (s >= send)
- s = send;
- *offsetp = s - start;
- if (lenp) {
- I32 ulen = *lenp;
- start = s;
- while (s < send && ulen--)
- s += UTF8SKIP(s);
- if (s >= send)
- s = send;
- *lenp = s - start;
+ if (len) {
+ I32 uoffset = *offsetp;
+ U8 *send = s + len;
+ MAGIC *mg = 0;
+ bool found = FALSE;
+
+ if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
+ found = TRUE;
+ if (!found && uoffset > 0) {
+ while (s < send && uoffset--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
+ boffset = cache[1];
+ *offsetp = s - start;
+ }
+ if (lenp) {
+ found = FALSE;
+ start = s;
+ if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
+ *lenp -= boffset;
+ found = TRUE;
+ }
+ if (!found && *lenp > 0) {
+ I32 ulen = *lenp;
+ if (ulen > 0)
+ while (s < send && ulen--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
+ cache[2] += *offsetp;
+ }
+ *lenp = s - start;
+ }
+ ASSERT_UTF8_CACHE(cache);
}
+ else {
+ *offsetp = 0;
+ if (lenp)
+ *lenp = 0;
+ }
+
return;
}
=for apidoc sv_pos_b2u
Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF8 chars.
+start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
=cut
*/
+/*
+ * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
+ * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
+ * byte offsets. See also the comments of S_utf8_mg_pos().
+ *
+ */
+
void
-Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
+Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
{
- U8 *s;
- U8 *send;
+ U8* s;
STRLEN len;
if (!sv)
s = (U8*)SvPV(sv, len);
if ((I32)len < *offsetp)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
- send = s + *offsetp;
- len = 0;
- while (s < send) {
- STRLEN n;
- /* Call utf8n_to_uvchr() to validate the sequence */
- utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
- if (n > 0) {
- s += n;
- len++;
+ else {
+ U8* send = s + *offsetp;
+ MAGIC* mg = NULL;
+ STRLEN *cache = NULL;
+
+ len = 0;
+
+ if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ if (mg && mg->mg_ptr) {
+ cache = (STRLEN *) mg->mg_ptr;
+ if (cache[1] == (STRLEN)*offsetp) {
+ /* An exact match. */
+ *offsetp = cache[0];
+
+ return;
+ }
+ else if (cache[1] < (STRLEN)*offsetp) {
+ /* We already know part of the way. */
+ len = cache[0];
+ s += cache[1];
+ /* Let the below loop do the rest. */
+ }
+ else { /* cache[1] > *offsetp */
+ /* We already know all of the way, now we may
+ * be able to walk back. The same assumption
+ * is made as in S_utf8_mg_pos(), namely that
+ * walking backward is twice slower than
+ * walking forward. */
+ STRLEN forw = *offsetp;
+ STRLEN backw = cache[1] - *offsetp;
+
+ if (!(forw < 2 * backw)) {
+ U8 *p = s + cache[1];
+ STRLEN ubackw = 0;
+
+ cache[1] -= backw;
+
+ while (backw--) {
+ p--;
+ while (UTF8_IS_CONTINUATION(*p)) {
+ p--;
+ backw--;
+ }
+ ubackw++;
+ }
+
+ cache[0] -= ubackw;
+ *offsetp = cache[0];
+ return;
+ }
+ }
+ }
+ ASSERT_UTF8_CACHE(cache);
}
- else
- break;
+
+ while (s < send) {
+ STRLEN n = 1;
+
+ /* Call utf8n_to_uvchr() to validate the sequence
+ * (unless a simple non-UTF character) */
+ if (!UTF8_IS_INVARIANT(*s))
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ if (n > 0) {
+ s += n;
+ len++;
+ }
+ else
+ break;
+ }
+
+ if (!SvREADONLY(sv)) {
+ if (!mg) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ }
+ assert(mg);
+
+ if (!mg->mg_ptr) {
+ Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ mg->mg_ptr = (char *) cache;
+ }
+ assert(cache);
+
+ cache[0] = len;
+ cache[1] = *offsetp;
+ }
+
+ *offsetp = len;
}
- *offsetp = len;
return;
}
}
if (cur1 == cur2)
- eq = memEQ(pv1, pv2, cur1);
+ eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
if (svrecode)
SvREFCNT_dec(svrecode);
register I32 cnt;
I32 i = 0;
I32 rspara = 0;
-
- SV_CHECK_THINKFIRST(sv);
+ I32 recsize;
+
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
+ /* XXX. If you make this PVIV, then copy on write can copy scalars read
+ from <>.
+ However, perlbench says it's slower, because the existing swipe code
+ is faster than copy on write.
+ Swings and roundabouts. */
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
- if (PL_curcop == &PL_compiling) {
+ if (append) {
+ if (PerlIO_isutf8(fp)) {
+ if (!SvUTF8(sv)) {
+ sv_utf8_upgrade_nomg(sv);
+ sv_pos_u2b(sv,&append,0);
+ }
+ } else if (SvUTF8(sv)) {
+ SV *tsv = NEWSV(0,0);
+ sv_gets(tsv, fp, 0);
+ sv_utf8_upgrade_nomg(tsv);
+ SvCUR_set(sv,append);
+ sv_catsv(sv,tsv);
+ sv_free(tsv);
+ goto return_string_or_null;
+ }
+ }
+
+ SvPOK_only(sv);
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
+
+ if (IN_PERL_COMPILETIME) {
/* we always read code in line mode */
rsptr = "\n";
rslen = 1;
}
else if (RsSNARF(PL_rs)) {
+ /* If it is a regular disk file use size from stat() as estimate
+ of amount we are going to read - may result in malloc-ing
+ more memory than we realy need if layers bellow reduce
+ size we read (e.g. CRLF or a gzip layer)
+ */
+ Stat_t st;
+ if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
+ Off_t offset = PerlIO_tell(fp);
+ if (offset != (Off_t) -1 && st.st_size + append > offset) {
+ (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+ }
+ }
rsptr = NULL;
rslen = 0;
}
else if (RsRECORD(PL_rs)) {
- I32 recsize, bytesread;
+ I32 bytesread;
char *buffer;
/* Grab the size of the record we're getting */
recsize = SvIV(SvRV(PL_rs));
- (void)SvPOK_only(sv); /* Validate pointer */
- buffer = SvGROW(sv, (STRLEN)(recsize + 1));
+ buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
/* VMS wants read instead of fread, because fread doesn't respect */
/* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice */
+ /* doing, but we've got no other real choice - except avoid stdio
+ as implementation - perhaps write a :vms layer ?
+ */
bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
- SvCUR_set(sv, bytesread);
+ if (bytesread < 0)
+ bytesread = 0;
+ SvCUR_set(sv, bytesread += append);
buffer[bytesread] = '\0';
- if (PerlIO_isutf8(fp))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+ goto return_string_or_null;
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
/* Here is some breathtakingly efficient cheating */
cnt = PerlIO_get_cnt(fp); /* get count into register */
- (void)SvPOK_only(sv); /* validate pointer */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* make sure we have the room */
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ /* Not room for all of it
+ if we are looking for a separator and room for some
+ */
+ if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
}
else
{
-#ifndef EPOC
- /*The big, slow, and stupid way */
- STDCHAR buf[8192];
+ /*The big, slow, and stupid way. */
+
+ /* Any stack-challenged places. */
+#if defined(EPOC)
+ /* EPOC: need to work around SDK features. *
+ * On WINS: MS VC5 generates calls to _chkstk, *
+ * if a "large" stack frame is allocated. *
+ * gcc on MARM does not generate calls like these. */
+# define USEHEAPINSTEADOFSTACK
+#endif
+
+#ifdef USEHEAPINSTEADOFSTACK
+ STDCHAR *buf = 0;
+ New(0, buf, 8192, STDCHAR);
+ assert(buf);
#else
- /* Need to work around EPOC SDK features */
- /* On WINS: MS VC5 generates calls to _chkstk, */
- /* if a `large' stack frame is allocated */
- /* gcc on MARM does not generate calls like these */
- STDCHAR buf[1024];
+ STDCHAR buf[8192];
#endif
screamer2:
/* Accomodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
- if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
+ if (cnt > 0)
+ i = (U8)buf[cnt - 1];
+ else
+ i = EOF;
}
+ 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(sv, (char *) buf, cnt);
else
- sv_setpvn(sv, (char *) buf, cnt);
+ sv_setpvn(sv, (char *) buf, cnt);
if (i != EOF && /* joy */
(!rslen ||
if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
goto screamer2;
}
+
+#ifdef USEHEAPINSTEADOFSTACK
+ Safefree(buf);
+#endif
}
if (rspara) { /* have to do this both before and after */
}
}
- if (PerlIO_isutf8(fp))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
-
+return_string_or_null:
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && SvFAKE(sv))
- sv_force_normal(sv);
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
}
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
+#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
if (gv == PL_envgv
# ifdef USE_ITHREADS
environ[0] = Nullch;
}
#endif
+#endif /* !PERL_MICRO */
}
}
}
else
io = 0;
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
break;
}
return io;
Nullop);
LEAVE;
if (!GvCVu(gv))
- Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
+ sv);
}
return GvCVu(gv);
}
return sv_2nv(sv);
}
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pv(pTHX_ SV *sv)
+{
+ STRLEN n_a;
+
+ if (SvPOK(sv))
+ return SvPVX(sv);
+
+ return sv_2pv(sv, &n_a);
+}
+
/*
=for apidoc sv_pv
return sv_2pv_flags(sv, lp, 0);
}
+/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
+{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_pvn_force
char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
- sv_force_normal(sv);
+ sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
+/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvbyte(pTHX_ SV *sv)
+{
+ sv_utf8_downgrade(sv,0);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvbyte
return sv_pvn_force(sv,lp);
}
+/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvutf8(pTHX_ SV *sv)
+{
+ sv_utf8_upgrade(sv);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvutf8
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
if (ob && SvOBJECT(sv)) {
- HV *svs = SvSTASH(sv);
- /* [20011101.072] This bandaid for C<package;> should eventually
- be removed. AMS 20011103 */
- return (svs ? HvNAME(svs) : "<none>");
+ if (HvNAME(SvSTASH(sv)))
+ return HvNAME(SvSTASH(sv));
+ else
+ return "__ANON__";
}
else {
switch (SvTYPE(sv)) {
case SVt_PVNV:
case SVt_PVMG:
case SVt_PVBM:
+ if (SvVOK(sv))
+ return "VSTRING";
if (SvROK(sv))
return "REF";
else
return "SCALAR";
- case SVt_PVLV: return "LVALUE";
+
+ case SVt_PVLV: return SvROK(sv) ? "REF"
+ /* tied lvalues should appear to be
+ * scalars for backwards compatitbility */
+ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ ? "SCALAR" : "LVALUE";
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
sv = (SV*)SvRV(sv);
if (!SvOBJECT(sv))
return 0;
+ if (!HvNAME(SvSTASH(sv)))
+ return 0;
return strEQ(HvNAME(SvSTASH(sv)), name);
}
new_SV(sv);
- SV_CHECK_THINKFIRST(rv);
+ SV_CHECK_THINKFIRST_COW_DROP(rv);
SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
Do not use with other Perl types such as HV, AV, SV, CV, because those
objects will become corrupted by the pointer copy process.
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will be returned and will have
-a reference count of 1.
+C<Nullch> to avoid the blessing. The new SV will have a reference count
+of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
}
/* Downgrades a PVGV to a PVMG.
- *
- * XXX This function doesn't actually appear to be used anywhere
- * DAPM 15-Jun-01
*/
STATIC void
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
+ /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+ assigned to as BEGIN {$a = \"Foo"} will fail. */
+ if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
SvREFCNT_dec(rv);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(rv); /* Schedule for freeing later */
return FALSE;
}
+/*
+=for apidoc sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+}
+
+/*
+=for apidoc sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvSETMAGIC(sv);
+}
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
}
#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+static char *
+F0convert(NV nv, char *endbuf, STRLEN *len)
+{
+ int neg = nv < 0;
+ UV uv;
+ char *p = endbuf;
+
+ if (neg)
+ nv = -nv;
+ if (nv < UV_MAX) {
+ nv += 0.5;
+ uv = (UV)nv;
+ if (uv & 1 && uv == nv)
+ uv--; /* Round to even */
+ do {
+ unsigned dig = uv % 10;
+ *--p = '0' + dig;
+ } while (uv /= 10);
+ if (neg)
+ *--p = '-';
+ *len = endbuf - p;
+ return p;
+ }
+ return Nullch;
+}
+
+
/*
=for apidoc sv_vcatpvfn
I32 svix = 0;
static char nullstr[] = "(null)";
SV *argsv = Nullsv;
- bool has_utf8 = FALSE; /* has the result utf8? */
+ bool has_utf8; /* has the result utf8? */
+ bool pat_utf8; /* the pattern is in utf8? */
+ SV *nsv = Nullsv;
+ /* Times 4: a decimal digit takes more than 3 binary digits.
+ * NV_DIG: mantissa takes than many decimal digits.
+ * Plus 32: Playing safe. */
+ char ebuf[IV_DIG * 4 + NV_DIG + 32];
+ /* large enough for "%#.#f" --chip */
+ /* what about long double NVs? --jhi */
+
+ has_utf8 = pat_utf8 = DO_UTF8(sv);
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
}
}
+#ifndef USE_LONG_DOUBLE
+ /* special-case "%.<number>[gf]" */
+ if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+ && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
+ unsigned digits = 0;
+ const char *pp;
+
+ pp = pat + 2;
+ while (*pp >= '0' && *pp <= '9')
+ digits = 10 * digits + (*pp++ - '0');
+ if (pp - pat == (int)patlen - 1) {
+ NV nv;
+
+ if (args)
+ nv = (NV)va_arg(*args, double);
+ else if (svix < svmax)
+ nv = SvNV(*svargs);
+ else
+ return;
+ if (*pp == 'g') {
+ /* Add check for digits != 0 because it seems that some
+ gconverts are buggy in this case, and we don't yet have
+ a Configure test for this. */
+ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+ /* 0, point, slack */
+ Gconvert(nv, (int)digits, 0, ebuf);
+ sv_catpv(sv, ebuf);
+ if (*ebuf) /* May return an empty string for digits==0 */
+ return;
+ }
+ } else if (!digits) {
+ STRLEN l;
+
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn(sv, p, l);
+ return;
+ }
+ }
+ }
+ }
+#endif /* !USE_LONG_DOUBLE */
+
if (!args && svix < svmax && DO_UTF8(*svargs))
- has_utf8 = TRUE;
+ has_utf8 = TRUE;
patend = (char*)pat + patlen;
for (p = (char*)pat; p < patend; p = q) {
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
+ I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
-
+#ifdef HAS_LDBL_SPRINTF_BUG
+ /* This is to try to fix a bug with irix/nonstop-ux/powerux and
+ with sfio - Allen <allens@cpan.org> */
+ bool fix_ldbl_sprintf_bug = FALSE;
+#endif
+
char esignbuf[4];
U8 utf8buf[UTF8_MAXLEN+1];
STRLEN esignlen = 0;
char *eptr = Nullch;
STRLEN elen = 0;
- /* Times 4: a decimal digit takes more than 3 binary digits.
- * NV_DIG: mantissa takes than many decimal digits.
- * Plus 32: Playing safe. */
- char ebuf[IV_DIG * 4 + NV_DIG + 32];
- /* large enough for "%#.#f" --chip */
- /* what about long double NVs? --jhi */
-
- SV *vecsv;
+ SV *vecsv = Nullsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
char c = 0;
unsigned base = 0;
IV iv = 0;
UV uv = 0;
+ /* we need a long double target in case HAS_LONG_DOUBLE but
+ not USE_LONG_DOUBLE
+ */
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
+ long double nv;
+#else
NV nv;
+#endif
STRLEN have;
STRLEN need;
STRLEN gap;
/* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
- sv_catpvn(sv, p, q - p);
+ if (has_utf8 && !pat_utf8)
+ sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
+ else
+ sv_catpvn(sv, p, q - p);
p = q;
}
if (q++ >= patend)
We allow format specification elements in this order:
\d+\$ explicit format parameter index
[-+ 0#]+ flags
- \*?(\d+\$)?v vector with optional (optionally specified) arg
+ v|\*(\d+\$)?v vector with optional (optionally specified) arg
+ 0 flag (as above): repeated to allow "v02"
\d+|\*(\d+\$)? width using optional (optionally specified) arg
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
[hlqLV] size
}
if (!asterisk)
+ if( *q == '0' )
+ fill = *q++;
EXPECT_NUMBER(q, width);
if (vectorize) {
vecsv = va_arg(*args, SV*);
else
vecsv = (evix ? evix <= svmax : svix < svmax) ?
- svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+ svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
dotstr = SvPVx(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
is_utf8 = TRUE;
q++;
if (*q == '*') {
q++;
- if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ goto unknown;
+ /* XXX: todo, support specified precision parameter */
+ if (epix)
goto unknown;
if (args)
i = va_arg(*args, int);
q++;
break;
#endif
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALL THROUGH */
-#endif
#ifdef HAS_QUAD
case 'q': /* qd */
+#endif
intsize = 'q';
q++;
break;
#endif
case 'l':
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
- if (*(q + 1) == 'l') { /* lld, llf */
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+ if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
break;
goto string;
}
- if (!args)
+ if (vectorize)
+ argsv = vecsv;
+ else if (!args)
argsv = (efix ? efix <= svmax : svix < svmax) ?
svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
/* STRINGS */
case 'c':
- uv = args ? va_arg(*args, int) : SvIVx(argsv);
+ uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
goto string;
case 's':
- if (args) {
+ if (args && !vectorize) {
eptr = va_arg(*args, char*);
if (eptr)
#ifdef MACOS_TRADITIONAL
* if ISO or ANSI decide to use '_' for something.
* So we keep it hidden from users' code.
*/
- if (!args)
+ if (!args || vectorize)
goto unknown;
argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
/* INTEGERS */
case 'p':
- if (alt)
+ if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
base = 16;
else if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
- default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ default: iv = va_arg(*args, int); break;
#ifdef HAS_QUAD
case 'q': iv = va_arg(*args, Quad_t); break;
#endif
}
}
else {
- iv = SvIVx(argsv);
+ IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': iv = (short)iv; break;
- default: break;
- case 'l': iv = (long)iv; break;
- case 'V': break;
+ case 'h': iv = (short)tiv; break;
+ case 'l': iv = (long)tiv; break;
+ case 'V':
+ default: iv = tiv; break;
#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)iv; break;
+ case 'q': iv = (Quad_t)tiv; break;
#endif
}
}
else if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
- default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ default: uv = va_arg(*args, unsigned); break;
#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Quad_t); break;
+ case 'q': uv = va_arg(*args, Uquad_t); break;
#endif
}
}
else {
- uv = SvUVx(argsv);
+ UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': uv = (unsigned short)uv; break;
- default: break;
- case 'l': uv = (unsigned long)uv; break;
- case 'V': break;
+ case 'h': uv = (unsigned short)tuv; break;
+ case 'l': uv = (unsigned long)tuv; break;
+ case 'V':
+ default: uv = tuv; break;
#ifdef HAS_QUAD
- case 'q': uv = (Quad_t)uv; break;
+ case 'q': uv = (Uquad_t)tuv; break;
#endif
}
}
/* This is evil, but floating point is even more evil */
- vectorize = FALSE;
- nv = args ? va_arg(*args, NV) : SvNVx(argsv);
+ /* for SV-style calling, we can only get NV
+ for C-style calling, we assume %f is double;
+ for simplicity we allow any of %Lf, %llf, %qf for long double
+ */
+ switch (intsize) {
+ case 'V':
+#if defined(USE_LONG_DOUBLE)
+ intsize = 'q';
+#endif
+ break;
+/* [perl #20339] - we should accept and ignore %lf rather than die */
+ case 'l':
+ /* FALL THROUGH */
+ default:
+#if defined(USE_LONG_DOUBLE)
+ intsize = args ? 0 : 'q';
+#endif
+ break;
+ case 'q':
+#if defined(HAS_LONG_DOUBLE)
+ break;
+#else
+ /* FALL THROUGH */
+#endif
+ case 'h':
+ goto unknown;
+ }
+
+ /* now we need (long double) if intsize == 'q', else (double) */
+ nv = (args && !vectorize) ?
+#if LONG_DOUBLESIZE > DOUBLESIZE
+ intsize == 'q' ?
+ va_arg(*args, long double) :
+ va_arg(*args, double)
+#else
+ va_arg(*args, double)
+#endif
+ : SvNVx(argsv);
need = 0;
+ vectorize = FALSE;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
+ /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
+ will cast our (long double) to (double) */
(void)Perl_frexp(nv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp");
need = BIT_DIGITS(i);
}
need += has_precis ? precis : 6; /* known default */
+
if (need < width)
need = width;
+#ifdef HAS_LDBL_SPRINTF_BUG
+ /* This is to try to fix a bug with irix/nonstop-ux/powerux and
+ with sfio - Allen <allens@cpan.org> */
+
+# ifdef DBL_MAX
+# define MY_DBL_MAX DBL_MAX
+# else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
+# if DOUBLESIZE >= 8
+# define MY_DBL_MAX 1.7976931348623157E+308L
+# else
+# define MY_DBL_MAX 3.40282347E+38L
+# endif
+# endif
+
+# ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
+# define MY_DBL_MAX_BUG 1L
+# else
+# define MY_DBL_MAX_BUG MY_DBL_MAX
+# endif
+
+# ifdef DBL_MIN
+# define MY_DBL_MIN DBL_MIN
+# else /* XXX guessing! -Allen */
+# if DOUBLESIZE >= 8
+# define MY_DBL_MIN 2.2250738585072014E-308L
+# else
+# define MY_DBL_MIN 1.17549435E-38L
+# endif
+# endif
+
+ if ((intsize == 'q') && (c == 'f') &&
+ ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
+ (need < DBL_DIG)) {
+ /* it's going to be short enough that
+ * long double precision is not needed */
+
+ if ((nv <= 0L) && (nv >= -0L))
+ fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
+ else {
+ /* would use Perl_fp_class as a double-check but not
+ * functional on IRIX - see perl.h comments */
+
+ if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
+ /* It's within the range that a double can represent */
+#if defined(DBL_MAX) && !defined(DBL_MIN)
+ if ((nv >= ((long double)1/DBL_MAX)) ||
+ (nv <= (-(long double)1/DBL_MAX)))
+#endif
+ fix_ldbl_sprintf_bug = TRUE;
+ }
+ }
+ if (fix_ldbl_sprintf_bug == TRUE) {
+ double temp;
+
+ intsize = 0;
+ temp = (double)nv;
+ nv = (NV)temp;
+ }
+ }
+
+# undef MY_DBL_MAX
+# undef MY_DBL_MAX_BUG
+# undef MY_DBL_MIN
+
+#endif /* HAS_LDBL_SPRINTF_BUG */
+
need += 20; /* fudge factor */
if (PL_efloatsize < need) {
Safefree(PL_efloatbuf);
PL_efloatbuf[0] = '\0';
}
+ if ( !(width || left || plus || alt) && fill != '0'
+ && has_precis && intsize != 'q' ) { /* Shortcuts */
+ /* See earlier comment about buggy Gconvert when digits,
+ aka precis is 0 */
+ if ( c == 'g' && precis) {
+ Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+ if (*PL_efloatbuf) /* May return an empty string for digits==0 */
+ goto float_converted;
+ } else if ( c == 'f' && !precis) {
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ break;
+ }
+ }
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
-#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
- {
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
/* No taint. Otherwise we are in the strange situation
* where printf() taints but print($float) doesn't.
* --jhi */
+#if defined(HAS_LONG_DOUBLE)
+ if (intsize == 'q')
+ (void)sprintf(PL_efloatbuf, eptr, nv);
+ else
+ (void)sprintf(PL_efloatbuf, eptr, (double)nv);
+#else
(void)sprintf(PL_efloatbuf, eptr, nv);
-
+#endif
+ float_converted:
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
break;
/* SPECIAL */
case 'n':
- vectorize = FALSE;
i = SvCUR(sv) - origlen;
- if (args) {
+ if (args && !vectorize) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
}
else
sv_setuv_mg(argsv, (UV)i);
+ vectorize = FALSE;
continue; /* not "break" */
/* UNKNOWN */
default:
unknown:
- vectorize = FALSE;
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
- Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
- (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
+ Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
+ (PL_op->op_type == OP_PRTF) ? "" : "s");
if (c) {
if (isPRINT(c))
Perl_sv_catpvf(aTHX_ msg,
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
+ svix = osvix;
continue; /* not "break" */
}
p = SvEND(sv);
*p = '\0';
}
+ /* Use memchr() instead of strchr(), as eptr is not guaranteed */
+ /* to point to a null-terminated string. */
+ if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
+ (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF),
+ "Newline in left-justified string for %sprintf",
+ (PL_op->op_type == OP_PRTF) ? "" : "s");
have = esignlen + zeros + elen;
need = (have > width ? have : width);
#if defined(USE_ITHREADS)
-#if defined(USE_5005THREADS)
-# include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
-#endif
-
#ifndef GpREFCNT_inc
# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
#endif
ret->subbeg = SAVEPV(r->subbeg);
else
ret->subbeg = Nullch;
+#ifdef PERL_COPY_ON_WRITE
+ ret->saved_copy = Nullsv;
+#endif
ptr_table_store(PL_ptr_table, r, ret);
return ret;
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- AV *av = (AV*) mg->mg_obj;
- SV **svp;
- I32 i;
- nmg->mg_obj = (SV*)newAV();
- svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- i--;
- }
+ AV *av = (AV*) mg->mg_obj;
+ SV **svp;
+ I32 i;
+ SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
+ svp = AvARRAY(av);
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (!svp[i] || SvREFCNT(svp[i]) < 2) continue;
+ av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
+ }
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
if (tblent->oldval == oldv) {
tblent->newval = newv;
- tbl->tbl_items++;
return;
}
}
/* attempt to make everything in the typeglob readonly */
STATIC SV *
-S_gv_share(pTHX_ SV *sstr)
+S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
{
GV *gv = (GV*)sstr;
- SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+ SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
}
else {
/* CvPADLISTs cannot be shared */
- if (!CvXSUB(GvCV(gv))) {
+ if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
GvUNIQUE_off(gv);
}
}
GvHV(gv) = (HV*)sv;
}
else {
- SvREADONLY_on(GvAV(gv));
+ SvREADONLY_on(GvHV(gv));
}
return sstr; /* he_dup() will SvREFCNT_inc() */
Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
- SvRV(dstr) = SvWEAKREF(sstr)
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
}
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
+ if (SvREADONLY(sstr) && SvFAKE(sstr)) {
+ /* Not that normal - actually sstr is copy on write.
+ But we are a true, independant SV, so: */
+ SvREADONLY_off(dstr);
+ SvFAKE_off(dstr);
+ }
}
else {
/* Special case - not normally malloced for some reason */
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* A "shared" PV - clone it as unshared string */
- SvFAKE_off(dstr);
- SvREADONLY_off(dstr);
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ if(SvPADTMP(sstr)) {
+ /* However, some of them live in the pad
+ and they should not have these flags
+ turned off */
+
+ SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
+ SvUVX(sstr));
+ SvUVX(dstr) = SvUVX(sstr);
+ } else {
+
+ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ SvFAKE_off(dstr);
+ SvREADONLY_off(dstr);
+ }
}
else {
/* Some other special case - random pointer */
SvPVX(dstr) = SvPVX(sstr);
- }
+ }
}
}
else {
if (dstr)
return dstr;
+ if(param->flags & CLONEf_JOIN_IN) {
+ /** We are joining here so we don't want do clone
+ something that is bad **/
+
+ if(SvTYPE(sstr) == SVt_PVHV &&
+ HvNAME(sstr)) {
+ /** don't clone stashes if they already exist **/
+ HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+ return (SV*) old_stash;
+ }
+ }
+
/* create anew and remember what it is */
new_SV(dstr);
ptr_table_store(PL_ptr_table, sstr, dstr);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
- LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
+ if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
+ LvTARG(dstr) = dstr;
+ else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
+ LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
+ else
+ LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
SV *share;
- if ((share = gv_share(sstr))) {
+ if ((share = gv_share(sstr, param))) {
del_SV(dstr);
dstr = share;
+ ptr_table_store(PL_ptr_table, sstr, dstr);
#if 0
PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
HvNAME(GvSTASH(share)), GvNAME(share));
IoPAGE(dstr) = IoPAGE(sstr);
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
+ if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
+ /* I have no idea why fake dirp (rsfps)
+ should be treaded differently but otherwise
+ we end up with leaks -- sky*/
+ IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
+ IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
+ } else {
+ IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
+ IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
+ }
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
- IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
- IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
- IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
} else {
CvDEPTH(dstr) = 0;
}
- if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
- /* XXX padlists are real, but pretend to be not */
- AvREAL_on(CvPADLIST(sstr));
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
- AvREAL_off(CvPADLIST(sstr));
- AvREAL_off(CvPADLIST(dstr));
- }
- else
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
- if (!CvANON(sstr) || CvCLONED(sstr))
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
- else
- CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
+ PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+ CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
+ CvOUTSIDE(dstr) =
+ CvWEAKOUTSIDE(sstr)
+ ? cv_dup( CvOUTSIDE(sstr), param)
+ : cv_dup_inc(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
+ ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
break;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
: gv_dup((GV*)cx->blk_loop.iterdata, param));
- ncx->blk_loop.oldcurpad
- = (SV**)ptr_table_fetch(PL_ptr_table,
- cx->blk_loop.oldcurpad);
+ ncx->blk_loop.oldcomppad
+ = (PAD*)ptr_table_fetch(PL_ptr_table,
+ cx->blk_loop.oldcomppad);
ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
#define TOPLONG(ss,ix) ((ss)[ix].any_long)
#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
#define TOPIV(ss,ix) ((ss)[ix].any_iv)
+#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
+#define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_BOOL:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ longval = (long)POPBOOL(ss,ix);
+ TOPBOOL(nss,ix) = (bool)longval;
+ break;
+ case SAVEt_SET_SVFLAGS:
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
}
Create and return a new interpreter by cloning the current one.
+perl_clone takes these flags as parameters:
+
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
+threads->new doesn't.
+
+CLONEf_KEEP_PTR_TABLE
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
+code is in threads.xs create
+
+CLONEf_CLONE_HOST
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
+you don't need to do anything.
+
=cut
*/
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# ifdef DEBUGGING
- memset(my_perl, 0xab, sizeof(PerlInterpreter));
+ Poison(my_perl, 1, PerlInterpreter);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
param->flags = flags;
+ param->proto_perl = proto_perl;
/* arena roots */
PL_xiv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
#ifdef USE_REENTRANT_API
+ /* XXX: things like -Dm will segfault here in perlio, but doing
+ * PERL_SET_CONTEXT(proto_perl);
+ * breaks too many other things
+ */
Perl_reentrant_init(aTHX);
#endif
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
- i = PL_origargc;
- New(0, PL_origargv, i+1, char*);
- PL_origargv[i] = '\0';
- while (i-- > 0) {
- PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
- }
+ PL_origargv = proto_perl->Iorigargv;
param->stashes = newAV(); /* Setup array of objects to call clone on */
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
PL_lineary = av_dup(proto_perl->Ilineary, param);
PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
PL_curstash = hv_dup(proto_perl->Tcurstash, param);
- PL_nullstash = hv_dup(proto_perl->Inullstash, param);
PL_debstash = hv_dup(proto_perl->Idebstash, param);
PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
+ PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
/* internal state */
PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
PL_maxo = proto_perl->Imaxo;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
PL_op_mask = Nullch;
+ /* PL_asserting = proto_perl->Iasserting; */
/* current interpreter roots */
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
PL_compcv = cv_dup(proto_perl->Icompcv, param);
- PL_comppad = av_dup(proto_perl->Icomppad, param);
- PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
- PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
- PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
- PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
- proto_perl->Tcurpad);
+
+ PAD_CLONE_VARS(proto_perl, param);
#ifdef HAVE_INTERP_INTERN
sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
PL_egid = proto_perl->Iegid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
- PL_cop_seqmax = proto_perl->Icop_seqmax;
PL_op_seqmax = proto_perl->Iop_seqmax;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
PL_pidstatus = newHV(); /* XXX flag for cloning? */
PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
+ PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
PL_sighandlerp = proto_perl->Isighandlerp;
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
- i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
- PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
- PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
- PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ /* XXX This is probably masking the deeper issue of why
+ * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
+ * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
+ * (A little debugging with a watchpoint on it may help.)
+ */
+ if (SvANY(proto_perl->Ilinestr)) {
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
+ i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
+ PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
+ PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
+ PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
+ PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ }
+ else {
+ PL_linestr = NEWSV(65,79);
+ sv_upgrade(PL_linestr,SVt_PVIV);
+ sv_setpvn(PL_linestr,"",0);
+ PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ }
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
- PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_pending_ident = proto_perl->Ipending_ident;
PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
- PL_min_intro_pending = proto_perl->Imin_intro_pending;
- PL_max_intro_pending = proto_perl->Imax_intro_pending;
- PL_padix = proto_perl->Ipadix;
- PL_padix_floor = proto_perl->Ipadix_floor;
- PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
-
- i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
- PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
- PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_last_lop_op = proto_perl->Ilast_lop_op;
+ /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
+ if (SvANY(proto_perl->Ilinestr)) {
+ i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
+ PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
+ PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ PL_last_lop_op = proto_perl->Ilast_lop_op;
+ }
+ else {
+ PL_last_uni = SvPVX(PL_linestr);
+ PL_last_lop = SvPVX(PL_linestr);
+ PL_last_lop_op = 0;
+ }
PL_in_my = proto_perl->Iin_my;
PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
+
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
+
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
+
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+
+ /* Not really needed/useful since the reenrant_retint is "volatile",
+ * but do it for consistency's sake. */
+ PL_reentrant_retint = proto_perl->Ireentrant_retint;
+
+ /* Hooks to shared SVs and locks. */
+ PL_sharehook = proto_perl->Isharehook;
+ PL_lockhook = proto_perl->Ilockhook;
+ PL_unlockhook = proto_perl->Iunlockhook;
+ PL_threadhook = proto_perl->Ithreadhook;
+
+ PL_runops_std = proto_perl->Irunops_std;
+ PL_runops_dbg = proto_perl->Irunops_dbg;
+
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = proto_perl->Ippid;
+#endif
+
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
PL_last_swash_klen = 0;
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
+ PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
PL_protect = proto_perl->Tprotect;
#endif
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
- PL_av_fetch_sv = Nullsv;
- PL_hv_fetch_sv = Nullsv;
- Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
+ PL_hv_fetch_ent_mh = Nullhe;
PL_modcount = proto_perl->Tmodcount;
PL_lastgotoprobe = Nullop;
PL_dumpindent = proto_perl->Tdumpindent;
PL_watchok = Nullch;
PL_regdummy = proto_perl->Tregdummy;
- PL_regcomp_parse = Nullch;
- PL_regxend = Nullch;
- PL_regcode = (regnode*)NULL;
- PL_regnaughty = 0;
- PL_regsawback = 0;
PL_regprecomp = Nullch;
PL_regnpar = 0;
PL_regsize = 0;
- PL_regflags = 0;
- PL_regseen = 0;
- PL_seen_zerolen = 0;
- PL_seen_evals = 0;
- PL_regcomp_rx = (regexp*)NULL;
- PL_extralen = 0;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reg_whilem_seen = 0;
PL_reginput = Nullch;
PL_regbol = Nullch;
PL_regeol = Nullch;
PL_regstartp = (I32*)NULL;
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
+ PL_reglastcloseparen = (U32*)NULL;
PL_regtill = Nullch;
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_reg_curpm = (PMOP*)NULL;
PL_reg_oldsaved = Nullch;
PL_reg_oldsavedlen = 0;
+#ifdef PERL_COPY_ON_WRITE
+ PL_nrs = Nullsv;
+#endif
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
PL_reg_poscache = Nullch;
/* Pluggable optimizer */
PL_peepp = proto_perl->Tpeepp;
+ PL_stashcache = newHV();
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
- SV *uni;
- STRLEN len;
- char *s;
- dSP;
- ENTER;
- SAVETMPS;
- PUSHMARK(sp);
- EXTEND(SP, 3);
- XPUSHs(encoding);
- XPUSHs(sv);
- XPUSHs(&PL_sv_yes);
- PUTBACK;
- call_method("decode", G_SCALAR);
- SPAGAIN;
- uni = POPs;
- PUTBACK;
- s = SvPV(uni, len);
- if (s != SvPVX(sv)) {
- SvGROW(sv, len);
- Move(s, SvPVX(sv), len, char);
- SvCUR_set(sv, len);
- }
- FREETMPS;
- LEAVE;
- SvUTF8_on(sv);
- }
- return SvPVX(sv);
+ if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
+ SV *uni;
+ STRLEN len;
+ char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 3);
+ XPUSHs(encoding);
+ XPUSHs(sv);
+/*
+ NI-S 2002/07/09
+ Passing sv_yes is wrong - it needs to be or'ed set of constants
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ remove converted chars from source.
+
+ Both will default the value - let them.
+
+ XPUSHs(&PL_sv_yes);
+*/
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV(uni, len);
+ if (s != SvPVX(sv)) {
+ SvGROW(sv, len + 1);
+ Move(s, SvPVX(sv), len, char);
+ SvCUR_set(sv, len);
+ SvPVX(sv)[len] = 0;
+ }
+ FREETMPS;
+ LEAVE;
+ SvUTF8_on(sv);
+ }
+ return SvPVX(sv);
}
+/*
+=for apidoc sv_cat_decode
+
+The encoding is assumed to be an Encode object, the PV of the ssv is
+assumed to be octets in that encoding and decoding the input starts
+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
+to the last input position on the ssv.
+
+Returns TRUE if the terminator was found, else returns FALSE.
+
+=cut */
+
+bool
+Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
+ SV *ssv, int *offset, char *tstr, int tlen)
+{
+ bool ret = FALSE;
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ SV *offsv;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 6);
+ XPUSHs(encoding);
+ XPUSHs(dsv);
+ XPUSHs(ssv);
+ XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
+ XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
+ PUTBACK;
+ call_method("cat_decode", G_SCALAR);
+ SPAGAIN;
+ ret = SvTRUE(TOPs);
+ *offset = SvIV(offsv);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ }
+ else
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+ return ret;
+}
https://perl5.git.perl.org / perl5.git / blobdiff