#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. */
+#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+ SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+ SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
+#define CAN_COW_FLAGS (SVp_POK|SVf_POK)
+#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 */
xpvbm->xpv_pv = 0;
}
-#ifdef LEAKTEST
-# define my_safemalloc(s) (void*)safexmalloc(717,s)
-# define my_safefree(p) safexfree((char*)p)
-#else
-# define my_safemalloc(s) (void*)safemalloc(s)
-# define my_safefree(p) safefree((char*)p)
-#endif
+#define my_safemalloc(s) (void*)safemalloc(s)
+#define my_safefree(p) safefree((char*)p)
#ifdef PURIFY
MAGIC* magic = NULL;
HV* stash = Nullhv;
- if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (mt != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvTYPE(sv) == mt)
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
-#if defined(MYMALLOC) && !defined(LEAKTEST)
+#ifdef MYMALLOC
STRLEN l = malloced_size((void*)SvPVX(sv));
if (newlen <= l) {
SvLEN_set(sv, l);
Renew(s,newlen,char);
}
else {
- /* sv_force_normal_flags() must not try to unshare the new
- PVX we allocate below. AMS 20010713 */
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
- }
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
+ (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
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))
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))
{
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";
if ( ((SvFLAGS(sv) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
- && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
need a newline */
mg->mg_len++; /* save space for it */
need_newline = 1; /* note to add it */
+ break;
}
}
}
mg->mg_ptr[mg->mg_len] = 0;
}
PL_reginterp_cnt += re->program[0].next_off;
+
+ if (re->reganch & ROPT_UTF8)
+ SvUTF8_on(origsv);
+ else
+ SvUTF8_off(origsv);
*lp = mg->mg_len;
return mg->mg_ptr;
}
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))
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
void
Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
{
- SV *tmpsv;
-
- if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) &&
- (tmpsv = AMG_CALLun(ssv,string))) {
- if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
- SvSetSV(dsv,tmpsv);
- return;
- }
- } else {
- tmpsv = sv_newmortal();
- }
- {
- STRLEN len;
- char *s;
- s = SvPV(ssv,len);
- sv_setpvn(tmpsv,s,len);
- if (SvUTF8(ssv))
- SvUTF8_on(tmpsv);
- else
- SvUTF8_off(tmpsv);
- SvSetSV(dsv,tmpsv);
- }
+ STRLEN len;
+ char *s;
+ s = SvPV(ssv,len);
+ sv_setpvn(dsv,s,len);
+ if (SvUTF8(ssv))
+ SvUTF8_on(dsv);
+ else
+ SvUTF8_off(dsv);
}
/*
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)
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)
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 */
}
}
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);
+ 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)
{
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 addtion, 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);
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)
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 - instead we could
- special case them in sv_free() -- NI-S
+ have its REFCNT incremented to keep it in existence.
*/
if (!obj || obj == sv ||
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
+
+ /* Normal self-ties simply pass a null object, and instead of
+ using mg_obj directly, use the SvTIED_obj macro to produce a
+ new RV as needed. For glob "self-ties", we are tieing the PVIO
+ with an RV obj pointing to the glob containing the PVIO. In
+ this case, to avoid a reference loop, we need to weaken the
+ reference.
+ */
+
+ if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
+ obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
+ {
+ sv_rvweaken(obj);
+ }
+
mg->mg_type = how;
mg->mg_len = namlen;
if (name) {
MAGIC* mg;
MGVTBL *vtable = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+#endif
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling
&& how != PERL_MAGIC_regex_global
case PERL_MAGIC_dbline:
vtable = &PL_vtbl_dbline;
break;
-#ifdef USE_5005THREADS
- case PERL_MAGIC_mutex:
- vtable = &PL_vtbl_mutex;
- break;
-#endif /* USE_5005THREADS */
#ifdef USE_LOCALE_COLLATE
case PERL_MAGIC_collxfrm:
vtable = &PL_vtbl_collxfrm;
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_vstring:
+ vtable = 0;
+ break;
case PERL_MAGIC_substr:
vtable = &PL_vtbl_substr;
break;
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
U32 refcnt = SvREFCNT(sv);
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
sv_clear(sv);
assert(!SvREFCNT(sv));
StructCopy(nsv,sv,SV);
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW_normal(nsv)) {
+ /* We need to follow the pointers around the loop to make the
+ previous SV point to sv, rather than nsv. */
+ SV *next;
+ SV *current = nsv;
+ while ((next = SV_COW_NEXT_SV(current)) != nsv) {
+ assert(next);
+ current = next;
+ assert(SvPVX(current) == SvPVX(nsv));
+ }
+ /* Make the SV before us point to the SV after us. */
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "previous is\n");
+ sv_dump(current);
+ PerlIO_printf(Perl_debug_log,
+ "move it from 0x%"UVxf" to 0x%"UVxf"\n",
+ (UV) SV_COW_NEXT_SV(current), (UV) sv);
+ }
+ SV_COW_NEXT_SV_SET(current, sv);
+ }
+#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
del_SV(nsv);
PUSHMARK(SP);
PUSHs(&tmpref);
PUTBACK;
- call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
+ call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
SvREFCNT(sv)--;
POPSTACK;
SPAGAIN;
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:
}
if (cur1 == cur2)
- eq = memEQ(pv1, pv2, cur1);
+ eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
if (svrecode)
SvREFCNT_dec(svrecode);
I32 i = 0;
I32 rspara = 0;
- SV_CHECK_THINKFIRST(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ /* 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);
/* Accomodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
-#ifdef DJGPP /* This is basically undoing #17270 for DJGPP. See below. */
- if (cnt)
-#else
if (cnt > 0)
-#endif
- {
- i = (U8)buf[cnt - 1];
- }
- else {
+ i = (U8)buf[cnt - 1];
+ else
i = EOF;
- }
}
-#ifndef DJGPP /* This is basically undoing #17270 for DJGPP. See above.*/
- if (cnt > 0)
-#endif
- {
- if (append)
- sv_catpvn(sv, (char *) buf, cnt);
- else
- sv_setpvn(sv, (char *) buf, cnt);
- }
+ 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);
+ else
+ sv_setpvn(sv, (char *) buf, cnt);
if (i != EOF && /* joy */
(!rslen ||
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);
char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
- sv_force_normal(sv);
+ sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
*lp = SvCUR(sv);
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>");
+ return HvNAME(SvSTASH(sv));
}
else {
switch (SvTYPE(sv)) {
case SVt_PVNV:
case SVt_PVMG:
case SVt_PVBM:
+ if (SvVOK(sv))
+ return "VSTRING";
if (SvROK(sv))
return "REF";
else
new_SV(sv);
- SV_CHECK_THINKFIRST(rv);
+ SV_CHECK_THINKFIRST_COW_DROP(rv);
SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
+ if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (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 */
}
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) {
bool has_precis = FALSE;
STRLEN precis = 0;
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 = Nullsv;
We allow format specification elements in this order:
\d+\$ explicit format parameter index
[-+ 0#]+ flags
- v|*(\d+\$)?v vector with optional (optionally specified) arg
+ v|\*(\d+\$)?v vector with optional (optionally specified) arg
\d+|\*(\d+\$)? width using optional (optionally specified) arg
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
[hlqLV] size
#endif
case 'l':
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
- if (*(q + 1) == 'l') { /* lld, llf */
+ if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
break;
nv = (args && !vectorize) ?
#if LONG_DOUBLESIZE > DOUBLESIZE
intsize == 'q' ?
- va_arg(*args, long double) :
- va_arg(*args, double)
+ va_arg(*args, long double) :
+ va_arg(*args, double)
#else
- va_arg(*args, double)
+ va_arg(*args, double)
#endif
: SvNVx(argsv);
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);
#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
Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
- SvRV(dstr) = SvWEAKREF(sstr)
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
}
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
+ if (SvREADONLY(sstr) && SvFAKE(sstr)) {
+ /* Not that normal - actually sstr is copy on write.
+ But we are a true, independant SV, so: */
+ SvREADONLY_off(dstr);
+ SvFAKE_off(dstr);
+ }
}
else {
/* Special case - not normally malloced for some reason */
else {
/* Some other special case - random pointer */
SvPVX(dstr) = SvPVX(sstr);
- }
+ }
}
}
else {
} 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);
+ PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+ /* anon prototypes aren't refcounted */
if (!CvANON(sstr) || CvCLONED(sstr))
CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
else
CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
+ CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
CvFLAGS(dstr) = CvFLAGS(sstr);
CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
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);
/* 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 */
/* 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);
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_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;
-
/* XXX See comment on SvANY(proto_perl->Ilinestr) above */
if (SvANY(proto_perl->Ilinestr)) {
i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
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);
+ int vary = FALSE;
+ SV *uni;
+ STRLEN len;
+ char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ 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
Both will default the value - let them.
- XPUSHs(&PL_sv_yes);
+ 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);
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV(uni, len);
+ {
+ U8 *t = (U8 *)s, *e = (U8 *)s + len;
+ while (t < e) {
+ if ((vary = !UTF8_IS_INVARIANT(*t++)))
+ break;
+ }
+ }
+ if (s != SvPVX(sv)) {
+ SvGROW(sv, len + 1);
+ Move(s, SvPVX(sv), len, char);
+ SvCUR_set(sv, len);
+ SvPVX(sv)[len] = 0;
+ }
+ FREETMPS;
+ LEAVE;
+ if (vary)
+ SvUTF8_on(sv);
+ SvUTF8_on(sv);
}
return SvPVX(sv);
}