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;
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
}
}
{
- SV *tsv;
+ STRLEN len;
+ char *retval;
+ char *buffer;
MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvs("NULLREF"));
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_PVMG
&& ((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);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
- tsv = sv_newmortal();
if (SvOBJECT(referent)) {
- const char *const name = HvNAME_get(SvSTASH(referent));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr,
- PTR2UV(referent));
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
+ } else {
+ SvUTF8_off(sv);
+ }
+ } else {
+ stashname = "__ANON__";
+ stashnamelen = 8;
+ }
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
- PTR2UV(referent));
+
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
+ }
+ /* retval may not neccesarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (sstr == dstr)
return;
+
+ if (SvIS_FREED(dstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+ " to a freed scalar %p", sstr, dstr);
+ }
SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
+ if (SvIS_FREED(sstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
+ dstr);
+ }
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
}
(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));
* 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);
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
+ case PERL_MAGIC_regdata_names:
+ vtable = &PL_vtbl_regdata_names;
+ break;
case PERL_MAGIC_regdatum:
vtable = &PL_vtbl_regdatum;
break;
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) {
switch (*q) {
case ' ':
case '+':
- plus = *q++;
+ if (plus == '+' && *q == ' ') /* '+' over ' ' */
+ q++;
+ else
+ plus = *q++;
continue;
case '-':
else
i = (ewix ? ewix <= svmax : svix < svmax)
? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
- precis = (i < 0) ? 0 : i;
+ precis = i;
+ has_precis = !(i < 0);
}
else {
precis = 0;
while (isDIGIT(*q))
precis = precis * 10 + (*q++ - '0');
+ has_precis = TRUE;
}
- has_precis = TRUE;
}
/* SIZE */
else {
eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv)) {
+ I32 old_precis = precis;
if (has_precis && precis < elen) {
I32 p = precis;
sv_pos_u2b(argsv, &p, 0); /* sticks at end */
precis = p;
}
if (width) { /* fudge width (can't fudge elen) */
- width += elen - sv_len_utf8(argsv);
+ if (has_precis && precis < elen)
+ width += precis - old_precis;
+ else
+ width += elen - sv_len_utf8(argsv);
}
is_utf8 = TRUE;
}
base = 10;
goto uns_integer;
+ case 'B':
case 'b':
base = 2;
goto uns_integer;
} while (uv >>= 1);
if (tempalt) {
esignbuf[esignlen++] = '0';
- esignbuf[esignlen++] = 'b';
+ esignbuf[esignlen++] = c;
}
break;
default: /* it had better be ten or less */
if (has_precis) {
if (precis > elen)
zeros = precis - elen;
- else if (precis == 0 && elen == 1 && *eptr == '0')
+ else if (precis == 0 && elen == 1 && *eptr == '0'
+ && !(base == 8 && alt)) /* "%#.0o" prints "0" */
elen = 0;
+
+ /* a precision nullifies the 0 flag. */
+ if (fill == '0')
+ fill = ' ';
}
}
break;
/* Certain cases in Perl_ss_dup have been merged, by relying on the fact
- that currently av_dup and hv_dup are the same as sv_dup. If this changes,
- please unmerge ss_dup. */
+ that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
+ If this changes, please unmerge ss_dup. */
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
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)) {
long longval;
GP *gp;
IV iv;
+ I32 i;
char *c = NULL;
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
Newxz(nss, max, ANY);
while (ix > 0) {
- I32 i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
- switch (i) {
+ const I32 type = POPINT(ss,ix);
+ TOPINT(nss,ix) = type;
+ switch (type) {
+ case SAVEt_HELEM: /* hash element */
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ /* fall through */
case SAVEt_ITEM: /* normal string */
case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ /* fall through */
+ case SAVEt_FREESV:
+ case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_AV: /* array reference */
sv = (SV*) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv, param);
+ /* fall through */
+ case SAVEt_COMPPAD:
+ case SAVEt_NSTAB:
+ sv = (SV*) POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_INT: /* int reference */
ptr = POPPTR(ss,ix);
case SAVEt_LONG: /* long reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ /* fall through */
+ case SAVEt_CLEARSV:
longval = (long)POPLONG(ss,ix);
TOPLONG(nss,ix) = longval;
break;
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
break;
- case SAVEt_NSTAB:
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv, param);
- break;
case SAVEt_GP: /* scalar reference */
gp = (GP*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup_inc(gv, param);
- c = (char*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = pv_dup(c);
- iv = POPIV(ss,ix);
- TOPIV(nss,ix) = iv;
- iv = POPIV(ss,ix);
- TOPIV(nss,ix) = iv;
break;
- case SAVEt_FREESV:
- case SAVEt_MORTALIZESV:
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
break;
- case SAVEt_CLEARSV:
- longval = POPLONG(ss,ix);
- TOPLONG(nss,ix) = longval;
- break;
case SAVEt_DELETE:
hv = (HV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
+ /* fall through */
+ case SAVEt_STACK_POS: /* Position on Perl stack */
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
break;
TOPINT(nss,ix) = i;
ix -= i;
break;
- case SAVEt_STACK_POS: /* Position on Perl stack */
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
- break;
case SAVEt_AELEM: /* array element */
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
av = (AV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
- case SAVEt_HELEM: /* hash element */
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
- break;
case SAVEt_OP:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = ptr;
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
}
break;
- case SAVEt_COMPPAD:
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av, param);
- break;
case SAVEt_PADSV:
longval = (long)POPLONG(ss,ix);
TOPLONG(nss,ix) = longval;
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
break;
default:
- Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i);
+ Perl_croak(aTHX_
+ "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
}
}
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_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
+ PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_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);
https://perl5.git.perl.org / perl5.git / blobdiff