#define ASSERT_UTF8_CACHE(cache) NOOP
#endif
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
SV *tsv, *origsv;
char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
char *tmpbuf = tbuf;
- STRLEN n_a;
-
- if (!lp) {
- /* Saves needing to do lots of if (!lp) checks below */
- lp = &n_a;
- }
if (!sv) {
- *lp = 0;
+ if (lp)
+ *lp = 0;
return (char *)"";
}
if (SvGMAGICAL(sv)) {
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvPOKp(sv)) {
- *lp = SvCUR(sv);
+ if (lp)
+ *lp = SvCUR(sv);
if (flags & SV_MUTABLE_RETURN)
return SvPVX_mutable(sv);
if (flags & SV_CONST_RETURN)
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit(sv);
}
- *lp = 0;
+ if (lp)
+ *lp = 0;
return (char *)"";
}
}
register const char *typestr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
(!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- char *pv = SvPV(tmpstr, *lp);
+ char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
if (SvUTF8(tmpstr))
SvUTF8_on(sv);
else
SvUTF8_on(origsv);
else
SvUTF8_off(origsv);
- *lp = mg->mg_len;
+ if (lp)
+ *lp = mg->mg_len;
return mg->mg_ptr;
}
/* Fall through */
Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
goto tokensaveref;
}
- *lp = strlen(typestr);
+ if (lp)
+ *lp = strlen(typestr);
return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- *lp = 0;
+ if (lp)
+ *lp = 0;
return (char *)"";
}
}
if (ckWARN(WARN_UNINITIALIZED)
&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit(sv);
+ if (lp)
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
return (char *)"";
}
- *lp = s - SvPVX_const(sv);
- SvCUR_set(sv, *lp);
+ {
+ STRLEN len = s - SvPVX_const(sv);
+ if (lp)
+ *lp = len;
+ SvCUR_set(sv, len);
+ }
SvPOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
PTR2UV(sv),SvPVX_const(sv)));
if (!tsv)
tsv = newSVpv(tmpbuf, 0);
sv_2mortal(tsv);
- *lp = SvCUR(tsv);
+ if (lp)
+ *lp = SvCUR(tsv);
return SvPVX(tsv);
}
else {
}
#endif
SvUPGRADE(sv, SVt_PV);
- *lp = len;
+ if (lp)
+ *lp = len;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
SvPOKp_on(sv);
}
break;
case SVt_PVFM:
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
if (dtype < SVt_PVIV)
sv_upgrade(dstr, SVt_PVIV);
if (
/* We're not already COW */
((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
-#ifndef PERL_COPY_ON_WRITE
+#ifndef PERL_OLD_COPY_ON_WRITE
/* or we are, but dstr isn't a suitable target. */
|| (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
#endif
SvLEN(sstr) && /* and really is a string */
/* and won't be needed again, potentially */
!(PL_op && PL_op->op_type == OP_AASSIGN))
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
&& !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
&& SvTYPE(sstr) >= SVt_PVIV)
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
} else {
- /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
+ /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
be true in here. */
/* Either it's a shared hash key, or it's suitable for
copy-on-write or we can swipe the string. */
sv_dump(sstr);
sv_dump(dstr);
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (!isSwipe) {
/* I believe I should acquire a global SV mutex if
it's a COW sv (not a shared hash key) to stop
/* making another shared SV. */
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (len) {
assert (SvTYPE(dstr) >= SVt_PVIV);
/* 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));
+ SvPV_set(dstr, SvPVX_mutable(sstr));
} else
#endif
{
}
else
{ /* Passes the swipe test. */
- SvPV_set(dstr, SvPVX(sstr));
+ SvPV_set(dstr, SvPVX_mutable(sstr));
SvLEN_set(dstr, SvLEN(sstr));
SvCUR_set(dstr, SvCUR(sstr));
SvSETMAGIC(dstr);
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
SV *
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
{
SV_COW_NEXT_SV_SET(dstr, sstr);
}
SV_COW_NEXT_SV_SET(sstr, dstr);
- new_pv = SvPVX(sstr);
+ new_pv = SvPVX_mutable(sstr);
common_exit:
SvPV_set(dstr, new_pv);
SvSETMAGIC(sv);
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_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
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
if (SvFAKE(sv)) {
const MGVTBL *vtable = 0;
MAGIC* mg;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_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. */
else
SvREFCNT_dec(SvRV(sv));
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
else if (SvPVX_const(sv)) {
if (SvIsCOW(sv)) {
/* I believe I need to grab the global SV mutex here and
sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
- *lp = SvCUR(sv);
+ if (lp)
+ *lp = SvCUR(sv);
}
else {
char *s;
-
+ STRLEN len;
+
if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
if (PL_op)
Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
OP_NAME(PL_op));
}
else
- s = sv_2pv_flags(sv, lp, flags);
+ s = sv_2pv_flags(sv, &len, flags);
+ if (lp)
+ *lp = len;
+
if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
- const STRLEN len = *lp;
-
if (SvROK(sv))
sv_unref(sv);
SvUPGRADE(sv, SVt_PV); /* Never FALSE */
ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
else
ret->subbeg = Nullch;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
ret->saved_copy = Nullsv;
#endif
PL_reg_curpm = (PMOP*)NULL;
PL_reg_oldsaved = Nullch;
PL_reg_oldsavedlen = 0;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
PL_nrs = Nullsv;
#endif
PL_reg_maxiter = 0;
projects / p5sagit/p5-mst-13.2.git / blobdiff