{
SV* sva;
SV* svanext;
+ XPV *arena, *arenanext;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
Safefree((void *)sva);
}
+ for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xiv_arenaroot = 0;
+
+ for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xnv_arenaroot = 0;
+
+ for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xrv_arenaroot = 0;
+
+ for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpviv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvnv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvcv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvav_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvhv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvmg_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvlv_arenaroot = 0;
+
+ for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvbm_arenaroot = 0;
+
+ for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_he_arenaroot = 0;
+
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
PL_nice_chunk = Nullch;
{
register NV* xnv;
register NV* xnvend;
- New(711, xnv, 1008/sizeof(NV), NV);
+ XPV *ptr;
+ New(711, ptr, 1008/sizeof(XPV), XPV);
+ ptr->xpv_pv = (char*)PL_xnv_arenaroot;
+ PL_xnv_arenaroot = ptr;
+
+ xnv = (NV*) ptr;
xnvend = &xnv[1008 / sizeof(NV) - 1];
xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
PL_xnv_root = xnv;
{
register XRV* xrv;
register XRV* xrvend;
- New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
- xrv = PL_xrv_root;
+ XPV *ptr;
+ New(712, ptr, 1008/sizeof(XPV), XPV);
+ ptr->xpv_pv = (char*)PL_xrv_arenaroot;
+ PL_xrv_arenaroot = ptr;
+
+ xrv = (XRV*) ptr;
xrvend = &xrv[1008 / sizeof(XRV) - 1];
+ xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
+ PL_xrv_root = xrv;
while (xrv < xrvend) {
xrv->xrv_rv = (SV*)(xrv + 1);
xrv++;
{
register XPV* xpv;
register XPV* xpvend;
- New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
- xpv = PL_xpv_root;
+ New(713, xpv, 1008/sizeof(XPV), XPV);
+ xpv->xpv_pv = (char*)PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
xpvend = &xpv[1008 / sizeof(XPV) - 1];
+ PL_xpv_root = ++xpv;
while (xpv < xpvend) {
xpv->xpv_pv = (char*)(xpv + 1);
xpv++;
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpviv(pTHX)
{
register XPVIV* xpviv;
register XPVIV* xpvivend;
- New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
- xpviv = PL_xpviv_root;
+ New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
+ xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
+
xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
+ PL_xpviv_root = ++xpviv;
while (xpviv < xpvivend) {
xpviv->xpv_pv = (char*)(xpviv + 1);
xpviv++;
xpviv->xpv_pv = 0;
}
-
STATIC XPVNV*
S_new_xpvnv(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvnv(pTHX)
{
register XPVNV* xpvnv;
register XPVNV* xpvnvend;
- New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
- xpvnv = PL_xpvnv_root;
+ New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
+ xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
+ PL_xpvnv_arenaroot = xpvnv;
+
xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
+ PL_xpvnv_root = ++xpvnv;
while (xpvnv < xpvnvend) {
xpvnv->xpv_pv = (char*)(xpvnv + 1);
xpvnv++;
xpvnv->xpv_pv = 0;
}
-
-
STATIC XPVCV*
S_new_xpvcv(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvcv(pTHX)
{
register XPVCV* xpvcv;
register XPVCV* xpvcvend;
- New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
- xpvcv = PL_xpvcv_root;
+ New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
+ xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
+ PL_xpvcv_arenaroot = xpvcv;
+
xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
+ PL_xpvcv_root = ++xpvcv;
while (xpvcv < xpvcvend) {
xpvcv->xpv_pv = (char*)(xpvcv + 1);
xpvcv++;
xpvcv->xpv_pv = 0;
}
-
-
STATIC XPVAV*
S_new_xpvav(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvav(pTHX)
{
register XPVAV* xpvav;
register XPVAV* xpvavend;
- New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
- xpvav = PL_xpvav_root;
+ New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
+ xpvav->xav_array = (char*)PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
+
xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
+ PL_xpvav_root = ++xpvav;
while (xpvav < xpvavend) {
xpvav->xav_array = (char*)(xpvav + 1);
xpvav++;
xpvav->xav_array = 0;
}
-
-
STATIC XPVHV*
S_new_xpvhv(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvhv(pTHX)
{
register XPVHV* xpvhv;
register XPVHV* xpvhvend;
- New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
- xpvhv = PL_xpvhv_root;
+ New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
+ xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
+ PL_xpvhv_root = ++xpvhv;
while (xpvhv < xpvhvend) {
xpvhv->xhv_array = (char*)(xpvhv + 1);
xpvhv++;
xpvhv->xhv_array = 0;
}
-
STATIC XPVMG*
S_new_xpvmg(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvmg(pTHX)
{
register XPVMG* xpvmg;
register XPVMG* xpvmgend;
- New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
- xpvmg = PL_xpvmg_root;
+ New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
+ xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
+ PL_xpvmg_arenaroot = xpvmg;
+
xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
+ PL_xpvmg_root = ++xpvmg;
while (xpvmg < xpvmgend) {
xpvmg->xpv_pv = (char*)(xpvmg + 1);
xpvmg++;
xpvmg->xpv_pv = 0;
}
-
-
STATIC XPVLV*
S_new_xpvlv(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvlv(pTHX)
{
register XPVLV* xpvlv;
register XPVLV* xpvlvend;
- New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
- xpvlv = PL_xpvlv_root;
+ New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
+ xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
+
xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
while (xpvlv < xpvlvend) {
xpvlv->xpv_pv = (char*)(xpvlv + 1);
xpvlv++;
xpvlv->xpv_pv = 0;
}
-
STATIC XPVBM*
S_new_xpvbm(pTHX)
{
UNLOCK_SV_MUTEX;
}
-
STATIC void
S_more_xpvbm(pTHX)
{
register XPVBM* xpvbm;
register XPVBM* xpvbmend;
- New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
- xpvbm = PL_xpvbm_root;
+ New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
+ xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
+ PL_xpvbm_arenaroot = xpvbm;
+
xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
+ PL_xpvbm_root = ++xpvbm;
while (xpvbm < xpvbmend) {
xpvbm->xpv_pv = (char*)(xpvbm + 1);
xpvbm++;
#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
#define del_XPVHV(p) my_safefree(p)
-
+
#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
#define del_XPVMG(p) my_safefree(p)
#define new_XPVHV() (void*)new_xpvhv()
#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-
+
#define new_XPVMG() (void*)new_xpvmg()
#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
#define del_XPVGV(p) my_safefree(p)
-
+
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
-
+
#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
#define del_XPVIO(p) my_safefree(p)
#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
+#define IS_NUMBER_INFINITY 0x10 /* this is big */
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
SvUVX(sv) = U_V(SvNVX(sv));
SvIsUV_on(sv);
ret_iv_max:
- DEBUG_c(PerlIO_printf(Perl_debug_log,
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
PTR2UV(sv),
SvUVX(sv),
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
the translation of the initial data.
-
+
This means that if we cache such an IV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
cache the NV if not needed.
goto ret_iv_max;
}
}
- else if (numtype) {
- /* The NV may be reconstructed from IV - safe to cache IV,
- which may be calculated by atol(). */
- if (SvTYPE(sv) == SVt_PV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = Atol(SvPVX(sv));
- }
- else { /* Not a number. Cache 0. */
- dTHR;
-
+ else { /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- SvIVX(sv) = 0;
(void)SvIOK_on(sv);
- if (ckWARN(WARN_NUMERIC))
+ SvIVX(sv) = Atol(SvPVX(sv));
+ if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
}
else {
SvIVX(sv) = I_V(SvNVX(sv));
ret_zero:
- DEBUG_c(PerlIO_printf(Perl_debug_log,
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
PTR2UV(sv),
SvIVX(sv),
/* We want to avoid a possible problem when we cache a UV which
may be later translated to an NV, and the resulting NV is not
the translation of the initial data.
-
+
This means that if we cache such a UV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
cache the NV if not needed.
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- SvUVX(sv) = 0; /* We assume that 0s have the
- same bitmap in IV and UV. */
(void)SvIOK_on(sv);
(void)SvIsUV_on(sv);
+ SvUVX(sv) = 0; /* We assume that 0s have the
+ same bitmap in IV and UV. */
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
return Atof(SvPVX(sv));
}
if (SvIOKp(sv)) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv))
return (NV)SvUVX(sv);
else
return (NV)SvIVX(sv);
sv_upgrade(sv, SVt_NV);
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
"0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv));
});
#else
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
SvNOK_on(sv);
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
#else
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
* IS_NUMBER_TO_INT_BY_ATOL 123
* IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
* IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
+ * IS_NUMBER_INFINITY
* with a possible addition of IS_NUMBER_NEG.
*/
register char *sbegin;
register char *nbegin;
I32 numtype = 0;
+ I32 sawinf = 0;
STRLEN len;
if (SvPOK(sv)) {
- sbegin = SvPVX(sv);
+ sbegin = SvPVX(sv);
len = SvCUR(sv);
}
else if (SvPOKp(sv))
* (int)atof().
*/
- /* next must be digit or the radix separator */
+ /* next must be digit or the radix separator or beginning of infinity */
if (isDIGIT(*s)) {
do {
s++;
numtype |= IS_NUMBER_TO_INT_BY_ATOL;
if (*s == '.'
-#ifdef USE_LOCALE_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
|| IS_NUMERIC_RADIX(*s)
#endif
) {
}
}
else if (*s == '.'
-#ifdef USE_LOCALE_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
|| IS_NUMERIC_RADIX(*s)
#endif
) {
else
return 0;
}
+ else if (*s == 'I' || *s == 'i') {
+ s++; if (*s != 'N' && *s != 'n') return 0;
+ s++; if (*s != 'F' && *s != 'f') return 0;
+ s++; if (*s == 'I' || *s == 'i') {
+ s++; if (*s != 'N' && *s != 'n') return 0;
+ s++; if (*s != 'I' && *s != 'i') return 0;
+ s++; if (*s != 'T' && *s != 't') return 0;
+ s++; if (*s != 'Y' && *s != 'y') return 0;
+ }
+ sawinf = 1;
+ }
else
return 0;
- /* we can have an optional exponent part */
- if (*s == 'e' || *s == 'E') {
- numtype &= ~IS_NUMBER_NEG;
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
- s++;
- if (*s == '+' || *s == '-')
+ if (sawinf)
+ numtype = IS_NUMBER_INFINITY;
+ else {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ numtype &= ~IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
s++;
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
- }
- else
- return 0;
+ if (*s == '+' || *s == '-')
+ s++;
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
}
while (isSPACE(*s))
s++;
return SvPVX(sv);
}
if (SvIOKp(sv)) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv))
(void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
else
(void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
switch (SvTYPE(sv)) {
case SVt_PVMG:
if ( ((SvFLAGS(sv) &
- (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
+ (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
&& (mg = mg_find(sv, 'r'))) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
- case SVt_PVBM: s = "SCALAR"; break;
+ case SVt_PVBM: if (SvROK(sv))
+ s = "REF";
+ else
+ s = "SCALAR"; break;
case SVt_PVLV: s = "LVALUE"; break;
case SVt_PVAV: s = "ARRAY"; break;
case SVt_PVHV: s = "HASH"; break;
}
if (SvNOKp(sv)) { /* See note in sv_2uv() */
/* XXXX 64-bit? IV may have better precision... */
- /* I tried changing this for to be 64-bit-aware and
+ /* I tried changing this to be 64-bit-aware and
* the t/op/numconvert.t became very, very, angry.
* --jhi Sep 1999 */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- SvGROW(sv, 28);
+ /* The +20 is pure guesswork. Configure test needed. --jhi */
+ SvGROW(sv, NV_DIG + 20);
s = SvPVX(sv);
olderrno = errno; /* some Xenix systems wipe out errno here */
#ifdef apollo
sv_utf8_upgrade(sv);
return sv_2pv(sv,lp);
}
-
+
/* This function is only called on magical items */
bool
Perl_sv_2bool(pTHX_ register SV *sv)
}
}
+/*
+=for apidoc sv_utf8_upgrade
+
+Convert the PV of an SV to its UTF8-encoded form.
+
+=cut
+*/
+
void
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
}
}
+/*
+=for apidoc sv_utf8_downgrade
+
+Attempt to convert the PV of an SV from UTF8-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.
+
+=cut
+*/
+
bool
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
return TRUE;
}
+/*
+=for apidoc sv_utf8_encode
+
+Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+flag so that it looks like bytes again. Nothing calls this.
+
+=cut
+*/
+
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, '*', name, len);
+ sv_magic(dstr, dstr, '*', Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
(CvROOT(cv) || CvXSUB(cv)))
{
SV *const_sv = cv_const_sv(cv);
- bool const_changed = TRUE;
+ bool const_changed = TRUE;
if(const_sv)
- const_changed = sv_cmp(const_sv,
- op_const_sv(CvSTART((CV*)sref),
- Nullcv));
+ const_changed = sv_cmp(const_sv,
+ op_const_sv(CvSTART((CV*)sref),
+ (CV*)sref));
/* ahem, death to those who redefine
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_
+ Perl_croak(aTHX_
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
- Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
+ if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
+ Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
"Constant subroutine %s redefined"
- : "Subroutine %s redefined",
+ : "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
cv_ckproto(cv, (GV*)dstr,
dref = (SV*)GvIOp(dstr);
GvIOp(dstr) = (IO*)sref;
break;
+ case SVt_PVFM:
+ if (intro)
+ SAVESPTR(GvFORM(dstr));
+ else
+ dref = (SV*)GvFORM(dstr);
+ GvFORM(dstr) = (CV*)sref;
+ break;
default:
if (intro)
SAVESPTR(GvSV(dstr));
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
- if (SvIsUV(sstr))
+ if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
if (SvAMAGIC(sstr)) {
if (SvTEMP(sstr) && /* slated for free anyway? */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
- !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
+ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ SvLEN(sstr)) /* and really is a string */
{
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
SvPV_set(dstr, SvPVX(sstr));
SvLEN_set(dstr, SvLEN(sstr));
SvCUR_set(dstr, SvCUR(sstr));
- if (SvUTF8(sstr))
- SvUTF8_on(dstr);
- else
- SvUTF8_off(dstr);
SvTEMP_off(dstr);
- (void)SvOK_off(sstr);
+ (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
SvPV_set(sstr, Nullch);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
*SvEND(dstr) = '\0';
(void)SvPOK_only(dstr);
}
- if (DO_UTF8(sstr))
+ if ((sflags & SVf_UTF8) && !IN_BYTE)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
if (sflags & SVp_NOK) {
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
- if (SvIsUV(sstr))
+ if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
}
else if (sflags & SVp_NOK) {
SvNVX(dstr) = SvNVX(sstr);
(void)SvNOK_only(dstr);
- if (SvIOK(sstr)) {
+ if (sflags & SVf_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (SvIsUV(sstr))
+ if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
(void)SvIOK_only(dstr);
SvIVX(dstr) = SvIVX(sstr);
- if (SvIsUV(sstr))
+ if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
else {
=for apidoc sv_usepvn
Tells an SV to use C<ptr> to find its string value. Normally the string is
-stored inside the SV but sv_usepvn allows the SV to use an outside string.
+stored inside the SV but sv_usepvn allows the SV to use an outside string.
The C<ptr> should point to memory that was allocated by C<malloc>. The
string length, C<len>, must be supplied. This function will realloc the
memory pointed to by C<ptr>, so that pointer should not be freed or used by
{
if (SvREADONLY(sv)) {
dTHR;
- if (PL_curcop != &PL_compiling)
+ if (SvFAKE(sv)) {
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvCUR(sv);
+ U32 hash = SvUVX(sv);
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ unsharepvn(pvx,len,hash);
+ }
+ else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv))
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
}
-
+
/*
=for apidoc sv_chop
-Efficient removal of characters from the beginning of the string buffer.
+Efficient removal of characters from the beginning of the string buffer.
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
string.
void
Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
-
-
+
+
{
register STRLEN delta;
if (!sstr)
return;
if ((s = SvPV(sstr, len))) {
- if (SvUTF8(sstr))
+ if (DO_UTF8(sstr)) {
sv_utf8_upgrade(dstr);
- sv_catpvn(dstr,s,len);
- if (SvUTF8(sstr))
+ sv_catpvn(dstr,s,len);
SvUTF8_on(dstr);
+ }
+ else
+ sv_catpvn(dstr,s,len);
}
}
Perl_newSV(pTHX_ STRLEN len)
{
register SV *sv;
-
+
new_SV(sv);
if (len) {
sv_upgrade(sv, SVt_PV);
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
MAGIC* mg;
-
+
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling && !strchr("gBf", how))
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
-
+
switch (how) {
case 0:
mg->mg_virtual = &PL_vtbl_sv;
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
}
+/*
+=for apidoc sv_unmagic
+
+Removes magic from an SV.
+
+=cut
+*/
+
int
Perl_sv_unmagic(pTHX_ SV *sv, int type)
{
return 0;
}
+/*
+=for apidoc sv_rvweaken
+
+Weaken a reference.
+
+=cut
+*/
+
SV *
Perl_sv_rvweaken(pTHX_ SV *sv)
{
tsv = SvRV(sv);
sv_add_backref(tsv, sv);
SvWEAKREF_on(sv);
- SvREFCNT_dec(tsv);
+ SvREFCNT_dec(tsv);
return sv;
}
av_push(av,sv);
}
-STATIC void
+STATIC void
S_sv_del_backref(pTHX_ SV *sv)
{
AV *av;
register char *bigend;
register I32 i;
STRLEN curlen;
-
+
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
SvPV_force(bigstr, curlen);
+ (void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
SvSETMAGIC(bigstr);
}
-/* make sv point to what nstr did */
+/*
+=for apidoc sv_replace
+
+Make the first argument a copy of the second, then delete the original.
+
+=cut
+*/
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
del_SV(nsv);
}
+/*
+=for apidoc sv_clear
+
+Clear an SV, making it empty. Does not free the memory used by the SV
+itself.
+
+=cut
+*/
+
void
Perl_sv_clear(pTHX_ register SV *sv)
{
}
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
+ else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
+ unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
+ SvFAKE_off(sv);
+ }
break;
/*
case SVt_NV:
return sv;
}
+/*
+=for apidoc sv_free
+
+Free the memory used by an SV.
+
+=cut
+*/
+
void
Perl_sv_free(pTHX_ SV *sv)
{
return len;
}
+/*
+=for apidoc sv_len_utf8
+
+Returns the number of characters in the string in an SV, counting wide
+UTF8 bytes as a single character.
+
+=cut
+*/
+
STRLEN
Perl_sv_len_utf8(pTHX_ register SV *sv)
{
}
if (s != send) {
dTHR;
- if (ckWARN_d(WARN_UTF8))
+ if (ckWARN_d(WARN_UTF8))
Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
--len;
}
*/
I32
-Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
+Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
char *pv1;
STRLEN cur1;
char *pv2;
STRLEN cur2;
+ I32 eq = 0;
+ bool pv1tmp = FALSE;
+ bool pv2tmp = FALSE;
- if (!str1) {
+ if (!sv1) {
pv1 = "";
cur1 = 0;
}
else
- pv1 = SvPV(str1, cur1);
+ pv1 = SvPV(sv1, cur1);
- if (!str2)
- return !cur1;
+ if (!sv2){
+ pv2 = "";
+ cur2 = 0;
+ }
else
- pv2 = SvPV(str2, cur2);
+ pv2 = SvPV(sv2, cur2);
- if (cur1 != cur2)
- return 0;
+ /* do not utf8ize the comparands as a side-effect */
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
+ if (SvUTF8(sv1)) {
+ pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ pv2tmp = TRUE;
+ }
+ else {
+ pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ pv1tmp = TRUE;
+ }
+ }
+
+ if (cur1 == cur2)
+ eq = memEQ(pv1, pv2, cur1);
+
+ if (pv1tmp)
+ Safefree(pv1);
+ if (pv2tmp)
+ Safefree(pv2);
- return memEQ(pv1, pv2, cur1);
+ return eq;
}
/*
*/
I32
-Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
+Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
char *pv1, *pv2;
- I32 retval;
+ I32 cmp;
+ bool pv1tmp = FALSE;
+ bool pv2tmp = FALSE;
- if (str1) {
- pv1 = SvPV(str1, cur1);
- }
- else {
+ if (!sv1) {
+ pv1 = "";
cur1 = 0;
}
+ else
+ pv1 = SvPV(sv1, cur1);
- if (str2) {
- if (SvPOK(str2)) {
- if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
- /* must upgrade other to UTF8 first */
- if (SvUTF8(str1)) {
- sv_utf8_upgrade(str2);
- }
- else {
- sv_utf8_upgrade(str1);
- /* refresh pointer and length */
- pv1 = SvPVX(str1);
- cur1 = SvCUR(str1);
- }
- }
- pv2 = SvPVX(str2);
- cur2 = SvCUR(str2);
- }
+ if (!sv2){
+ pv2 = "";
+ cur2 = 0;
+ }
+ else
+ pv2 = SvPV(sv2, cur2);
+
+ /* do not utf8ize the comparands as a side-effect */
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (SvUTF8(sv1)) {
+ pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ pv2tmp = TRUE;
+ }
else {
- pv2 = sv_2pv(str2, &cur2);
+ pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ pv1tmp = TRUE;
}
}
- else {
- cur2 = 0;
+
+ if (!cur1) {
+ cmp = cur2 ? -1 : 0;
+ } else if (!cur2) {
+ cmp = 1;
+ } else {
+ I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+
+ if (retval) {
+ cmp = retval < 0 ? -1 : 1;
+ } else if (cur1 == cur2) {
+ cmp = 0;
+ } else {
+ cmp = cur1 < cur2 ? -1 : 1;
+ }
}
- if (!cur1)
- return cur2 ? -1 : 0;
+ if (pv1tmp)
+ Safefree(pv1);
+ if (pv2tmp)
+ Safefree(pv2);
- if (!cur2)
- return 1;
+ return cmp;
+}
- retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+/*
+=for apidoc sv_cmp_locale
- if (retval)
- return retval < 0 ? -1 : 1;
+Compares the strings in two SVs in a locale-aware manner. See
+L</sv_cmp_locale>
- if (cur1 == cur2)
- return 0;
- else
- return cur1 < cur2 ? -1 : 1;
-}
+=cut
+*/
I32
Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
#endif /* USE_LOCALE_COLLATE */
+/*
+=for apidoc sv_gets
+
+Get a line from the filehandle and store it into the SV, optionally
+appending to the currently-stored string.
+
+=cut
+*/
+
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
/* See if we know enough about I/O mechanism to cheat it ! */
/* This used to be #ifdef test - it is made run-time test for ease
- of abstracting out stdio interface. One call should be cheap
+ of abstracting out stdio interface. One call should be cheap
enough here - and may even be a macro allowing compile
time optimization.
*/
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
screamer:
}
}
else {
- Copy(ptr, bp, cnt, char); /* this | eat */
- bp += cnt; /* screams | dust */
+ Copy(ptr, bp, cnt, char); /* this | eat */
+ bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
}
PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
- /* This used to call 'filbuf' in stdio form, but as that behaves like
+ /* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
}
}
- if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ if (RsPARA(PL_rs)) { /* have to do this both before and after */
while (i != EOF) { /* to make sure file boundaries work right */
i = PerlIO_getc(fp);
if (i != '\n') {
else {
(void)SvIOK_only(sv);
++SvIVX(sv);
- }
+ }
}
return;
}
/* MKS: The original code here died if letters weren't consecutive.
* at least it didn't have to worry about non-C locales. The
* new code assumes that ('z'-'a')==('Z'-'A'), letters are
- * arranged in order (although not consecutively) and that only
+ * arranged in order (although not consecutively) and that only
* [A-Za-z] are accepted by isALPHA in the C locale.
*/
if (*d != 'z' && *d != 'Z') {
else {
(void)SvIOK_only_UV(sv);
--SvUVX(sv);
- }
+ }
} else {
if (SvIVX(sv) == IV_MIN)
sv_setnv(sv, (NV)IV_MIN - 1.0);
else {
(void)SvIOK_only(sv);
--SvIVX(sv);
- }
+ }
}
return;
}
=for apidoc newSVpvn
Creates a new SV and copies a string into it. The reference count for the
-SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
+SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
C<len> bytes long.
return sv;
}
+/*
+=for apidoc newSVpvn_share
+
+Creates a new SV and populates it with a string from
+the string table. Turns on READONLY and FAKE.
+The idea here is that as string table is used for shared hash
+keys these strings will have SvPVX == HeKEY and hash lookup
+will avoid string compare.
+
+=cut
+*/
+
+SV *
+Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
+{
+ register SV *sv;
+ if (!hash)
+ PERL_HASH(hash, src, len);
+ new_SV(sv);
+ sv_upgrade(sv, SVt_PVIV);
+ SvPVX(sv) = sharepvn(src, len, hash);
+ SvCUR(sv) = len;
+ SvUVX(sv) = hash;
+ SvLEN(sv) = 0;
+ SvREADONLY_on(sv);
+ SvFAKE_on(sv);
+ SvPOK_on(sv);
+ return sv;
+}
+
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_newSVpvf_nocontext(const char* pat, ...)
}
}
+/*
+=for apidoc sv_true
+
+Returns true if the SV has a true value by Perl's rules.
+
+=cut
+*/
+
I32
Perl_sv_true(pTHX_ register SV *sv)
{
return sv_2pv(sv, lp);
}
+/*
+=for apidoc sv_pvn_force
+
+Get a sensible string out of the SV somehow.
+
+=cut
+*/
+
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal(sv);
-
+
if (SvPOK(sv)) {
*lp = SvCUR(sv);
}
s = sv_2pv(sv, lp);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
-
+
if (SvROK(sv))
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
return sv_pvn(sv,lp);
}
+/*
+=for apidoc sv_pvutf8n_force
+
+Get a sensible UTF8-encoded string out of the SV somehow. See
+L</sv_pvn_force>.
+
+=cut
+*/
+
char *
Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
{
return sv_pvn_force(sv,lp);
}
+/*
+=for apidoc sv_reftype
+
+Returns a string describing what the SV is a reference to.
+
+=cut
+*/
+
char *
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
SV_CHECK_THINKFIRST(rv);
SvAMAGIC_off(rv);
+ if (SvTYPE(rv) >= SVt_PVMG) {
+ U32 refcnt = SvREFCNT(rv);
+ SvREFCNT(rv) = 0;
+ sv_clear(rv);
+ SvFLAGS(rv) = 0;
+ SvREFCNT(rv) = refcnt;
+ }
+
if (SvTYPE(rv) < SVt_RV)
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_RV);
+ else if (SvTYPE(rv) > SVt_RV) {
+ (void)SvOOK_off(rv);
+ if (SvPVX(rv) && SvLEN(rv))
+ Safefree(SvPVX(rv));
+ SvCUR_set(rv, 0);
+ SvLEN_set(rv, 0);
+ }
(void)SvOK_off(rv);
SvRV(rv) = sv;
case 'v':
vectorize = TRUE;
q++;
- if (args)
- vecsv = va_arg(*args, SV*);
- else if (svix < svmax)
- vecsv = svargs[svix++];
- else {
- vecstr = (U8*)"";
- veclen = 0;
- continue;
- }
- vecstr = (U8*)SvPVx(vecsv,veclen);
- utf = DO_UTF8(vecsv);
continue;
default:
has_precis = TRUE;
}
+ if (vectorize) {
+ if (args) {
+ vecsv = va_arg(*args, SV*);
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ utf = DO_UTF8(vecsv);
+ }
+ else if (svix < svmax) {
+ vecsv = svargs[svix++];
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ utf = DO_UTF8(vecsv);
+ }
+ else {
+ vecstr = (U8*)"";
+ veclen = 0;
+ }
+ }
+
/* SIZE */
switch (*q) {
-#ifdef HAS_QUAD
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
case 'L': /* Ld */
+ /* FALL THROUGH */
+#endif
+#ifdef HAS_QUAD
case 'q': /* qd */
intsize = 'q';
q++;
break;
#endif
case 'l':
-#ifdef HAS_QUAD
- if (*(q + 1) == 'l') { /* lld */
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+ if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
break;
/* INTEGERS */
case 'p':
+ if (alt)
+ goto unknown;
if (args)
uv = PTR2UV(va_arg(*args, void*));
else
iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': iv = (short)iv; break;
- default: iv = (int)iv; break;
+ default: break;
case 'l': iv = (long)iv; break;
case 'V': break;
#ifdef HAS_QUAD
uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': uv = (unsigned short)uv; break;
- default: uv = (unsigned)uv; break;
+ default: break;
case 'l': uv = (unsigned long)uv; break;
case 'V': break;
#ifdef HAS_QUAD
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
-#ifdef USE_LONG_DOUBLE
+#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
{
- static char const my_prifldbl[] = PERL_PRIfldbl;
- char const *p = my_prifldbl + sizeof my_prifldbl - 3;
- while (p >= my_prifldbl) { *--eptr = *p--; }
+ /* Copy the one or more characters in a long double
+ * format before the 'base' ([efgEFG]) character to
+ * the format string. */
+ static char const prifldbl[] = PERL_PRIfldbl;
+ char const *p = prifldbl + sizeof(prifldbl) - 3;
+ while (p >= prifldbl) { *--eptr = *p--; }
}
#endif
if (has_precis) {
*--eptr = '%';
{
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_STANDARD_SET_LOCAL();
+#ifdef USE_LOCALE_NUMERIC
+ if (!was_standard && maybe_tainted)
+ *maybe_tainted = TRUE;
+#endif
(void)sprintf(PL_efloatbuf, eptr, nv);
- RESTORE_NUMERIC_LOCAL();
+ RESTORE_NUMERIC_STANDARD();
}
eptr = PL_efloatbuf;
}
}
else if (svix < svmax)
- sv_setuv(svargs[svix++], (UV)i);
+ sv_setuv_mg(svargs[svix++], (UV)i);
continue; /* not "break" */
/* UNKNOWN */
(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
if (c) {
if (isPRINT(c))
- Perl_sv_catpvf(aTHX_ msg,
+ Perl_sv_catpvf(aTHX_ msg,
"\"%%%c\"", c & 0xFF);
else
Perl_sv_catpvf(aTHX_ msg,
char *c;
void (*dptr) (void*);
void (*dxptr) (pTHXo_ void*);
+ OP *o;
Newz(54, nss, max, ANY);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup_inc(gv);
break;
+ case SAVEt_GENERIC_PVREF: /* generic char* */
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = pv_dup(c);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ break;
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
case OP_LEAVE:
case OP_SCOPE:
case OP_LEAVEWRITE:
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ TOPPTR(nss,ix) = ptr;
+ o = (OP*)ptr;
+ OpREFCNT_inc(o);
break;
default:
TOPPTR(nss,ix) = Nullop;
/* arena roots */
PL_xiv_arenaroot = NULL;
PL_xiv_root = NULL;
+ PL_xnv_arenaroot = NULL;
PL_xnv_root = NULL;
+ PL_xrv_arenaroot = NULL;
PL_xrv_root = NULL;
+ PL_xpv_arenaroot = NULL;
PL_xpv_root = NULL;
+ PL_xpviv_arenaroot = NULL;
PL_xpviv_root = NULL;
+ PL_xpvnv_arenaroot = NULL;
PL_xpvnv_root = NULL;
+ PL_xpvcv_arenaroot = NULL;
PL_xpvcv_root = NULL;
+ PL_xpvav_arenaroot = NULL;
PL_xpvav_root = NULL;
+ PL_xpvhv_arenaroot = NULL;
PL_xpvhv_root = NULL;
+ PL_xpvmg_arenaroot = NULL;
PL_xpvmg_root = NULL;
+ PL_xpvlv_arenaroot = NULL;
PL_xpvlv_root = NULL;
+ PL_xpvbm_arenaroot = NULL;
PL_xpvbm_root = NULL;
+ PL_he_arenaroot = NULL;
PL_he_root = NULL;
PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
- PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
+ PL_eval_root = proto_perl->Ieval_root;
PL_eval_start = proto_perl->Ieval_start;
/* runtime control stuff */
}
else {
init_stacks();
+ ENTER; /* perl_destruct() wants to LEAVE; */
}
PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
- SvROK_off(sv);
- SvRV(sv) = 0;
- SvREFCNT_dec(rv);
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ } else {
+ SvROK_off(sv);
+ SvRV(sv) = 0;
+ SvREFCNT_dec(rv);
+ }
}
/* XXX Might want to check arrays, etc. */
https://perl5.git.perl.org / perl5.git / blobdiff