/* HEs use this offset for their arena. */
{ 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
- /* The bind placeholder pretends to be an RV for now.
- Also it's marked as "can't upgrade" to stop anyone using it before it's
- implemented. */
- { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
-
/* IVs are in the head, so the allocation size is 0. */
{ 0,
sizeof(IV), /* This is used to copy out the IV body. */
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+ { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
+ copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
+ + STRUCT_OFFSET(XPV, xpv_cur),
+ SVt_INVLIST, TRUE, NONV, HASARENA,
+ FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
+
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
{ sizeof(regexp),
sizeof(regexp),
0,
- SVt_REGEXP, FALSE, NONV, HASARENA,
+ SVt_REGEXP, TRUE, NONV, HASARENA,
FIT_ARENA(0, sizeof(regexp))
},
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(sv); /* key-sharing on by default */
#endif
- HvMAX(sv) = 7; /* (start with 8 buckets) */
+ /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+ HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_INVLIST:
case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
PERL_ARGS_ASSERT_SV_GROW;
- if (PL_madskills && newlen >= 0x100000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- }
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
s = SvPVX_mutable(sv);
}
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
+ * to store the COW count. So in general, allocate one more byte than
+ * asked for, to make it likely this byte is always spare: and thus
+ * make more strings COW-able.
+ * If the new size is a big power of two, don't bother: we assume the
+ * caller wanted a nice 2^N sized block and will be annoyed at getting
+ * 2^N+1 */
+ if (newlen & 0xff)
+ newlen++;
+#endif
+
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
if (!sv)
return 0;
+ assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+ && SvTYPE(sv) != SVt_PVFM);
+
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
dVAR;
if (!sv)
return 0.0;
+ assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+ && SvTYPE(sv) != SVt_PVFM);
if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache NVs.
*lp = 0;
return (char *)"";
}
+ assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
+ && SvTYPE(sv) != SVt_PVFM);
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
if (SvROK(sv)) {
Move(ptr, s, len, char);
s += len;
*s = '\0';
+ SvPOK_on(sv);
}
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
/* The +20 is pure guesswork. Configure test needed. --jhi */
s = SvGROW_mutable(sv, NV_DIG + 20);
/* some Xenix systems wipe out errno here */
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
+
+#ifndef USE_LOCALE_NUMERIC
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ SvPOK_on(sv);
+#else
+ /* Gconvert always uses the current locale. That's the right thing
+ * to do if we're supposed to be using locales. But otherwise, we
+ * want the result to be based on the C locale, so we need to
+ * change to the C locale during the Gconvert and then change back.
+ * But if we're already in the C locale (PL_numeric_standard is
+ * TRUE in that case), no need to do any changing */
+ if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) {
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+
+ /* If the radix character is UTF-8, and actually is in the
+ * output, turn on the UTF-8 flag for the scalar */
+ if (! PL_numeric_standard
+ && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+ && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ }
+ else {
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+
+ }
+
+ /* We don't call SvPOK_on(), because it may come to pass that the
+ * locale changes so that the stringification we just did is no
+ * longer correct. We will have to re-stringify every time it is
+ * needed */
+#endif
RESTORE_ERRNO;
while (*s) s++;
}
*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)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
+ SvGETMAGIC(sv);
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
|| isGV_with_GP(sv) || SvROK(sv)) {
SV *sv2 = sv_newmortal();
- sv_copypv(sv2,sv);
+ sv_copypv_nomg(sv2,sv);
sv = sv2;
}
- else SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
}
return SvRV(sv) != 0;
}
+ if (isREGEXP(sv))
+ return
+ RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
*/
+static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
+
STRLEN
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
}
if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
+ S_sv_uncow(aTHX_ sv, 0);
}
if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
int mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
+ S_sv_uncow(aTHX_ sv, 0);
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
/* update pos */
);
}
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
+ if (GvIO(dstr) && dtype == SVt_PVGV) {
+ DEBUG_o(Perl_deb(aTHX_
+ "glob_assign_glob clearing PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
return;
}
}
break;
- /* case SVt_BIND: */
+ case SVt_INVLIST:
case SVt_PVLV:
case SVt_PVGV:
case SVt_PVMG:
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
# ifdef PERL_OLD_COPY_ON_WRITE
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV
+ && SvTYPE(sstr) >= SVt_PVIV && len
# else
&& !(SvFLAGS(dstr) & SVf_BREAK)
&& !(sflags & SVf_IsCOW)
{
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
- Safefree(SvPVX(sv));
+ SvPV_free(sv);
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
=cut
*/
-void
-Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
+static void
+S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
{
dVAR;
- PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
-
+ assert(SvIsCOW(sv));
+ {
#ifdef PERL_ANY_COW
- if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
- Perl_croak_no_modify();
- }
- else if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
sv_dump(sv);
}
}
- }
#else
- if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
- Perl_croak_no_modify();
- }
- else
- if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvIsCOW_off(sv);
*SvEND(sv) = '\0';
}
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
- }
#endif
+ }
+}
+
+void
+Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
+{
+ PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
+
+ if (SvREADONLY(sv))
+ Perl_croak_no_modify();
+ else if (SvIsCOW(sv))
+ S_sv_uncow(aTHX_ sv, flags);
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && isGV_with_GP(sv))
evacp = p - evacn;
#endif
+ /* This sets 'delta' to the accumulated value of all deltas so far */
delta += old_delta;
assert(delta);
+
+ /* If 'delta' fits in a byte, store it just prior to the new beginning of
+ * the string; otherwise store a 0 byte there and store 'delta' just prior
+ * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
+ * portion of the chopped part of the string */
if (delta < 0x100) {
*--p = (U8) delta;
} else {
PERL_ARGS_ASSERT_SV_MAGICEXT;
+ if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
+
SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
return mg;
}
+MAGIC *
+Perl_sv_magicext_mglob(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+ /* This sv is only a delegate. //g magic must be attached to
+ its target. */
+ vivify_defelem(sv);
+ sv = LvTARG(sv);
+ }
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+#endif
+ return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
+ &PL_vtbl_mglob, 0, 0);
+}
+
/*
=for apidoc sv_magic
vtable = (vtable_index == magic_vtable_max)
? NULL : PL_magic_vtables + vtable_index;
-#ifdef PERL_ANY_COW
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
if (
- /* its okay to attach magic to shared strings */
- !SvIsCOW(sv)
-
- && IN_PERL_RUNTIME
- && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
+ !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
Perl_croak_no_modify();
}
else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(SvOURSTASH(sv));
+ }
+ else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
+ assert(!SvMAGICAL(sv));
} else if (SvMAGIC(sv)) {
/* Free back-references before other types of magic. */
sv_unmagic(sv, PERL_MAGIC_backref);
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
- /* case SVt_BIND: */
+ /* case SVt_INVLIST: */
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
+ case SVt_INVLIST:
case SVt_PV:
freescalar:
/* Don't bother with SvOOK_off(sv); as we're only going to
PERL_ARGS_ASSERT_SV_FREE2;
- if (rc == 1) {
+ if (LIKELY( rc == 1 )) {
/* normal case */
SvREFCNT(sv) = 0;
/*
=for apidoc sv_pos_u2b_flags
-Converts the value pointed to by offsetp from a count of UTF-8 chars from
+Converts the offset from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
the offset, rather than from the start
assert(*mgp);
(*mgp)->mg_len = ulen;
- /* For now, treat "overflowed" as "still unknown". See RT #72924. */
- if (ulen != (STRLEN) (*mgp)->mg_len)
- (*mgp)->mg_len = -1;
}
/* Create and update the UTF8 magic offset cache, with the proffered utf8/
}
/*
-=for apidoc sv_pos_b2u
+=for apidoc sv_pos_b2u_flags
-Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF-8 chars.
-Handles magic and type coercion.
+Converts the offset from a count of bytes from the start of the string, to
+a count of the equivalent number of UTF-8 chars. Handles type coercion.
+I<flags> is passed to C<SvPV_flags>, and usually should be
+C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
*/
/*
- * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
- * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
- * byte offsets.
+ * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
+ * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
+ * and byte offsets.
*
*/
-void
-Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
+STRLEN
+Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
{
const U8* s;
- const STRLEN byte = *offsetp;
STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
STRLEN blen;
MAGIC* mg = NULL;
const U8* send;
bool found = FALSE;
- PERL_ARGS_ASSERT_SV_POS_B2U;
-
- if (!sv)
- return;
+ PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
- s = (const U8*)SvPV_const(sv, blen);
+ s = (const U8*)SvPV_flags(sv, blen, flags);
- if (blen < byte)
+ if (blen < offset)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
- ", byte=%"UVuf, (UV)blen, (UV)byte);
+ ", byte=%"UVuf, (UV)blen, (UV)offset);
- send = s + byte;
+ send = s + offset;
if (!SvREADONLY(sv)
&& PL_utf8cache
{
if (mg->mg_ptr) {
STRLEN * const cache = (STRLEN *) mg->mg_ptr;
- if (cache[1] == byte) {
+ if (cache[1] == offset) {
/* An exact match. */
- *offsetp = cache[0];
- return;
+ return cache[0];
}
- if (cache[3] == byte) {
+ if (cache[3] == offset) {
/* An exact match. */
- *offsetp = cache[2];
- return;
+ return cache[2];
}
- if (cache[1] < byte) {
+ if (cache[1] < offset) {
/* We already know part of the way. */
if (mg->mg_len != -1) {
/* Actually, we know the end too. */
len = cache[0] + utf8_length(s + cache[1], send);
}
}
- else if (cache[3] < byte) {
+ else if (cache[3] < offset) {
/* We're between the two cached pairs, so we do the calculation
offset by the byte/utf-8 positions for the earlier pair,
then add the utf-8 characters from the string start to
+ cache[2];
}
- else { /* cache[3] > byte */
+ else { /* cache[3] > offset */
len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
cache[2]);
assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
len = real_len;
}
- *offsetp = len;
if (PL_utf8cache) {
- if (blen == byte)
+ if (blen == offset)
utf8_mg_len_cache_update(sv, &mg, len);
else
- utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+ utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
}
+
+ return len;
+}
+
+/*
+=for apidoc sv_pos_b2u
+
+Converts the value pointed to by offsetp from a count of bytes from the
+start of the string, to a count of the equivalent number of UTF-8 chars.
+Handles magic and type coercion.
+
+Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
+longer than 2Gb.
+
+=cut
+*/
+
+/*
+ * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
+ * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
+ * byte offsets.
+ *
+ */
+void
+Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
+{
+ PERL_ARGS_ASSERT_SV_POS_B2U;
+
+ if (!sv)
+ return;
+
+ *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
+ SV_GMAGIC|SV_CONST_RETURN);
}
static void
#include <rms.h>
int fd;
Stat_t st;
- dSAVE_ERRNO;
/* With a true, record-oriented file on VMS, we need to use read directly
* to ensure that we respect RMS record boundaries. The user is responsible
|| st.st_fab_rfm == FAB$C_VFC
|| st.st_fab_rfm == FAB$C_FIX)) {
- /* fstat does the equivalent of SETERRNO(EVMSERR, RMS$_IOP) on PPFs. */
- RESTORE_ERRNO;
bytesread = PerlLIO_read(fd, buffer, recsize);
}
else /* in-memory file from PerlIO::Scalar
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv) || isGV_with_GP(sv))
- sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
if (SvROK(sv)) {
sv_unref(sv);
sv_setiv(sv, i);
}
+ else sv_force_normal_flags(sv, 0);
}
flags = SvFLAGS(sv);
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv) || isGV_with_GP(sv))
- sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
if (SvROK(sv)) {
sv_unref(sv);
sv_setiv(sv, i);
}
+ else sv_force_normal_flags(sv, 0);
}
/* Unlike sv_inc we don't have to worry about string-never-numbers
and keeping them magic. But we mustn't warn on punting */
new_SV(sv);
sv_setpvn(sv,s,len);
- /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
- * and do what it does ourselves here.
- * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
- * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
- * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
- * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
- */
+ /* This code used to do a sv_2mortal(), however we now unroll the call to
+ * sv_2mortal() and do what it does ourselves here. Since we have asserted
+ * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
+ * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
+ * in turn means we dont need to mask out the SVf_UTF8 flag below, which
+ * means that we eliminate quite a few steps than it looks - Yves
+ * (explaining patch by gfx) */
SvFLAGS(sv) |= flags;
char todo[PERL_UCHAR_MAX+1];
const char *send;
- if (!stash)
+ if (!stash || SvTYPE(stash) != SVt_PVHV)
return;
if (!s) { /* reset ?? searches */
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
if (flags & SV_GMAGIC) SvGETMAGIC(sv);
- if (SvTHINKFIRST(sv) && !SvROK(sv))
+ if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
char *s;
STRLEN len;
- if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
- const char * const ref = sv_reftype(sv,0);
- if (PL_op)
- Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
- ref, OP_DESC(PL_op));
- else
- Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
- }
if (SvTYPE(sv) > SVt_PVLV
|| isGV_with_GP(sv))
/* diag_listed_as: Can't coerce %s to %s in %s */
? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
- case SVt_BIND: return "BIND";
+ case SVt_INVLIST: return "INVLIST";
case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
PERL_ARGS_ASSERT_SV_BLESS;
+ SvGETMAGIC(sv);
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
+ if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
SvREFCNT_dec(SvSTASH(tmpRef));
%-<num>p include an SV with precision <num>
%2p include a HEK
%3p include a HEK with precision of 256
- %<num>p (where num != 2 or 3) reserved for future
+ %4p char* preceded by utf8 flag and length
+ %<num>p (where num is 1 or > 4) reserved for future
extensions
Robin Barker 2005-07-14 (but modified since)
STRLEN n = 0;
if (*q == '-')
sv = *q++;
+ else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
+ /* The argument has already gone through cBOOL, so the cast
+ is safe. */
+ is_utf8 = (bool)va_arg(*args, int);
+ elen = va_arg(*args, UV);
+ eptr = va_arg(*args, char *);
+ q += sizeof(UTF8f)-1;
+ goto string;
+ }
n = expect_number(&q);
if (*q++ == 'p') {
if (sv) { /* SVf */
}
float_converted:
eptr = PL_efloatbuf;
+ if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+ && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
+ {
+ is_utf8 = TRUE;
+ }
+
break;
/* SPECIAL */
SvANY(dstr) = new_XNV();
SvNV_set(dstr, SvNVX(sstr));
break;
- /* case SVt_BIND: */
default:
{
/* These are all the types that need complex bodies allocating. */
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
+ case SVt_INVLIST:
case SVt_PV:
assert(sv_type_details->body_size);
if (sv_type_details->arena) {
if (sv_type >= SVt_PVMG) {
if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
+ } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
+ NOOP;
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvOBJECT(dstr) && SvSTASH(dstr))
}
daux->xhv_name_count = saux->xhv_name_count;
+ daux->xhv_fill_lazy = saux->xhv_fill_lazy;
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
/* fall through */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
+ case SAVEt_READONLY_OFF:
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
break;
+ case SAVEt_ADELETE:
+ av = (const AV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = av_dup_inc(av, param);
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
case SAVEt_DELETE:
hv = (const HV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
- case SAVEt_RE_STATE:
- {
- const struct re_save_state *const old_state
- = (struct re_save_state *)
- (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
- struct re_save_state *const new_state
- = (struct re_save_state *)
- (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
-
- Copy(old_state, new_state, 1, struct re_save_state);
- ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
-
- new_state->re_state_bostr
- = pv_dup(old_state->re_state_bostr);
- new_state->re_state_regeol
- = pv_dup(old_state->re_state_regeol);
-#ifdef PERL_ANY_COW
- new_state->re_state_nrs
- = sv_dup(old_state->re_state_nrs, param);
-#endif
- new_state->re_state_reg_magic
- = (MAGIC*) any_dup(old_state->re_state_reg_magic,
- proto_perl);
- new_state->re_state_reg_oldcurpm
- = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
- proto_perl);
- new_state->re_state_reg_curpm
- = (PMOP*) any_dup(old_state->re_state_reg_curpm,
- proto_perl);
- new_state->re_state_reg_oldsaved
- = pv_dup(old_state->re_state_reg_oldsaved);
- new_state->re_state_reg_poscache
- = pv_dup(old_state->re_state_reg_poscache);
- new_state->re_state_reg_starttry
- = pv_dup(old_state->re_state_reg_starttry);
- break;
- }
case SAVEt_COMPILE_WARNINGS:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
#endif
/* RE engine related */
- Zero(&PL_reg_state, 1, struct re_save_state);
PL_regmatch_slab = NULL;
+ PL_reg_curpm = NULL;
PL_sub_generation = proto_perl->Isub_generation;
PL_cryptseen = proto_perl->Icryptseen;
#endif
- PL_hints = proto_perl->Ihints;
-
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_standard = proto_perl->Icollation_standard;
/* regex stuff */
- PL_regdummy = proto_perl->Iregdummy;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+ Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
+
/* This PV will be free'd special way so must set it same way op.c does */
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
/* Unicode inversion lists */
PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+ PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
- PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
- PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
- PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Isortstash, param);
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
break;
}
else {
+ SV * const opsv = cSVOPx_sv(kid);
+ const IV opsviv = SvIV(opsv);
SV * const * const svp = av_fetch(MUTABLE_AV(sv),
- negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
+ negate ? - opsviv : opsviv,
FALSE);
if (!svp || *svp != uninit_sv)
break;