#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-
pv = (char*)SvRV(sv);
break;
case SVt_PV:
- pv = SvPVX(sv);
+ pv = SvPVX_mutable(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
del_XPV(SvANY(sv));
mt = SVt_PVNV;
break;
case SVt_PVIV:
- pv = SvPVX(sv);
+ pv = SvPVX_mutable(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
iv = SvIVX(sv);
del_XPVIV(SvANY(sv));
break;
case SVt_PVNV:
- pv = SvPVX(sv);
+ pv = SvPVX_mutable(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
iv = SvIVX(sv);
Given that it only has meaning inside the pad, it shouldn't be set
on anything that can get upgraded. */
assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
- pv = SvPVX(sv);
+ pv = SvPVX_mutable(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
iv = SvIVX(sv);
#endif
}
else
- s = SvPVX(sv);
+ s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
newlen = PERL_STRLEN_ROUNDUP(newlen);
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- char *s, *end;
- for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
+ const char *s, *end;
+ for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
+ s++) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
len = SvCUR(sv);
}
else if (SvPOKp(sv))
- sbegin = SvPV(sv, len);
+ sbegin = SvPV_const(sv, len);
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
return grok_number(sbegin, len, NULL);
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit(sv);
}
- return 0;
+ return (NV)0;
}
}
if (SvTHINKFIRST(sv)) {
flags. NWC, 2000/11/25 */
/* Both already have p flags, so do nothing */
} else {
- NV nv = SvNVX(sv);
+ const NV nv = SvNVX(sv);
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
if (SvIVX(sv) == I_V(nv)) {
SvNOK_on(sv);
if (numtype & IS_NUMBER_NOT_INT) {
/* UV and NV both imprecise. */
} else {
- UV nv_as_uv = U_V(nv);
+ const UV nv_as_uv = U_V(nv);
if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
SvNOK_on(sv);
S_asIV(pTHX_ SV *sv)
{
UV value;
- int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
char *
Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
- STRLEN n_a;
- return sv_2pv(sv, &n_a);
+ return sv_2pv(sv, 0);
}
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
char *tmpbuf = tbuf;
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)
+ return (char *)SvPVX_const(sv);
return SvPVX(sv);
}
if (SvIOKp(sv)) {
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 *)"";
}
}
else
ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
- Move(ptr,SvPVX(sv),ebuf - ptr,char);
+ Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
*s = '\0';
sv_upgrade(sv, SVt_PVNV);
/* The +20 is pure guesswork. Configure test needed. --jhi */
SvGROW(sv, NV_DIG + 20);
- s = SvPVX(sv);
+ s = SvPVX_mutable(sv);
olderrno = errno; /* some Xenix systems wipe out errno here */
#ifdef apollo
if (SvNVX(sv) == 0.0)
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 (flags & SV_CONST_RETURN)
+ return (char *)SvPVX_const(sv);
+ if (flags & SV_MUTABLE_RETURN)
+ return SvPVX_mutable(sv);
return SvPVX(sv);
tokensave:
if (!tsv)
tsv = newSVpv(tmpbuf, 0);
sv_2mortal(tsv);
- *lp = SvCUR(tsv);
+ if (lp)
+ *lp = SvCUR(tsv);
return SvPVX(tsv);
}
else {
len = 1;
}
#endif
- (void)SvUPGRADE(sv, SVt_PV);
- *lp = len;
+ SvUPGRADE(sv, SVt_PV);
+ if (lp)
+ *lp = len;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
SvPOKp_on(sv);
Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
{
STRLEN len;
- char *s;
- s = SvPV(ssv,len);
+ const char *s;
+ s = SvPV_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
char *
Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
{
- STRLEN n_a;
- return sv_2pvbyte(sv, &n_a);
+ return sv_2pvbyte(sv, 0);
}
/*
char *
Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
{
- STRLEN n_a;
- return sv_2pvutf8(sv, &n_a);
+ return sv_2pvutf8(sv, 0);
}
/*
}
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 (stype == SVt_PVLV)
- (void)SvUPGRADE(dstr, SVt_PVNV);
+ SvUPGRADE(dstr, SVt_PVNV);
else
- (void)SvUPGRADE(dstr, (U32)stype);
+ SvUPGRADE(dstr, (U32)stype);
}
sflags = SvFLAGS(sstr);
(void)SvPOK_only(dstr);
if (
-#ifdef PERL_COPY_ON_WRITE
- (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
- &&
+ /* We're not already COW */
+ ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+#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
+ )
+ &&
!(isSwipe =
(sflags & SVs_TEMP) && /* slated for free anyway? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
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. */
-#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) {
sv_dump(sstr);
sv_dump(dstr);
}
+#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
Safefree(SvPVX_const(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);
+#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));
- } else {
+ SvPV_set(dstr, SvPVX_mutable(sstr));
+ } else
+#endif
+ {
/* SvIsCOW_shared_hash */
- UV hash = SvUVX(sstr);
+ UV hash = SvSHARED_HASH(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Copy on write: Sharing hash\n"));
+
+ assert (SvTYPE(dstr) >= SVt_PVIV);
SvPV_set(dstr,
sharepvn(SvPVX_const(sstr),
(sflags & SVf_UTF8?-cur:cur), hash));
/* Relesase a global SV mutex. */
}
else
-#endif
{ /* 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)
{
}
else
new_SV(dstr);
- (void)SvUPGRADE (dstr, SVt_PVIV);
+ SvUPGRADE(dstr, SVt_PVIV);
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
if (SvLEN(sstr) == 0) {
/* source is a COW shared hash key. */
- UV hash = SvUVX(sstr);
+ UV hash = SvSHARED_HASH(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Sharing hash\n"));
SvUV_set(dstr, hash);
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
- (void)SvUPGRADE (sstr, SVt_PVIV);
+ SvUPGRADE(sstr, SVt_PVIV);
SvREADONLY_on(sstr);
SvFAKE_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
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);
if (iv < 0)
Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
}
- (void)SvUPGRADE(sv, SVt_PV);
+ SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
dptr = SvPVX(sv);
return;
}
len = strlen(ptr);
- (void)SvUPGRADE(sv, SVt_PV);
+ SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len+1,char);
{
STRLEN allocate;
SV_CHECK_THINKFIRST_COW_DROP(sv);
- (void)SvUPGRADE(sv, SVt_PV);
+ SvUPGRADE(sv, SVt_PV);
if (!ptr) {
(void)SvOK_off(sv);
return;
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 char *pvx = SvPVX_const(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. */
+ const STRLEN len = SvLEN(sv);
+ const STRLEN cur = SvCUR(sv);
+ const U32 hash = SvSHARED_HASH(sv);
+ SV *const 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",
#else
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
- char *pvx = SvPVX_const(sv);
+ const char *pvx = SvPVX_const(sv);
const int is_utf8 = SvUTF8(sv);
- STRLEN len = SvCUR(sv);
- U32 hash = SvUVX(sv);
+ const STRLEN len = SvCUR(sv);
+ const U32 hash = SvSHARED_HASH(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
- SvPV_set(sv, (char*)0);
- SvLEN_set(sv, 0);
+ SvPV_set(sv, Nullch);
+ SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
Move(pvx,SvPVX_const(sv),len,char);
*SvEND(sv) = '\0';
void
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
- char *spv;
+ const char *spv;
STRLEN slen;
if (!ssv)
return;
- if ((spv = SvPV(ssv, slen))) {
+ if ((spv = SvPV_const(ssv, slen))) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
MAGIC* mg;
if (SvTYPE(sv) < SVt_PVMG) {
- (void)SvUPGRADE(sv, SVt_PVMG);
+ SvUPGRADE(sv, SVt_PVMG);
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(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
if (SvGMAGICAL(sv))
len = mg_length(sv);
else
- (void)SvPV(sv, len);
+ (void)SvPV_const(sv, len);
return len;
}
else
{
STRLEN len, ulen;
- const U8 *s = (U8*)SvPV(sv, len);
+ const U8 *s = (U8*)SvPV_const(sv, len);
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
*
*/
STATIC bool
-S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start)
+S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
+ I32 offsetp, const U8 *s, const U8 *start)
{
bool found = FALSE;
*
*/
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)
+S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
{
bool found = FALSE;
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
- U8 *start;
+ const U8 *start;
STRLEN len;
if (!sv)
return;
- start = (U8*)SvPV(sv, len);
+ start = (U8*)SvPV_const(sv, len);
if (len) {
STRLEN boffset = 0;
STRLEN *cache = 0;
- U8 *s = start;
- I32 uoffset = *offsetp;
- U8 *send = s + len;
- MAGIC *mg = 0;
- bool found = FALSE;
+ const U8 *s = start;
+ I32 uoffset = *offsetp;
+ const 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;
void
Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
{
- U8* s;
+ const U8* s;
STRLEN len;
if (!sv)
return;
- s = (U8*)SvPV(sv, len);
+ s = (const U8*)SvPV_const(sv, len);
if ((I32)len < *offsetp)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
else {
- U8* send = s + *offsetp;
+ const U8* send = s + *offsetp;
MAGIC* mg = NULL;
STRLEN *cache = NULL;
STRLEN backw = cache[1] - *offsetp;
if (!(forw < 2 * backw)) {
- U8 *p = s + cache[1];
+ const U8 *p = s + cache[1];
STRLEN ubackw = 0;
cache[1] -= backw;
cur1 = 0;
}
else
- pv1 = SvPV(sv1, cur1);
+ pv1 = SvPV_const(sv1, cur1);
if (!sv2){
pv2 = "";
cur2 = 0;
}
else
- pv2 = SvPV(sv2, cur2);
+ pv2 = SvPV_const(sv2, cur2);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
/* Differing utf8ness.
cur1 = 0;
}
else
- pv1 = SvPV(sv1, cur1);
+ pv1 = SvPV_const(sv1, cur1);
if (!sv2) {
pv2 = "";
cur2 = 0;
}
else
- pv2 = SvPV(sv2, cur2);
+ pv2 = SvPV_const(sv2, cur2);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
/* Differing utf8ness.
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);
+ SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
/*
-=for apidoc newSVpv_hek
+=for apidoc newSVhek
Creates a new SV from the hash key structure. It will generate scalars that
-point to the shared string table where possible.
+point to the shared string table where possible. Returns a new (undefined)
+SV if the hek is NULL.
=cut
*/
SV *
Perl_newSVhek(pTHX_ const HEK *hek)
{
+ if (!hek) {
+ SV *sv;
+
+ new_SV(sv);
+ return sv;
+ }
+
if (HEK_LEN(hek) == HEf_SVKEY) {
return newSVsv(*(SV**)HEK_KEY(hek));
} else {
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",
+ sv_reftype(sv,0), OP_NAME(PL_op));
+ else
+ Perl_croak(aTHX_ "Can't coerce readonly %s to string",
+ sv_reftype(sv,0));
+ }
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
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);
- (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
+ SvUPGRADE(sv, SVt_PV); /* Never FALSE */
SvGROW(sv, len + 1);
Move(s,SvPVX_const(sv),len,char);
SvCUR_set(sv, len);
PTR2UV(sv),SvPVX_const(sv)));
}
}
- return SvPVX(sv);
+ return SvPVX_mutable(sv);
}
/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
SvOBJECT_on(tmpRef);
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
- (void)SvUPGRADE(tmpRef, SVt_PVMG);
+ SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
if (Gv_AMG(stash))
U8 utf8buf[UTF8_MAXBYTES+1];
STRLEN esignlen = 0;
- char *eptr = Nullch;
+ const char *eptr = Nullch;
STRLEN elen = 0;
SV *vecsv = Nullsv;
- U8 *vecstr = Null(U8*);
+ const U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
char c = 0;
int i;
else
vecsv = (evix ? evix <= svmax : svix < svmax) ?
svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
- dotstr = SvPVx(vecsv, dotstrlen);
+ dotstr = SvPV_const(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
is_utf8 = TRUE;
}
if (args) {
vecsv = va_arg(*args, SV*);
- vecstr = (U8*)SvPVx(vecsv,veclen);
+ vecstr = (U8*)SvPV_const(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
}
else if (efix ? efix <= svmax : svix < svmax) {
vecsv = svargs[efix ? efix-1 : svix++];
- vecstr = (U8*)SvPVx(vecsv,veclen);
+ vecstr = (U8*)SvPV_const(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
/* if this is a version object, we need to return the
* stringified representation (which the SvPVX_const has
if ( *q == 'd' && sv_derived_from(vecsv,"version") )
{
q++; /* skip past the rest of the %vd format */
- eptr = (char *) vecstr;
+ eptr = (const char *) vecstr;
elen = strlen(eptr);
vectorize=FALSE;
goto string;
}
}
else {
- eptr = SvPVx(argsv, elen);
+ eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv)) {
if (has_precis && precis < elen) {
I32 p = precis;
if (vectorize)
goto unknown;
argsv = va_arg(*args, SV*);
- eptr = SvPVx(argsv, elen);
+ eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv))
is_utf8 = TRUE;
goto string;
}
integer:
- eptr = ebuf + sizeof ebuf;
- switch (base) {
- unsigned dig;
- case 16:
- if (!uv)
- alt = FALSE;
- p = (char*)((c == 'X')
- ? "0123456789ABCDEF" : "0123456789abcdef");
- do {
- dig = uv & 15;
- *--eptr = p[dig];
- } while (uv >>= 4);
- if (alt) {
- esignbuf[esignlen++] = '0';
- esignbuf[esignlen++] = c; /* 'x' or 'X' */
+ {
+ char *ptr = ebuf + sizeof ebuf;
+ switch (base) {
+ unsigned dig;
+ case 16:
+ if (!uv)
+ alt = FALSE;
+ p = (char*)((c == 'X')
+ ? "0123456789ABCDEF" : "0123456789abcdef");
+ do {
+ dig = uv & 15;
+ *--ptr = p[dig];
+ } while (uv >>= 4);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
+ }
+ break;
+ case 8:
+ do {
+ dig = uv & 7;
+ *--ptr = '0' + dig;
+ } while (uv >>= 3);
+ if (alt && *ptr != '0')
+ *--ptr = '0';
+ break;
+ case 2:
+ do {
+ dig = uv & 1;
+ *--ptr = '0' + dig;
+ } while (uv >>= 1);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = 'b';
+ }
+ break;
+ default: /* it had better be ten or less */
+ do {
+ dig = uv % base;
+ *--ptr = '0' + dig;
+ } while (uv /= base);
+ break;
}
- break;
- case 8:
- do {
- dig = uv & 7;
- *--eptr = '0' + dig;
- } while (uv >>= 3);
- if (alt && *eptr != '0')
- *--eptr = '0';
- break;
- case 2:
- do {
- dig = uv & 1;
- *--eptr = '0' + dig;
- } while (uv >>= 1);
- if (alt) {
- esignbuf[esignlen++] = '0';
- esignbuf[esignlen++] = 'b';
+ elen = (ebuf + sizeof ebuf) - ptr;
+ eptr = ptr;
+ if (has_precis) {
+ if (precis > elen)
+ zeros = precis - elen;
+ else if (precis == 0 && elen == 1 && *eptr == '0')
+ elen = 0;
}
- break;
- default: /* it had better be ten or less */
- do {
- dig = uv % base;
- *--eptr = '0' + dig;
- } while (uv /= base);
- break;
- }
- elen = (ebuf + sizeof ebuf) - eptr;
- if (has_precis) {
- if (precis > elen)
- zeros = precis - elen;
- else if (precis == 0 && elen == 1 && *eptr == '0')
- elen = 0;
}
break;
break;
}
}
- eptr = ebuf + sizeof ebuf;
- *--eptr = '\0';
- *--eptr = c;
- /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+ {
+ char *ptr = ebuf + sizeof ebuf;
+ *--ptr = '\0';
+ *--ptr = c;
+ /* 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. */
- static char const prifldbl[] = PERL_PRIfldbl;
- char const *p = prifldbl + sizeof(prifldbl) - 3;
- while (p >= prifldbl) { *--eptr = *p--; }
- }
+ if (intsize == 'q') {
+ /* Copy the one or more characters in a long double
+ * format before the 'base' ([efgEFG]) character to
+ * the format string. */
+ static char const prifldbl[] = PERL_PRIfldbl;
+ char const *p = prifldbl + sizeof(prifldbl) - 3;
+ while (p >= prifldbl) { *--ptr = *p--; }
+ }
#endif
- if (has_precis) {
- base = precis;
- do { *--eptr = '0' + (base % 10); } while (base /= 10);
- *--eptr = '.';
- }
- if (width) {
- base = width;
- do { *--eptr = '0' + (base % 10); } while (base /= 10);
- }
- if (fill == '0')
- *--eptr = fill;
- if (left)
- *--eptr = '-';
- if (plus)
- *--eptr = plus;
- if (alt)
- *--eptr = '#';
- *--eptr = '%';
-
- /* No taint. Otherwise we are in the strange situation
- * where printf() taints but print($float) doesn't.
- * --jhi */
+ if (has_precis) {
+ base = precis;
+ do { *--ptr = '0' + (base % 10); } while (base /= 10);
+ *--ptr = '.';
+ }
+ if (width) {
+ base = width;
+ do { *--ptr = '0' + (base % 10); } while (base /= 10);
+ }
+ if (fill == '0')
+ *--ptr = fill;
+ if (left)
+ *--ptr = '-';
+ if (plus)
+ *--ptr = plus;
+ if (alt)
+ *--ptr = '#';
+ *--ptr = '%';
+
+ /* 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);
+ if (intsize == 'q')
+ (void)sprintf(PL_efloatbuf, ptr, nv);
+ else
+ (void)sprintf(PL_efloatbuf, ptr, (double)nv);
#else
- (void)sprintf(PL_efloatbuf, eptr, nv);
+ (void)sprintf(PL_efloatbuf, ptr, nv);
#endif
+ }
float_converted:
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
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
static void
do_mark_cloneable_stash(pTHX_ SV *sv)
{
- const char *hvname = HvNAME_get((HV*)sv);
+ const HEK *hvname = HvNAME_HEK((HV*)sv);
if (hvname) {
GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
- STRLEN len = HvNAMELEN_get((HV*)sv);
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
if (cloner && GvCV(cloner)) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
+ XPUSHs(sv_2mortal(newSVhek(hvname)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_SCALAR);
SPAGAIN;
* constants; they need to be allocated as common memory and just
* their pointers copied. */
+ IV i;
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
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;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash))));
+ XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
projects / p5sagit/p5-mst-13.2.git / blobdiff