/* sv.c
*
- * Copyright (c) 1991-2001, 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_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 */
}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free non-arena SV: 0x%"UVxf,
PTR2UV(p));
return;
Perl_report_uninit(pTHX)
{
if (PL_op)
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
" in ", OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
}
/* grab a new IV body from the free list, allocating more if necessary */
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
bool
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
- char* pv;
- U32 cur;
- U32 len;
- IV iv;
- NV nv;
- MAGIC* magic;
- HV* stash;
+ char* pv = NULL;
+ U32 cur = 0;
+ U32 len = 0;
+ IV iv = 0;
+ NV nv = 0.0;
+ 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)
}
else
s = SvPVX(sv);
+
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);
+ }
}
SvPV_set(sv, s);
SvLEN_set(sv, newlen);
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 (PL_op)
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric", pv);
}
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))
sign = 1;
}
do {
- *--ptr = '0' + (uv % 10);
+ *--ptr = '0' + (char)(uv % 10);
} while (uv /= 10);
if (sign)
*--ptr = '-';
return ptr;
}
-/* For backwards-compatibility only. sv_2pv() is normally #def'ed to
- * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
*/
char *
{
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;
char ch;
int left = 0;
int right = 4;
- U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
+ char need_newline = 0;
+ U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
while((ch = *fptr++)) {
if(reganch & 1) {
}
mg->mg_len = re->prelen + 4 + left;
+ /*
+ * If /x was used, we have to worry about a regex
+ * ending with a comment later being embedded
+ * within another regex. If so, we don't want this
+ * regex's "commentization" to leak out to the
+ * right part of the enclosing regex, we must cap
+ * it with a newline.
+ *
+ * So, if /x was used, we scan backwards from the
+ * end of the regex. If we find a '#' before we
+ * find a newline, we need to add a newline
+ * ourself. If we find a '\n' first (or if we
+ * don't find '#' or '\n'), we don't need to add
+ * anything. -jfriedl
+ */
+ if (PMf_EXTENDED & re->reganch)
+ {
+ char *endptr = re->precomp + re->prelen;
+ while (endptr >= re->precomp)
+ {
+ char c = *(endptr--);
+ if (c == '\n')
+ break; /* don't need another */
+ if (c == '#') {
+ /* we end while in a comment, so we
+ need a newline */
+ mg->mg_len++; /* save space for it */
+ need_newline = 1; /* note to add it */
+ break;
+ }
+ }
+ }
+
New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
Copy("(?", mg->mg_ptr, 2, char);
Copy(reflags, mg->mg_ptr+2, left, char);
Copy(":", mg->mg_ptr+left+2, 1, char);
Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
+ if (need_newline)
+ mg->mg_ptr[mg->mg_len - 2] = '\n';
mg->mg_ptr[mg->mg_len - 1] = ')';
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":"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));
ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
else
ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
Move(ptr,SvPVX(sv),ebuf - ptr,char);
SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
}
/*
+=for apidoc sv_copypv
+
+Copies a stringified representation of the source SV into the
+destination SV. Automatically performs any necessary mg_get and
+coercion of numeric values into strings. Guaranteed to preserve
+UTF-8 flag even from overloaded objects. Similar in nature to
+sv_2pv[_flags] but operates directly on an SV instead of just the
+string. Mostly uses sv_2pv_flags to do its work, except when that
+would lose the UTF-8'ness of the PV.
+
+=cut
+*/
+
+void
+Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
+{
+ 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.
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
(!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return SvTRUE(tmpsv);
+ return (bool)SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
}
}
-/*
-=for apidoc sv_utf8_upgrade
-
-Convert the PV of an SV to its UTF8-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.
+/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
+ * this function provided for binary compatibility only
+ */
-=cut
-*/
STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
}
/*
+=for apidoc sv_utf8_upgrade
+
+Convert the PV of an SV to its UTF8-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.
+
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=for apidoc sv_utf8_upgrade_flags
Convert the PV of an SV to its UTF8-encoded form.
will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=cut
*/
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)
- Perl_sv_recode_to_utf8(aTHX_ sv, 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
* had a FLAG in SVs to signal if there are any hibit
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
+This is not as a general purpose Unicode to byte encoding interface:
+use the Encode extension for that.
+
=cut
*/
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)
return FALSE;
-#ifdef USE_BYTES_DOWNGRADES
- else if (IN_BYTES) {
- U8 *d = s;
- U8 *e = (U8 *) SvEND(sv);
- int first = 1;
- while (s < e) {
- UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
- if (first && ch > 255) {
- if (PL_op)
- Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
- OP_DESC(PL_op);
- else
- Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
- first = 0;
- }
- *d++ = ch;
- s += len;
- }
- *d = '\0';
- len = (d - (U8 *) SvPVX(sv));
- }
-#endif
else {
if (PL_op)
Perl_croak(aTHX_ "Wide character in %s",
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
C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
C<SvSetMagicSV_nosteal>.
-
-=cut
-*/
-
-/* sv_setsv() is aliased to Perl_sv_setsv_macro; 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_flags
Copies the contents of the source SV C<ssv> into the destination SV
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;
default:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
- if (SvTYPE(sstr) != stype) {
+ if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV)
goto glob_assign;
if (stype == SVt_PVLV)
(void)SvUPGRADE(dstr, SVt_PVNV);
else
- (void)SvUPGRADE(dstr, stype);
+ (void)SvUPGRADE(dstr, (U32)stype);
}
sflags = SvFLAGS(sstr);
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);
|| sv_cmp(cv_const_sv(cv),
cv_const_sv((CV*)sref)))))
{
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv)
- ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined",
+ ? "Constant subroutine %s::%s redefined"
+ : "Subroutine %s::%s redefined",
+ HvNAME(GvSTASH((GV*)dstr)),
GvENAME((GV*)dstr));
}
}
- cv_ckproto(cv, (GV*)dstr,
- SvPOK(sref) ? SvPVX(sref) : Nullch);
+ if (!intro)
+ cv_ckproto(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX(sref) : Nullch);
}
GvCV(dstr) = (CV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
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 */
+ 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
+ && 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';
+ (void)SvPOK_only(dstr);
+ } 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;
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)
else {
if (dtype == SVt_PVGV) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
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 (PL_curcop != &PL_compiling)
+ 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);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
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);
}
else if (PL_curcop != &PL_compiling)
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;
}
-/*
-=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.
-Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
-
-=cut
-*/
+/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
+ * this function provided for binary compatibility only
+ */
-/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
- for binary compatibility only
-*/
void
Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
}
/*
+=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.
+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
SvSETMAGIC(sv);
}
-/*
-=for apidoc sv_catsv
-
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
-not 'set' magic. See C<sv_catsv_mg>.
-
-=cut */
+/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
+ * this function provided for binary compatibility only
+ */
-/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
- for binary compatibility only
-*/
void
Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
}
/*
+=for apidoc sv_catsv
+
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
+not 'set' magic. See C<sv_catsv_mg>.
+
=for apidoc sv_catsv_flags
Concatenates the string from SV C<ssv> onto the end of the string in
}
return sv;
}
-
/*
-=for apidoc sv_magic
+=for apidoc sv_magicext
-Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
-then adds a new magic item of type C<how> to the head of the magic list.
+Adds magic to an SV, upgrading it if necessary. Applies the
+supplied vtable and returns pointer to the magic added.
+
+Note that sv_magicext will allow things that sv_magic will not.
+In particular you can add magic to SvREADONLY SVs and and more than
+one instance of the same 'how'
+
+I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
+if C<namelen> is zero then C<name> is stored as-is and - as another special
+case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
+an C<SV*> and has its REFCNT incremented
-C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+(This is now used as a subroutine by sv_magic.)
=cut
*/
-
-void
-Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+MAGIC *
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+ const char* name, I32 namlen)
{
MAGIC* mg;
- if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling
- && how != PERL_MAGIC_regex_global
- && how != PERL_MAGIC_bm
- && how != PERL_MAGIC_fm
- && how != PERL_MAGIC_sv
- )
- {
- Perl_croak(aTHX_ PL_no_modify);
- }
- }
- if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
- if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
- if (how == PERL_MAGIC_taint)
- mg->mg_len |= 1;
- return;
- }
- }
- else {
- (void)SvUPGRADE(sv, SVt_PVMG);
+ if (SvTYPE(sv) < SVt_PVMG) {
+ (void)SvUPGRADE(sv, SVt_PVMG);
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
/* 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) {
- if (namlen >= 0)
+ if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ else
+ mg->mg_ptr = (char *) name;
+ }
+ mg->mg_virtual = vtable;
+
+ mg_magical(sv);
+ if (SvGMAGICAL(sv))
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+ return mg;
+}
+
+/*
+=for apidoc sv_magic
+
+Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
+then adds a new magic item of type C<how> to the head of the magic list.
+
+=cut
+*/
+
+void
+Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+{
+ 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
+ && how != PERL_MAGIC_regex_global
+ && how != PERL_MAGIC_bm
+ && how != PERL_MAGIC_fm
+ && how != PERL_MAGIC_sv
+ )
+ {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+ }
+ if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
+ if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
+ /* sv_magic() refuses to add a magic of the same 'how' as an
+ existing one
+ */
+ if (how == PERL_MAGIC_taint)
+ mg->mg_len |= 1;
+ return;
+ }
}
switch (how) {
case PERL_MAGIC_sv:
- mg->mg_virtual = &PL_vtbl_sv;
+ vtable = &PL_vtbl_sv;
break;
case PERL_MAGIC_overload:
- mg->mg_virtual = &PL_vtbl_amagic;
+ vtable = &PL_vtbl_amagic;
break;
case PERL_MAGIC_overload_elem:
- mg->mg_virtual = &PL_vtbl_amagicelem;
+ vtable = &PL_vtbl_amagicelem;
break;
case PERL_MAGIC_overload_table:
- mg->mg_virtual = &PL_vtbl_ovrld;
+ vtable = &PL_vtbl_ovrld;
break;
case PERL_MAGIC_bm:
- mg->mg_virtual = &PL_vtbl_bm;
+ vtable = &PL_vtbl_bm;
break;
case PERL_MAGIC_regdata:
- mg->mg_virtual = &PL_vtbl_regdata;
+ vtable = &PL_vtbl_regdata;
break;
case PERL_MAGIC_regdatum:
- mg->mg_virtual = &PL_vtbl_regdatum;
+ vtable = &PL_vtbl_regdatum;
break;
case PERL_MAGIC_env:
- mg->mg_virtual = &PL_vtbl_env;
+ vtable = &PL_vtbl_env;
break;
case PERL_MAGIC_fm:
- mg->mg_virtual = &PL_vtbl_fm;
+ vtable = &PL_vtbl_fm;
break;
case PERL_MAGIC_envelem:
- mg->mg_virtual = &PL_vtbl_envelem;
+ vtable = &PL_vtbl_envelem;
break;
case PERL_MAGIC_regex_global:
- mg->mg_virtual = &PL_vtbl_mglob;
+ vtable = &PL_vtbl_mglob;
break;
case PERL_MAGIC_isa:
- mg->mg_virtual = &PL_vtbl_isa;
+ vtable = &PL_vtbl_isa;
break;
case PERL_MAGIC_isaelem:
- mg->mg_virtual = &PL_vtbl_isaelem;
+ vtable = &PL_vtbl_isaelem;
break;
case PERL_MAGIC_nkeys:
- mg->mg_virtual = &PL_vtbl_nkeys;
+ vtable = &PL_vtbl_nkeys;
break;
case PERL_MAGIC_dbfile:
- SvRMAGICAL_on(sv);
- mg->mg_virtual = 0;
+ vtable = 0;
break;
case PERL_MAGIC_dbline:
- mg->mg_virtual = &PL_vtbl_dbline;
- break;
-#ifdef USE_5005THREADS
- case PERL_MAGIC_mutex:
- mg->mg_virtual = &PL_vtbl_mutex;
+ vtable = &PL_vtbl_dbline;
break;
-#endif /* USE_5005THREADS */
#ifdef USE_LOCALE_COLLATE
case PERL_MAGIC_collxfrm:
- mg->mg_virtual = &PL_vtbl_collxfrm;
+ vtable = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
case PERL_MAGIC_tied:
- mg->mg_virtual = &PL_vtbl_pack;
+ vtable = &PL_vtbl_pack;
break;
case PERL_MAGIC_tiedelem:
case PERL_MAGIC_tiedscalar:
- mg->mg_virtual = &PL_vtbl_packelem;
+ vtable = &PL_vtbl_packelem;
break;
case PERL_MAGIC_qr:
- mg->mg_virtual = &PL_vtbl_regexp;
+ vtable = &PL_vtbl_regexp;
break;
case PERL_MAGIC_sig:
- mg->mg_virtual = &PL_vtbl_sig;
+ vtable = &PL_vtbl_sig;
break;
case PERL_MAGIC_sigelem:
- mg->mg_virtual = &PL_vtbl_sigelem;
+ vtable = &PL_vtbl_sigelem;
break;
case PERL_MAGIC_taint:
- mg->mg_virtual = &PL_vtbl_taint;
- mg->mg_len = 1;
+ vtable = &PL_vtbl_taint;
break;
case PERL_MAGIC_uvar:
- mg->mg_virtual = &PL_vtbl_uvar;
+ vtable = &PL_vtbl_uvar;
break;
case PERL_MAGIC_vec:
- mg->mg_virtual = &PL_vtbl_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:
- mg->mg_virtual = &PL_vtbl_substr;
+ vtable = &PL_vtbl_substr;
break;
case PERL_MAGIC_defelem:
- mg->mg_virtual = &PL_vtbl_defelem;
+ vtable = &PL_vtbl_defelem;
break;
case PERL_MAGIC_glob:
- mg->mg_virtual = &PL_vtbl_glob;
+ vtable = &PL_vtbl_glob;
break;
case PERL_MAGIC_arylen:
- mg->mg_virtual = &PL_vtbl_arylen;
+ vtable = &PL_vtbl_arylen;
break;
case PERL_MAGIC_pos:
- mg->mg_virtual = &PL_vtbl_pos;
+ vtable = &PL_vtbl_pos;
break;
case PERL_MAGIC_backref:
- mg->mg_virtual = &PL_vtbl_backref;
+ vtable = &PL_vtbl_backref;
break;
case PERL_MAGIC_ext:
/* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
- SvRMAGICAL_on(sv);
break;
default:
Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
- mg_magical(sv);
- if (SvGMAGICAL(sv))
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+
+ /* Rest of work is done else where */
+ mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+
+ switch (how) {
+ case PERL_MAGIC_taint:
+ mg->mg_len = 1;
+ break;
+ case PERL_MAGIC_ext:
+ case PERL_MAGIC_dbfile:
+ SvRMAGICAL_on(sv);
+ break;
+ }
}
/*
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len >= 0)
+ if (mg->mg_len > 0)
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);
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
- av_push(av,sv);
+ if (AvFILLp(av) >= AvMAX(av)) {
+ SV **svp = AvARRAY(av);
+ I32 i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] == &PL_sv_undef) {
+ svp[i] = sv; /* reuse the slot */
+ return;
+ }
+ i--;
+ }
+ av_extend(av, AvFILLp(av)+1);
+ }
+ AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
}
/* delete a back-reference to ourselves from the backref magic associated
SV **svp;
I32 i;
SV *tsv = SvRV(sv);
- MAGIC *mg;
+ MAGIC *mg = NULL;
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
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_ WARN_INTERNAL, "Reference miscount in sv_replace()");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
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 */
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_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
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))
- Perl_warner(aTHX_ WARN_DEBUGGING,
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Attempt to free temp prematurely: SV 0x%"UVxf,
PTR2UV(sv));
return;
=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;
- return Perl_utf8_length(aTHX_ s, s + len);
+ if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
+ ulen = mg->mg_len;
+ 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) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ *mgp = mg_find(sv, PERL_MAGIC_utf8);
+ }
+ 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);
+
+ (*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;
+ 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;
+
+ 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;
+ }
+ }
+ }
+ }
+ return found;
+}
+
/*
=for apidoc sv_pos_u2b
=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;
+ }
+ }
+ else {
+ *offsetp = 0;
+ if (lenp)
+ *lenp = 0;
}
return;
}
=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)
- return;
+ if (!sv)
+ return;
+
+ s = (U8*)SvPV(sv, len);
+ if ((I32)len < *offsetp)
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
+ 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;
+ }
+ }
+ }
+ }
+
+ 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);
- s = (U8*)SvPV(sv, len);
- if (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++;
+ 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;
}
- else
- break;
+
+ *offsetp = len;
}
- *offsetp = len;
return;
}
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
+ SV* svrecode = Nullsv;
if (!sv1) {
pv1 = "";
else
pv2 = SvPV(sv2, cur2);
- /* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- bool is_utf8 = TRUE;
- /* UTF-8ness differs */
-
- if (SvUTF8(sv1)) {
- /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
- if (pv != pv1)
- pv1 = tpv = pv;
- }
- else {
- /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
- if (pv != pv2)
- pv2 = tpv = pv;
- }
- if (is_utf8) {
- /* Downgrade not possible - cannot be eq */
- return FALSE;
- }
+ /* Differing utf8ness.
+ * Do not UTF8size the comparands as a side-effect. */
+ if (PL_encoding) {
+ if (SvUTF8(sv1)) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV(svrecode, cur2);
+ }
+ else {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV(svrecode, cur1);
+ }
+ /* Now both are in UTF-8. */
+ if (cur1 != cur2)
+ return FALSE;
+ }
+ else {
+ bool is_utf8 = TRUE;
+
+ if (SvUTF8(sv1)) {
+ /* sv1 is the UTF-8 one,
+ * if is equal it must be downgrade-able */
+ char *pv = (char*)bytes_from_utf8((U8*)pv1,
+ &cur1, &is_utf8);
+ if (pv != pv1)
+ pv1 = tpv = pv;
+ }
+ else {
+ /* sv2 is the UTF-8 one,
+ * if is equal it must be downgrade-able */
+ char *pv = (char *)bytes_from_utf8((U8*)pv2,
+ &cur2, &is_utf8);
+ if (pv != pv2)
+ pv2 = tpv = pv;
+ }
+ if (is_utf8) {
+ /* Downgrade not possible - cannot be eq */
+ return FALSE;
+ }
+ }
}
if (cur1 == cur2)
- eq = memEQ(pv1, pv2, cur1);
+ eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
- if (tpv != Nullch)
+ if (svrecode)
+ SvREFCNT_dec(svrecode);
+
+ if (tpv)
Safefree(tpv);
return eq;
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
- char *pv1, *pv2;
+ char *pv1, *pv2, *tpv = Nullch;
I32 cmp;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ SV *svrecode = Nullsv;
if (!sv1) {
pv1 = "";
else
pv1 = SvPV(sv1, cur1);
- if (!sv2){
+ if (!sv2) {
pv2 = "";
cur2 = 0;
}
else
pv2 = SvPV(sv2, cur2);
- /* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+ /* Differing utf8ness.
+ * Do not UTF8size the comparands as a side-effect. */
if (SvUTF8(sv1)) {
- pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
- pv2tmp = TRUE;
+ if (PL_encoding) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV(svrecode, cur2);
+ }
+ else {
+ pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ }
}
else {
- pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
- pv1tmp = TRUE;
+ if (PL_encoding) {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV(svrecode, cur1);
+ }
+ else {
+ pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ }
}
}
}
}
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (svrecode)
+ SvREFCNT_dec(svrecode);
+
+ if (tpv)
+ Safefree(tpv);
return cmp;
}
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 (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 (PL_curcop == &PL_compiling) {
/* 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, 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 (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && 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;
}
else {
shortbuffered = 0;
/* remember that cnt can be negative */
- SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
+ 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);
SvGROW(sv, bpx + cnt + 2);
bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
- *bp++ = i; /* store character from PerlIO_getc */
+ *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
if (rslen && (STDCHAR)i == rslast) /* all done for now? */
goto thats_all_folks;
}
thats_all_folks:
- if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
+ if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
thats_really_all_folks:
if (rslen) {
register STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
- while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
cnt = bp - buf;
}
/* 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 (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)
Perl_croak(aTHX_ PL_no_modify);
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)
Perl_croak(aTHX_ PL_no_modify);
return Nullsv;
if (SvTYPE(old) == SVTYPEMASK) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return Nullsv;
}
new_SV(sv);
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv)
+ if (gv == PL_envgv
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
+ }
#endif
}
}
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;
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
- GV *gv;
- CV *cv;
+ GV *gv = Nullgv;
+ CV *cv = Nullcv;
STRLEN n_a;
if (!sv)
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);
}
-/*
-=for apidoc sv_pv
-
-A private implementation of the C<SvPV_nolen> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
char *
Perl_sv_pv(pTHX_ SV *sv)
}
/*
+=for apidoc sv_pv
+
+Use the C<SvPV_nolen> macro instead
+
=for apidoc sv_pvn
A private implementation of the C<SvPV> macro for compilers which can't
return sv_2pv(sv, lp);
}
-/* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
- */
char *
Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
return sv_2pv_flags(sv, lp, 0);
}
-/*
-=for apidoc sv_pvn_force
-
-Get a sensible string out of the SV somehow.
-A private implementation of the C<SvPV_force> macro for compilers which
-can't cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
+/* 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)
}
/*
+=for apidoc sv_pvn_force
+
+Get a sensible string out of the SV somehow.
+A private implementation of the C<SvPV_force> macro for compilers which
+can't cope with complex macro expressions. Always use the macro instead.
+
=for apidoc sv_pvn_force_flags
Get a sensible string out of the SV somehow.
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- char *s;
+ 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);
}
-/*
-=for apidoc sv_pvbyte
-
-A private implementation of the C<SvPVbyte_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
+/* 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)
}
/*
+=for apidoc sv_pvbyte
+
+Use C<SvPVbyte_nolen> instead.
+
=for apidoc sv_pvbyten
A private implementation of the C<SvPVbyte> macro for compilers
return sv_pvn_force(sv,lp);
}
-/*
-=for apidoc sv_pvutf8
-
-A private implementation of the C<SvPVutf8_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
+/* 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)
}
/*
+=for apidoc sv_pvutf8
+
+Use the C<SvPVutf8_nolen> macro instead
+
=for apidoc sv_pvutf8n
A private implementation of the C<SvPVutf8> macro for compilers
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" : "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) {
}
/* 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 */
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;
+
+ has_utf8 = pat_utf8 = DO_UTF8(sv);
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
}
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;
* 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 */
+ /* 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;
+ char c = 0;
int i;
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) {
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);
/* SIZE */
switch (*q) {
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#ifdef WIN32
+ case 'I': /* Ix, I32x, and I64x */
+# ifdef WIN64
+ if (q[1] == '6' && q[2] == '4') {
+ q += 3;
+ intsize = 'q';
+ break;
+ }
+# endif
+ if (q[1] == '3' && q[2] == '2') {
+ q += 3;
+ break;
+ }
+# ifdef WIN64
+ intsize = 'q';
+# endif
+ q++;
+ break;
+#endif
+#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;
if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
&& (n == 2 || !isDIGIT(s[n-3])))
{
- Perl_warner(aTHX_ WARN_Y2K,
+ Perl_warner(aTHX_ packWARN(WARN_Y2K),
"Possible Y2K bug: %%%c %s",
c, "format string following '19'");
}
/* 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);
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
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,
(UV)c & 0xFF);
} else
sv_catpv(msg, "end of string");
- Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
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);
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
- for (i = 0; i < esignlen; i++)
+ for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (gap && !left) {
p += gap;
}
if (esignlen && fill != '0') {
- for (i = 0; i < esignlen; i++)
+ for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (zeros) {
#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
s->min_offset = r->substrs->data[i].min_offset;
s->max_offset = r->substrs->data[i].max_offset;
s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
+ s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
}
ret->regstclass = NULL;
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_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len >= 0) {
+ if (mg->mg_len > 0) {
nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
if (mg->mg_type == PERL_MAGIC_overload_table &&
AMT_AMAGIC((AMT*)mg->mg_ptr))
else if (mg->mg_len == HEf_SVKEY)
nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
}
+ if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
+ CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
+ }
mgprev = nmg;
}
return mgret;
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);
}
}
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);
}
else if (SvPVX(sstr)) {
/* Has something there */
if (SvLEN(sstr)) {
- /* Normal PV - clone whole allocated space */
+ /* 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);
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- !!HvSHAREKEYS(sstr), param);
+ (bool)!!HvSHAREKEYS(sstr),
+ param);
++i;
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
+ dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
+ (bool)!!HvSHAREKEYS(sstr), param);
}
else {
SvPVX(dstr) = Nullch;
} 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;
default:
- Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
+ Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(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)
/* see if it is part of the interpreter structure */
if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
- else
+ else {
ret = v;
+ }
return ret;
}
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_SHARED_PVREF: /* char* in shared space */
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = savesharedpv(c);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ break;
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
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;
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 paramters:
+
+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
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ Perl_reentrant_init(aTHX);
#endif
/* create SV map for pointer relocation */
SvNVX(&PL_sv_yes) = 1;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
- /* create shared string table */
+ /* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
hv_ksplit(PL_strtab, 512);
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
- PL_compiling = proto_perl->Icompiling;
- PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
- PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
+ PL_compiling = proto_perl->Icompiling;
+
+ /* These two PVs will be free'd special way so must set them same way op.c does */
+ PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+
+ PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
/* 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 */
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
/* Clone the regex array */
PL_regex_padav = newAV();
{
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_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+ PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+ PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_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_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
+ PL_hash_seed = proto_perl->Ihash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
PL_retstack_ix = proto_perl->Tretstack_ix;
PL_retstack_max = proto_perl->Tretstack_max;
Newz(54, PL_retstack, PL_retstack_max, OP*);
- Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
+ Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
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_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;
}