Safefree(arena);
}
PL_xiv_arenaroot = 0;
+ PL_xiv_root = 0;
for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xnv_arenaroot = 0;
+ PL_xnv_root = 0;
for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xrv_arenaroot = 0;
+ PL_xrv_root = 0;
for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpv_arenaroot = 0;
+ PL_xpv_root = 0;
for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpviv_arenaroot = 0;
+ PL_xpviv_root = 0;
for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvnv_arenaroot = 0;
+ PL_xpvnv_root = 0;
for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvcv_arenaroot = 0;
+ PL_xpvcv_root = 0;
for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvav_arenaroot = 0;
+ PL_xpvav_root = 0;
for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvhv_arenaroot = 0;
+ PL_xpvhv_root = 0;
for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvmg_arenaroot = 0;
+ PL_xpvmg_root = 0;
for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvlv_arenaroot = 0;
+ PL_xpvlv_root = 0;
for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_xpvbm_arenaroot = 0;
+ PL_xpvbm_root = 0;
for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
}
PL_he_arenaroot = 0;
+ PL_he_root = 0;
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
LvTARGLEN(sv) = 0;
LvTARG(sv) = 0;
LvTYPE(sv) = 0;
+ GvGP(sv) = 0;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
break;
case SVt_PVAV:
SvANY(sv) = new_XPVAV();
}
#endif /* !NV_PRESERVES_UV*/
+/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
+ * this function provided for binary compatibility only
+ */
+
+IV
+Perl_sv_2iv(pTHX_ register SV *sv)
+{
+ return sv_2iv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2iv
+=for apidoc sv_2iv_flags
-Return the integer value of an SV, doing any necessary string conversion,
-magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
*/
IV
-Perl_sv_2iv(pTHX_ register SV *sv)
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
if (SvNOKp(sv)) {
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
+ * this function provided for binary compatibility only
+ */
+
+UV
+Perl_sv_2uv(pTHX_ register SV *sv)
+{
+ return sv_2uv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2uv
+=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
=cut
*/
UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvUVX(sv);
if (SvNOKp(sv))
=for apidoc sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF8 as a side-effect.
+May cause the SV to be downgraded from UTF-8 as a side-effect.
Usually accessed via the C<SvPVbyte_nolen> macro.
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be downgraded from UTF8 as a
+to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
Usually accessed via the C<SvPVbyte> macro.
/*
=for apidoc sv_2pvutf8_nolen
-Return a pointer to the UTF8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8_nolen> macro.
/*
=for apidoc sv_2pvutf8
-Return a pointer to the UTF8-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
/*
=for apidoc sv_utf8_upgrade
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
This may not be possible if the PV contains non-byte encoding characters;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
flag so that it looks like octets again. Used as a building block
for encode_utf8 in Encode.xs
if (dtype != SVt_PVGV) {
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
- sv_upgrade(dstr, SVt_PVGV);
+ /* don't upgrade SVt_PVLV: it can hold a glob */
+ if (dtype != SVt_PVLV)
+ sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
* has to be allocated and SvPVX(sstr) has to be freed.
*/
+ /* Whichever path we take through the next code, we want this true,
+ and doing it now facilitates the COW check. */
+ (void)SvPOK_only(dstr);
+
if (
#ifdef PERL_COPY_ON_WRITE
(sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
!(PL_op && PL_op->op_type == OP_AASSIGN))
#ifdef PERL_COPY_ON_WRITE
&& !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
&& SvTYPE(sstr) >= SVt_PVIV)
#endif
) {
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
- (void)SvPOK_only(dstr);
} else {
/* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
be true in here. */
else if (SvLEN(dstr))
Safefree(SvPVX(dstr));
}
- (void)SvPOK_only(dstr);
#ifdef PERL_COPY_ON_WRITE
if (!isSwipe) {
sv_dump(sv);
}
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
/* At this point I believe that I can drop the global SV mutex. */
}
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
+ int is_utf8 = SvUTF8(sv);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
+ SvPVX(sv) = 0;
+ SvLEN(sv) = 0;
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
- unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
+ unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
#endif
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-If the SV has the UTF8 status set, then the bytes appended should be
-valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
=cut */
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling
+ if (IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
&& how != PERL_MAGIC_sv
+ && how != PERL_MAGIC_backref
)
{
Perl_croak(aTHX_ PL_no_modify);
* by magic_killbackrefs() when tsv is being freed */
}
if (AvFILLp(av) >= AvMAX(av)) {
+ I32 i;
SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == &PL_sv_undef) {
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (!svp[i]) {
svp[i] = sv; /* reuse the slot */
return;
}
- i--;
- }
av_extend(av, AvFILLp(av)+1);
}
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i] == sv) {
- svp[i] = &PL_sv_undef; /* XXX */
- }
- i--;
- }
+ for (i = AvFILLp(av); i >= 0; i--)
+ if (svp[i] == sv) svp[i] = Nullsv;
}
/*
#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
+ SvREFCNT(nsv) = 0;
del_SV(nsv);
}
return;
}
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf,
+ PTR2UV(sv));
return;
}
if (--(SvREFCNT(sv)) > 0)
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
=cut
*/
bool found = FALSE;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
- if (!*mgp) {
- sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
- *mgp = mg_find(sv, PERL_MAGIC_utf8);
- }
+ if (!*mgp)
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
assert(*mgp);
if ((*mgp)->mg_ptr)
/* Update the cache. */
(*cachep)[i] = (STRLEN)uoff;
(*cachep)[i+1] = p - start;
+
+ /* Drop the stale "length" cache */
+ if (i == 0) {
+ (*cachep)[2] = 0;
+ (*cachep)[3] = 0;
+ }
found = TRUE;
}
/*
=for apidoc sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF8 chars from
+Converts the value pointed to by offsetp 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 of the string. Handles magic and
=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 UTF8 chars.
+start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
=cut
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
/* we always read code in line mode */
rsptr = "\n";
rslen = 1;
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
}
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
+#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
if (gv == PL_envgv
# ifdef USE_ITHREADS
environ[0] = Nullch;
}
#endif
+#endif /* !PERL_MICRO */
}
}
}
the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
Do not use with other Perl types such as HV, AV, SV, CV, because those
objects will become corrupted by the pointer copy process.
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will be returned and will have
-a reference count of 1.
+C<Nullch> to avoid the blessing. The new SV will have a reference count
+of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
}
#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+static char *
+F0convert(NV nv, char *endbuf, STRLEN *len)
+{
+ int neg = nv < 0;
+ UV uv;
+ char *p = endbuf;
+
+ if (neg)
+ nv = -nv;
+ if (nv < UV_MAX) {
+ nv += 0.5;
+ uv = (UV)nv;
+ if (uv & 1 && uv == nv)
+ uv--; /* Round to even */
+ do {
+ unsigned dig = uv % 10;
+ *--p = '0' + dig;
+ } while (uv /= 10);
+ if (neg)
+ *--p = '-';
+ *len = endbuf - p;
+ return p;
+ }
+ return Nullch;
+}
+
+
/*
=for apidoc sv_vcatpvfn
bool has_utf8; /* has the result utf8? */
bool pat_utf8; /* the pattern is in utf8? */
SV *nsv = Nullsv;
+ /* Times 4: a decimal digit takes more than 3 binary digits.
+ * NV_DIG: mantissa takes than many decimal digits.
+ * Plus 32: Playing safe. */
+ char ebuf[IV_DIG * 4 + NV_DIG + 32];
+ /* large enough for "%#.#f" --chip */
+ /* what about long double NVs? --jhi */
has_utf8 = pat_utf8 = DO_UTF8(sv);
}
}
+#ifndef USE_LONG_DOUBLE
+ /* special-case "%.<number>[gf]" */
+ if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+ && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
+ unsigned digits = 0;
+ const char *pp;
+
+ pp = pat + 2;
+ while (*pp >= '0' && *pp <= '9')
+ digits = 10 * digits + (*pp++ - '0');
+ if (pp - pat == (int)patlen - 1) {
+ NV nv;
+
+ if (args)
+ nv = (NV)va_arg(*args, double);
+ else if (svix < svmax)
+ nv = SvNV(*svargs);
+ else
+ return;
+ if (*pp == 'g') {
+ /* Add check for digits != 0 because it seems that some
+ gconverts are buggy in this case, and we don't yet have
+ a Configure test for this. */
+ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+ /* 0, point, slack */
+ Gconvert(nv, (int)digits, 0, ebuf);
+ sv_catpv(sv, ebuf);
+ if (*ebuf) /* May return an empty string for digits==0 */
+ return;
+ }
+ } else if (!digits) {
+ STRLEN l;
+
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn(sv, p, l);
+ return;
+ }
+ }
+ }
+ }
+#endif /* !USE_LONG_DOUBLE */
+
if (!args && svix < svmax && DO_UTF8(*svargs))
has_utf8 = TRUE;
char *eptr = Nullch;
STRLEN elen = 0;
- /* Times 4: a decimal digit takes more than 3 binary digits.
- * NV_DIG: mantissa takes than many decimal digits.
- * Plus 32: Playing safe. */
- char ebuf[IV_DIG * 4 + NV_DIG + 32];
- /* large enough for "%#.#f" --chip */
- /* what about long double NVs? --jhi */
-
SV *vecsv = Nullsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
else if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
- default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ default: iv = va_arg(*args, int); break;
#ifdef HAS_QUAD
case 'q': iv = va_arg(*args, Quad_t); break;
#endif
}
}
else {
- iv = SvIVx(argsv);
+ IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': iv = (short)iv; break;
- default: break;
- case 'l': iv = (long)iv; break;
- case 'V': break;
+ case 'h': iv = (short)tiv; break;
+ case 'l': iv = (long)tiv; break;
+ case 'V':
+ default: iv = tiv; break;
#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)iv; break;
+ case 'q': iv = (Quad_t)tiv; break;
#endif
}
}
else if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
- default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ default: uv = va_arg(*args, unsigned); break;
#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Quad_t); break;
+ case 'q': uv = va_arg(*args, Uquad_t); break;
#endif
}
}
else {
- uv = SvUVx(argsv);
+ UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
switch (intsize) {
- case 'h': uv = (unsigned short)uv; break;
- default: break;
- case 'l': uv = (unsigned long)uv; break;
- case 'V': break;
+ case 'h': uv = (unsigned short)tuv; break;
+ case 'l': uv = (unsigned long)tuv; break;
+ case 'V':
+ default: uv = tuv; break;
#ifdef HAS_QUAD
- case 'q': uv = (Quad_t)uv; break;
+ case 'q': uv = (Uquad_t)tuv; break;
#endif
}
}
PL_efloatbuf[0] = '\0';
}
+ if ( !(width || left || plus || alt) && fill != '0'
+ && has_precis && intsize != 'q' ) { /* Shortcuts */
+ /* See earlier comment about buggy Gconvert when digits,
+ aka precis is 0 */
+ if ( c == 'g' && precis) {
+ Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+ if (*PL_efloatbuf) /* May return an empty string for digits==0 */
+ goto float_converted;
+ } else if ( c == 'f' && !precis) {
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ break;
+ }
+ }
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
#else
(void)sprintf(PL_efloatbuf, eptr, nv);
#endif
+ float_converted:
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
break;
continue; /* not "break" */
}
+ /* calculate width before utf8_upgrade changes it */
+ have = esignlen + zeros + elen;
+
if (is_utf8 != has_utf8) {
if (is_utf8) {
if (SvCUR(sv))
"Newline in left-justified string for %sprintf",
(PL_op->op_type == OP_PRTF) ? "" : "s");
- have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- AV *av = (AV*) mg->mg_obj;
- SV **svp;
- I32 i;
- nmg->mg_obj = (SV*)newAV();
- svp = AvARRAY(av);
- i = AvFILLp(av);
- while (i >= 0) {
- av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- i--;
- }
+ AV *av = (AV*) mg->mg_obj;
+ SV **svp;
+ I32 i;
+ SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
+ svp = AvARRAY(av);
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (!svp[i]) continue;
+ av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
+ }
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
GvHV(gv) = (HV*)sv;
}
else {
- SvREADONLY_on(GvAV(gv));
+ SvREADONLY_on(GvHV(gv));
}
return sstr; /* he_dup() will SvREFCNT_inc() */
SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
}
- CvGV(dstr) = gv_dup(CvGV(sstr), param);
+ /* don't dup if copying back - CvGV isn't refcounted, so the
+ * duped GV may never be freed. A bit of a hack! DAPM */
+ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
+ Nullgv : gv_dup(CvGV(sstr), param) ;
if (param->flags & CLONEf_COPY_STACKS) {
CvDEPTH(dstr) = CvDEPTH(sstr);
} else {
longval = (long)POPBOOL(ss,ix);
TOPBOOL(nss,ix) = (bool)longval;
break;
+ case SAVEt_SET_SVFLAGS:
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
}
PL_debug = proto_perl->Idebug;
#ifdef USE_REENTRANT_API
+ /* XXX: things like -Dm will segfault here in perlio, but doing
+ * PERL_SET_CONTEXT(proto_perl);
+ * breaks too many other things
+ */
Perl_reentrant_init(aTHX);
#endif
PL_egid = proto_perl->Iegid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
- PL_op_seqmax = proto_perl->Iop_seqmax;
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
PL_last_swash_tmps = (U8*)NULL;
PL_last_swash_slen = 0;
- /* perly.c globals */
- PL_yydebug = proto_perl->Iyydebug;
- PL_yynerrs = proto_perl->Iyynerrs;
- PL_yyerrflag = proto_perl->Iyyerrflag;
- PL_yychar = proto_perl->Iyychar;
- PL_yyval = proto_perl->Iyyval;
- PL_yylval = proto_perl->Iyylval;
-
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */