/* RVs are in the head now. */
{ 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
+ /* The bind placeholder pretends to be an RV for now. */
+ { 0, 0, 0, SVt_BIND, FALSE, NONV, NOARENA, 0 },
+
/* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(xpv_allocated),
copy_length(XPV, xpv_len)
{ sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- /* 36 */
- { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
-
/* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
assert(SvPVX_const(sv) == 0);
}
- /* Could put this in the else clause below, as PVMG must have SvPVX
- 0 already (the assertion above) */
- SvPV_set(sv, NULL);
-
if (old_type >= SVt_PVMG) {
SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
+ } else {
+ sv->sv_u.svu_array = NULL; /* or svu_hash */
}
break;
assert(!SvNOK(sv));
case SVt_PVIO:
case SVt_PVFM:
- case SVt_PVBM:
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- sv_setiv(sv, 0);
- SvIsUV_on(sv);
sv_setuv(sv,u);
SvSETMAGIC(sv);
}
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv)) {
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+ cache IVs just in case. In practice it seems that they never
+ actually anywhere accessible by user Perl code, let alone get used
+ in anything other than a string context. */
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
dVAR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv)) {
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+ cache IVs just in case. */
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv)) {
+ if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
+ /* FBMs use the same flag bit as SVf_IVisUV, so must let them
+ cache IVs just in case. */
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
return ptr;
}
-/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
- * a regexp to its stringified form.
- */
-
-static char *
-S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
- dVAR;
- const regexp * const re = (regexp *)mg->mg_obj;
-
- if (!mg->mg_ptr) {
- const char *fptr = "msix";
- char reflags[6];
- char ch;
- int left = 0;
- int right = 4;
- bool need_newline = 0;
- U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
-
- while((ch = *fptr++)) {
- if(reganch & 1) {
- reflags[left++] = ch;
- }
- else {
- reflags[right--] = ch;
- }
- reganch >>= 1;
- }
- if(left != 4) {
- reflags[left] = '-';
- left = 5;
- }
-
- 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) {
- const char *endptr = re->precomp + re->prelen;
- while (endptr >= re->precomp) {
- const 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;
- }
- }
- }
-
- Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
- mg->mg_ptr[0] = '(';
- mg->mg_ptr[1] = '?';
- Copy(reflags, mg->mg_ptr+2, left, char);
- *(mg->mg_ptr+left+2) = ':';
- 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(sv);
- else
- SvUTF8_off(sv);
- if (lp)
- *lp = mg->mg_len;
- return mg->mg_ptr;
-}
-
/*
=for apidoc sv_2pv_flags
&& ((SvFLAGS(referent) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_SMG))
- && (mg = mg_find(referent, PERL_MAGIC_qr))) {
- return stringify_regexp(sv, mg, lp);
+ && (mg = mg_find(referent, PERL_MAGIC_qr)))
+ {
+ char *str = NULL;
+ I32 haseval = 0;
+ U32 flags = 0;
+ (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval);
+ if (flags & 1)
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ PL_reginterp_cnt += haseval;
+ return str;
} else {
const char *const typestr = sv_reftype(referent, 0);
const STRLEN typelen = strlen(typestr);
if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
- const U32 isIOK = SvIOK(sv);
const U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
*s = '\0';
- if (isIOK)
- SvIOK_on(sv);
- else
- SvIOKp_on(sv);
- if (isUIOK)
- SvIsUV_on(sv);
}
else if (SvNOKp(sv)) {
const int olderrno = errno;
}
sv_upgrade(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- SvSCREAM_on(dstr);
+ /* FIXME - why are we doing this, then turning it off and on again
+ below? */
+ isGV_with_GP_on(dstr);
}
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
#endif
gp_free((GV*)dstr);
- SvSCREAM_off(dstr);
+ isGV_with_GP_off(dstr);
(void)SvOK_off(dstr);
- SvSCREAM_on(dstr);
+ isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
GvGP(dstr) = gp_ref(GvGP(sstr));
if (SvTAINTED(sstr))
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
break;
+ case SVt_PVGV:
+ goto end_of_first_switch;
}
(void)SvIOK_only(dstr);
SvIV_set(dstr, SvIVX(sstr));
case SVt_PVIV:
sv_upgrade(dstr, SVt_PVNV);
break;
+ case SVt_PVGV:
+ goto end_of_first_switch;
}
SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
}
break;
+ /* case SVt_BIND: */
case SVt_PVGV:
- if (dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
return;
}
+ /* SvVALID means that this PVGV is playing at being an FBM. */
/*FALLTHROUGH*/
case SVt_PVMG:
case SVt_PVLV:
- case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
- if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
+ if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
return;
}
else
SvUPGRADE(dstr, (svtype)stype);
}
+ end_of_first_switch:
/* dstr may have been upgraded. */
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (sflags & SVf_ROK) {
- if (dtype == SVt_PVGV &&
- SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ if (dtype == SVt_PVCV) {
+ /* Assigning to a subroutine sets the prototype. */
+ if (SvOK(sstr)) {
+ STRLEN len;
+ const char *const ptr = SvPV_const(sstr, len);
+
+ SvGROW(dstr, len + 1);
+ Copy(ptr, SvPVX(dstr), len + 1, char);
+ SvCUR_set(dstr, len);
+ SvPOK_only(dstr);
+ } else {
+ SvOK_off(dstr);
+ }
+ } else if (sflags & SVf_ROK) {
+ if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+ && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
}
(void)SvOK_off(dstr);
SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
- SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
+ SvFLAGS(dstr) |= sflags & SVf_ROK;
assert(!(sflags & SVp_NOK));
assert(!(sflags & SVp_IOK));
assert(!(sflags & SVf_NOK));
assert(!(sflags & SVf_IOK));
}
- else if (dtype == SVt_PVGV) {
+ else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
if (!(sflags & SVf_OK)) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC),
* possible small lose on short strings, but a big win on long ones.
* It might even be a win on short strings if SvPVX_const(dstr)
* has to be allocated and SvPVX_const(sstr) has to be freed.
+ * Likewise if we can set up COW rather than doing an actual copy, we
+ * drop to the else clause, as the swipe code and the COW setup code
+ * have much in common.
*/
/* Whichever path we take through the next code, we want this true,
(void)SvPOK_only(dstr);
if (
- /* We're not already COW */
- ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
+ /* If we're already COW then this clause is not true, and if COW
+ is allowed then we drop down to the else and make dest COW
+ with us. If caller hasn't said that we're allowed to COW
+ shared hash keys then we don't do the COW setup, even if the
+ source scalar is a shared hash key scalar. */
+ (((flags & SV_COW_SHARED_HASH_KEYS)
+ ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+ : 1 /* If making a COW copy is forbidden then the behaviour we
+ desire is as if the source SV isn't actually already
+ COW, even if it is. So we act as if the source flags
+ are not COW, rather than actually testing them. */
+ )
#ifndef PERL_OLD_COPY_ON_WRITE
- /* or we are, but dstr isn't a suitable target. */
+ /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
+ when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
+ Conceptually PERL_OLD_COPY_ON_WRITE being defined should
+ override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
+ but in turn, it's somewhat dead code, never expected to go
+ live, but more kept as a placeholder on how to do it better
+ in a newer implementation. */
+ /* If we are COW and dstr is a suitable target then we drop down
+ into the else and make dest a COW of us. */
|| (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
#endif
)
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
- SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8
- |SVf_AMAGIC);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
{
const MAGIC * const smg = SvVSTRING_mg(sstr);
if (smg) {
}
else if (sflags & (SVp_IOK|SVp_NOK)) {
(void)SvOK_off(dstr);
- SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK
- |SVf_AMAGIC);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
if (sflags & SVp_IOK) {
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
SvIV_set(dstr, SvIVX(sstr));
SvFAKE_off(sstr);
gv_efullname3(dstr, (GV *)sstr, "*");
SvFLAGS(sstr) |= wasfake;
- SvFLAGS(dstr) |= sflags & SVf_AMAGIC;
}
else
(void)SvOK_off(dstr);
}
}
if (type >= SVt_PVMG) {
- if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) {
+ if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(OURSTASH(sv));
} else if (SvMAGIC(sv))
mg_free(sv);
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
+ /* case SVt_BIND: */
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
goto freescalar;
- case SVt_PVBM:
- goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
cv_undef((CV*)sv);
SvREFCNT_dec(LvTARG(sv));
goto freescalar;
case SVt_PVGV:
- gp_free((GV*)sv);
- if (GvNAME_HEK(sv)) {
- unshare_hek(GvNAME_HEK(sv));
- }
+ if (isGV_with_GP(sv)) {
+ gp_free((GV*)sv);
+ if (GvNAME_HEK(sv))
+ unshare_hek(GvNAME_HEK(sv));
/* If we're in a stash, we don't own a reference to it. However it does
have a back reference to us, which needs to be cleared. */
- if (GvSTASH(sv))
- sv_del_backref((SV*)GvSTASH(sv), sv);
+ if (!SvVALID(sv) && GvSTASH(sv))
+ sv_del_backref((SV*)GvSTASH(sv), sv);
+ }
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
if (PL_utf8cache < 0) {
const U8 *start = (const U8 *) SvPVX_const(sv);
- const U8 *const end = start + byte;
- STRLEN realutf8 = 0;
-
- while (start < end) {
- start += UTF8SKIP(start);
- realutf8++;
- }
-
- /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on
- surrogates. FIXME - is it inconsistent that b2u warns, but u2b
- doesn't? I don't know whether this difference was introduced with
- the caching code in 5.8.1. */
+ const STRLEN realutf8 = utf8_length(start, start + byte);
if (realutf8 != utf8) {
/* Need to turn the assertions off otherwise we may recurse
ASSERT_UTF8_CACHE(cache);
}
-/* If we don't know the character offset of the end of a region, our only
- option is to walk forwards to the target byte offset. */
-static STRLEN
-S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target)
-{
- STRLEN len = 0;
- while (s < target) {
- 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;
- }
- return len;
-}
-
/* We already know all of the way, now we may be able to walk back. The same
assumption is made as in S_sv_pos_u2b_midway(), namely that walking
backward is half the speed of walking forward. */
STRLEN backw = end - target;
if (forw < 2 * backw) {
- return S_sv_pos_b2u_forwards(aTHX_ s, target);
+ return utf8_length(s, target);
}
while (end > target) {
+ S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
s + blen, mg->mg_len - cache[0]);
} else {
- len = cache[0]
- + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send);
+ len = cache[0] + utf8_length(s + cache[1], send);
}
}
else if (cache[3] < byte) {
}
}
if (!found || PL_utf8cache < 0) {
- const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send);
+ const STRLEN real_len = utf8_length(s, send);
if (found && PL_utf8cache < 0) {
if (len != real_len) {
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
- case SVt_PVBM:
if (SvVOK(sv))
return "VSTRING";
if (SvROK(sv))
case SVt_PVGV: return "GLOB";
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
+ case SVt_BIND: return "BIND";
default: return "UNKNOWN";
}
}
if (GvNAME_HEK(sv)) {
unshare_hek(GvNAME_HEK(sv));
}
- SvSCREAM_off(sv);
+ isGV_with_GP_off(sv);
/* need to keep SvANY(sv) in the right arena */
xpvmg = new_XPVMG();
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
-/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
- regcomp.c. AMS 20010712 */
-
-REGEXP *
-Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
-{
- return CALLREGDUPE(r,param);
-}
-
/* duplicate a file handle */
PerlIO *
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
if (mg->mg_type == PERL_MAGIC_qr) {
- nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
+ nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
/* The backref AV has its reference count deliberately bumped by
SvANY(dstr) = &(dstr->sv_u.svu_rv);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
+ /* case SVt_BIND: */
default:
{
/* These are all the types that need complex bodies allocating. */
case SVt_PVFM:
case SVt_PVHV:
case SVt_PVAV:
- case SVt_PVBM:
case SVt_PVCV:
case SVt_PVLV:
case SVt_PVMG:
break;
case SVt_PVMG:
break;
- case SVt_PVBM:
- break;
case SVt_PVLV:
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
break;
case SVt_PVGV:
- if (GvNAME_HEK(dstr))
- GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+ if(isGV_with_GP(sstr)) {
+ if (GvNAME_HEK(dstr))
+ GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+ }
/* Don't call sv_add_backref here as it's going to be created
as part of the magic cloning of the symbol table. */
- GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(!SvVALID(dstr))
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
if(isGV_with_GP(sstr)) {
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
src_ary = AvARRAY((AV*)sstr);
Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
- SvPV_set(dstr, (char*)dst_ary);
+ AvARRAY((AV*)dstr) = dst_ary;
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
}
}
else {
- SvPV_set(dstr, NULL);
+ AvARRAY((AV*)dstr) = NULL;
AvALLOC((AV*)dstr) = (SV**)NULL;
}
break;
}
}
else
- SvPV_set(dstr, NULL);
+ HvARRAY((HV*)dstr) = NULL;
break;
case SVt_PVCV:
if (!(param->flags & CLONEf_COPY_STACKS)) {
case OP_LEAVEWRITE:
TOPPTR(nss,ix) = ptr;
o = (OP*)ptr;
+ OP_REFCNT_LOCK;
OpREFCNT_inc(o);
+ OP_REFCNT_UNLOCK;
break;
default:
TOPPTR(nss,ix) = NULL;
SvREPADTMP(regex)
? sv_dup_inc(regex, param)
: SvREFCNT_inc(
- newSViv(PTR2IV(re_dup(
+ newSViv(PTR2IV(CALLREGDUPE(
INT2PTR(REGEXP *, SvIVX(regex)), param))))
;
av_push(PL_regex_padav, sv);
/* current interpreter roots */
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
+ OP_REFCNT_LOCK;
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
+ OP_REFCNT_UNLOCK;
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_eval_start = proto_perl->Ieval_start;