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
&& ((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);
}
(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);
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) {
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. */
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)) {
/* fall through */
case SAVEt_COMPPAD:
case SAVEt_NSTAB:
- sv = POPPTR(ss,ix);
+ sv = (SV*) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_INT: /* int reference */
https://perl5.git.perl.org / perl5.git / blobdiff