#define PERL_IN_SV_C
#include "perl.h"
-#ifdef OVR_DBL_DIG
-/* Use an overridden DBL_DIG */
-# ifdef DBL_DIG
-# undef DBL_DIG
-# endif
-# define DBL_DIG OVR_DBL_DIG
-#else
-/* The following is all to get DBL_DIG, in order to pick a nice
- default value for printing floating point numbers in Gconvert.
- (see config.h)
-*/
-#ifdef I_LIMITS
-#include <limits.h>
-#endif
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifndef HAS_DBL_DIG
-#define DBL_DIG 15 /* A guess that works lots of places */
-#endif
-#endif
-
-#ifdef PERL_OBJECT
-#define FCALL this->*f
-#define VTBL this->*vtbl
-#else /* !PERL_OBJECT */
-#define VTBL *vtbl
#define FCALL *f
-#endif /* PERL_OBJECT */
-
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
+static void do_report_used(pTHXo_ SV *sv);
+static void do_clean_objs(pTHXo_ SV *sv);
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+static void do_clean_named_objs(pTHXo_ SV *sv);
+#endif
+static void do_clean_all(pTHXo_ SV *sv);
+
+
#ifdef PURIFY
#define new_SV(p) \
ok = 1;
}
if (!ok) {
- Perl_warn(aTHX_ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
return;
}
}
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK)
- (FCALL)(aTHX_ sv);
+ (FCALL)(aTHXo_ sv);
}
}
}
#endif /* PURIFY */
-STATIC void
-S_do_report_used(pTHX_ SV *sv)
-{
- if (SvTYPE(sv) != SVTYPEMASK) {
- /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
- PerlIO_printf(PerlIO_stderr(), "****\n");
- sv_dump(sv);
- }
-}
-
void
Perl_sv_report_used(pTHX)
{
- visit(FUNC_NAME_TO_PTR(S_do_report_used));
+ visit(do_report_used);
}
-STATIC void
-S_do_clean_objs(pTHX_ SV *sv)
-{
- SV* rv;
-
- 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);
- }
-
- /* XXX Might want to check arrays, etc. */
-}
-
-#ifndef DISABLE_DESTRUCTOR_KLUDGE
-STATIC void
-S_do_clean_named_objs(pTHX_ SV *sv)
-{
- if (SvTYPE(sv) == SVt_PVGV) {
- if ( SvOBJECT(GvSV(sv)) ||
- GvAV(sv) && SvOBJECT(GvAV(sv)) ||
- GvHV(sv) && SvOBJECT(GvHV(sv)) ||
- GvIO(sv) && SvOBJECT(GvIO(sv)) ||
- GvCV(sv) && SvOBJECT(GvCV(sv)) )
- {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
- SvREFCNT_dec(sv);
- }
- }
-}
-#endif
-
void
Perl_sv_clean_objs(pTHX)
{
PL_in_clean_objs = TRUE;
- visit(FUNC_NAME_TO_PTR(S_do_clean_objs));
+ visit(do_clean_objs);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
/* some barnacles may yet remain, clinging to typeglobs */
- visit(FUNC_NAME_TO_PTR(S_do_clean_named_objs));
+ visit(do_clean_named_objs);
#endif
PL_in_clean_objs = FALSE;
}
-STATIC void
-S_do_clean_all(pTHX_ SV *sv)
-{
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
-}
-
void
Perl_sv_clean_all(pTHX)
{
PL_in_clean_all = TRUE;
- visit(FUNC_NAME_TO_PTR(S_do_clean_all));
+ visit(do_clean_all);
PL_in_clean_all = FALSE;
}
STATIC XPVNV*
S_new_xnv(pTHX)
{
- double* xnv;
+ NV* xnv;
LOCK_SV_MUTEX;
if (!PL_xnv_root)
more_xnv();
xnv = PL_xnv_root;
- PL_xnv_root = *(double**)xnv;
+ PL_xnv_root = *(NV**)xnv;
UNLOCK_SV_MUTEX;
return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
STATIC void
S_del_xnv(pTHX_ XPVNV *p)
{
- double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
LOCK_SV_MUTEX;
- *(double**)xnv = PL_xnv_root;
+ *(NV**)xnv = PL_xnv_root;
PL_xnv_root = xnv;
UNLOCK_SV_MUTEX;
}
STATIC void
S_more_xnv(pTHX)
{
- register double* xnv;
- register double* xnvend;
- New(711, xnv, 1008/sizeof(double), double);
- xnvend = &xnv[1008 / sizeof(double) - 1];
- xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
+ register NV* xnv;
+ register NV* xnvend;
+ New(711, xnv, 1008/sizeof(NV), NV);
+ xnvend = &xnv[1008 / sizeof(NV) - 1];
+ xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
PL_xnv_root = xnv;
while (xnv < xnvend) {
- *(double**)xnv = (double*)(xnv + 1);
+ *(NV**)xnv = (NV*)(xnv + 1);
xnv++;
}
- *(double**)xnv = 0;
+ *(NV**)xnv = 0;
}
STATIC XRV*
xpv->xpv_pv = 0;
}
+STATIC XPVIV*
+S_new_xpviv(pTHX)
+{
+ XPVIV* xpviv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpviv_root)
+ more_xpviv();
+ xpviv = PL_xpviv_root;
+ PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpviv;
+}
+
+STATIC void
+S_del_xpviv(pTHX_ XPVIV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpviv_root;
+ PL_xpviv_root = p;
+ 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;
+ xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
+ while (xpviv < xpvivend) {
+ xpviv->xpv_pv = (char*)(xpviv + 1);
+ xpviv++;
+ }
+ xpviv->xpv_pv = 0;
+}
+
+
+STATIC XPVNV*
+S_new_xpvnv(pTHX)
+{
+ XPVNV* xpvnv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvnv_root)
+ more_xpvnv();
+ xpvnv = PL_xpvnv_root;
+ PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvnv;
+}
+
+STATIC void
+S_del_xpvnv(pTHX_ XPVNV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvnv_root;
+ PL_xpvnv_root = p;
+ 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;
+ xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
+ while (xpvnv < xpvnvend) {
+ xpvnv->xpv_pv = (char*)(xpvnv + 1);
+ xpvnv++;
+ }
+ xpvnv->xpv_pv = 0;
+}
+
+
+
+STATIC XPVCV*
+S_new_xpvcv(pTHX)
+{
+ XPVCV* xpvcv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvcv_root)
+ more_xpvcv();
+ xpvcv = PL_xpvcv_root;
+ PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvcv;
+}
+
+STATIC void
+S_del_xpvcv(pTHX_ XPVCV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvcv_root;
+ PL_xpvcv_root = p;
+ 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;
+ xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
+ while (xpvcv < xpvcvend) {
+ xpvcv->xpv_pv = (char*)(xpvcv + 1);
+ xpvcv++;
+ }
+ xpvcv->xpv_pv = 0;
+}
+
+
+
+STATIC XPVAV*
+S_new_xpvav(pTHX)
+{
+ XPVAV* xpvav;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvav_root)
+ more_xpvav();
+ xpvav = PL_xpvav_root;
+ PL_xpvav_root = (XPVAV*)xpvav->xav_array;
+ UNLOCK_SV_MUTEX;
+ return xpvav;
+}
+
+STATIC void
+S_del_xpvav(pTHX_ XPVAV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xav_array = (char*)PL_xpvav_root;
+ PL_xpvav_root = p;
+ 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;
+ xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
+ while (xpvav < xpvavend) {
+ xpvav->xav_array = (char*)(xpvav + 1);
+ xpvav++;
+ }
+ xpvav->xav_array = 0;
+}
+
+
+
+STATIC XPVHV*
+S_new_xpvhv(pTHX)
+{
+ XPVHV* xpvhv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvhv_root)
+ more_xpvhv();
+ xpvhv = PL_xpvhv_root;
+ PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
+ UNLOCK_SV_MUTEX;
+ return xpvhv;
+}
+
+STATIC void
+S_del_xpvhv(pTHX_ XPVHV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xhv_array = (char*)PL_xpvhv_root;
+ PL_xpvhv_root = p;
+ 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;
+ xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
+ while (xpvhv < xpvhvend) {
+ xpvhv->xhv_array = (char*)(xpvhv + 1);
+ xpvhv++;
+ }
+ xpvhv->xhv_array = 0;
+}
+
+
+STATIC XPVMG*
+S_new_xpvmg(pTHX)
+{
+ XPVMG* xpvmg;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvmg_root)
+ more_xpvmg();
+ xpvmg = PL_xpvmg_root;
+ PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvmg;
+}
+
+STATIC void
+S_del_xpvmg(pTHX_ XPVMG *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvmg_root;
+ PL_xpvmg_root = p;
+ 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;
+ xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
+ while (xpvmg < xpvmgend) {
+ xpvmg->xpv_pv = (char*)(xpvmg + 1);
+ xpvmg++;
+ }
+ xpvmg->xpv_pv = 0;
+}
+
+
+
+STATIC XPVLV*
+S_new_xpvlv(pTHX)
+{
+ XPVLV* xpvlv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvlv_root)
+ more_xpvlv();
+ xpvlv = PL_xpvlv_root;
+ PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvlv;
+}
+
+STATIC void
+S_del_xpvlv(pTHX_ XPVLV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvlv_root;
+ PL_xpvlv_root = p;
+ 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;
+ xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
+ while (xpvlv < xpvlvend) {
+ xpvlv->xpv_pv = (char*)(xpvlv + 1);
+ xpvlv++;
+ }
+ xpvlv->xpv_pv = 0;
+}
+
+
+STATIC XPVBM*
+S_new_xpvbm(pTHX)
+{
+ XPVBM* xpvbm;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvbm_root)
+ more_xpvbm();
+ xpvbm = PL_xpvbm_root;
+ PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvbm;
+}
+
+STATIC void
+S_del_xpvbm(pTHX_ XPVBM *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvbm_root;
+ PL_xpvbm_root = p;
+ 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;
+ xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
+ while (xpvbm < xpvbmend) {
+ xpvbm->xpv_pv = (char*)(xpvbm + 1);
+ xpvbm++;
+ }
+ xpvbm->xpv_pv = 0;
+}
+
#ifdef PURIFY
#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
#define del_XIV(p) Safefree((char*)p)
# define my_safefree(s) Safefree(s)
#endif
-#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) my_safefree((char*)p)
-
-#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) my_safefree((char*)p)
-
-#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) my_safefree((char*)p)
-
-#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) my_safefree((char*)p)
+#ifdef PURIFY
+#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
+#define del_XPVIV(p) Safefree((char*)p)
+#else
+#define new_XPVIV() (void*)new_xpviv()
+#define del_XPVIV(p) del_xpviv((XPVIV *)p)
+#endif
-#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) my_safefree((char*)p)
+#ifdef PURIFY
+#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) Safefree((char*)p)
+#else
+#define new_XPVNV() (void*)new_xpvnv()
+#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
+#endif
+
+
+#ifdef PURIFY
+#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
+#define del_XPVCV(p) Safefree((char*)p)
+#else
+#define new_XPVCV() (void*)new_xpvcv()
+#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
+#endif
+
+#ifdef PURIFY
+#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) Safefree((char*)p)
+#else
+#define new_XPVAV() (void*)new_xpvav()
+#define del_XPVAV(p) del_xpvav((XPVAV *)p)
+#endif
+
+#ifdef PURIFY
+#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) Safefree((char*)p)
+#else
+#define new_XPVHV() (void*)new_xpvhv()
+#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
+#endif
-#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) my_safefree((char*)p)
+#ifdef PURIFY
+#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) Safefree((char*)p)
+#else
+#define new_XPVMG() (void*)new_xpvmg()
+#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+#endif
-#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
-#define del_XPVCV(p) my_safefree((char*)p)
+#ifdef PURIFY
+#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
+#define del_XPVLV(p) Safefree((char*)p)
+#else
+#define new_XPVLV() (void*)new_xpvlv()
+#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
+#endif
#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
#define del_XPVGV(p) my_safefree((char*)p)
-#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) my_safefree((char*)p)
+#ifdef PURIFY
+#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
+#define del_XPVBM(p) Safefree((char*)p)
+#else
+#define new_XPVBM() (void*)new_xpvbm()
+#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
+#endif
#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree((char*)p)
U32 cur;
U32 len;
IV iv;
- double nv;
+ NV nv;
MAGIC* magic;
HV* stash;
cur = 0;
len = 0;
iv = SvIVX(sv);
- nv = (double)SvIVX(sv);
+ nv = (NV)SvIVX(sv);
del_XIV(SvANY(sv));
magic = 0;
stash = 0;
pv = (char*)SvRV(sv);
cur = 0;
len = 0;
- iv = (IV)pv;
- nv = (double)(unsigned long)pv;
+ iv = PTR2IV(pv);
+ nv = PTR2NV(pv);
del_XRV(SvANY(sv));
magic = 0;
stash = 0;
}
void
-Perl_sv_setnv(pTHX_ register SV *sv, double num)
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
SV_CHECK_THINKFIRST(sv);
switch (SvTYPE(sv)) {
}
void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, double num)
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
{
sv_setnv(sv,num);
SvSETMAGIC(sv);
*d = '\0';
if (PL_op)
- Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
- PL_op_name[PL_op->op_type]);
+ Perl_warner(aTHX_ WARN_NUMERIC,
+ "Argument \"%s\" isn't numeric in %s", tmpbuf,
+ PL_op_desc[PL_op->op_type]);
else
- Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
+ Perl_warner(aTHX_ WARN_NUMERIC,
+ "Argument \"%s\" isn't numeric", tmpbuf);
}
-/* the number can be converted to _integer_ with atol() */
+/* the number can be converted to integer with atol() or atoll() */
#define IS_NUMBER_TO_INT_BY_ATOL 0x01
#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
return SvIV(tmpstr);
- return (IV)SvRV(sv);
+ return PTR2IV(SvRV(sv));
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
- return I_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv))
- return asIV(sv);
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0;
}
}
if (SvNOKp(sv)) {
/* We can cache the IV/UV value even if it not good enough
* to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV. XXXX 64-bit?
+ * NV over IV/UV.
*/
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
(void)SvIOK_on(sv);
- if (SvNVX(sv) < (double)IV_MAX + 0.5)
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5)
SvIVX(sv) = I_V(SvNVX(sv));
else {
SvUVX(sv) = U_V(SvNVX(sv));
SvIsUV_on(sv);
ret_iv_max:
+#ifdef IV_IS_QUAD
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
+ PTR2UV(sv),
+ (UV)SvUVX(sv), (IV)SvUVX(sv)));
+#else
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%lx 2iv(%lu => %ld) (as unsigned)\n",
(unsigned long)sv,
(unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
+#endif
return (IV)SvUVX(sv);
}
}
if (numtype & IS_NUMBER_NOT_IV) {
/* May be not an integer. Need to cache NV if we cache IV
* - otherwise future conversion to NV will be wrong. */
- double d;
+ NV d;
- SET_NUMERIC_STANDARD();
- d = atof(SvPVX(sv));
+ d = Atof(SvPVX(sv));
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNVX(sv) = d;
(void)SvNOK_on(sv);
(void)SvIOK_on(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%lx 2nv(%g)\n",(unsigned long)sv,
- SvNVX(sv)));
- if (SvNVX(sv) < (double)IV_MAX + 0.5)
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
+ (unsigned long)sv, SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+ (unsigned long)sv, SvNVX(sv)));
+#endif
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5)
SvIVX(sv) = I_V(SvNVX(sv));
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (SvTYPE(sv) == SVt_PV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
+ SvIVX(sv) = Atol(SvPVX(sv));
}
else { /* Not a number. Cache 0. */
dTHR;
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
return SvUV(tmpstr);
- return (UV)SvRV(sv);
+ return PTR2UV(SvRV(sv));
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
- return U_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv))
- return asUV(sv);
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0;
}
}
if (SvNOKp(sv)) {
/* We can cache the IV/UV value even if it not good enough
* to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV. XXXX 64-bit?
+ * NV over IV/UV.
*/
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
else {
SvIVX(sv) = I_V(SvNVX(sv));
ret_zero:
+#ifdef IV_IS_QUAD
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
+ (unsigned long)sv,(long)SvIVX(sv),
+ (long)(UV)SvIVX(sv)));
+#else
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%lx 2uv(%ld => %lu) (as signed)\n",
(unsigned long)sv,(long)SvIVX(sv),
(long)(UV)SvIVX(sv)));
+#endif
return (UV)SvIVX(sv);
}
}
if (numtype & IS_NUMBER_NOT_IV) {
/* May be not an integer. Need to cache NV if we cache IV
* - otherwise future conversion to NV will be wrong. */
- double d;
+ NV d;
- SET_NUMERIC_STANDARD();
- d = atof(SvPVX(sv)); /* XXXX 64-bit? */
+ d = Atof(SvPVX(sv));
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNVX(sv) = d;
(void)SvNOK_on(sv);
(void)SvIOK_on(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%lx 2nv(%g)\n",(unsigned long)sv,
- SvNVX(sv)));
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
+ (unsigned long)sv, SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+ (unsigned long)sv, SvNVX(sv)));
+#endif
if (SvNVX(sv) < -0.5) {
SvIVX(sv) = I_V(SvNVX(sv));
goto ret_zero;
if (SvTYPE(sv) == SVt_PV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+ SvIVX(sv) = (IV)Atol(SvPVX(sv));
}
else if (numtype) { /* Non-negative */
/* The NV may be reconstructed from UV - safe to cache UV,
(void)SvIOK_on(sv);
(void)SvIsUV_on(sv);
#ifdef HAS_STRTOUL
- SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
+ SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
#else /* no atou(), but we know the number fits into IV... */
/* The only problem may be if it is negative... */
- SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+ SvUVX(sv) = (UV)Atol(SvPVX(sv));
#endif
}
else { /* Not a number. Cache 0. */
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
-double
+NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
if (!sv)
dTHR;
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- SET_NUMERIC_STANDARD();
- return atof(SvPVX(sv));
+ return Atof(SvPVX(sv));
}
if (SvIOKp(sv)) {
if (SvIsUV(sv))
- return (double)SvUVX(sv);
+ return (NV)SvUVX(sv);
else
- return (double)SvIVX(sv);
+ return (NV)SvIVX(sv);
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
return SvNV(tmpstr);
- return (double)(unsigned long)SvRV(sv);
+ return PTR2NV(SvRV(sv));
}
- if (SvREADONLY(sv)) {
+ if (SvREADONLY(sv) && !SvOK(sv)) {
dTHR;
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
- not_a_number(sv);
- SET_NUMERIC_STANDARD();
- return atof(SvPVX(sv));
- }
- if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- return (double)SvUVX(sv);
- else
- return (double)SvIVX(sv);
- }
if (ckWARN(WARN_UNINITIALIZED))
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0.0;
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
- DEBUG_c(SET_NUMERIC_STANDARD());
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c({
+ RESTORE_NUMERIC_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
+ (unsigned long)sv, SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#else
+ DEBUG_c({
+ RESTORE_NUMERIC_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
+ (unsigned long)sv, SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#endif
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
if (SvIOKp(sv) &&
(!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
- SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
+ SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
dTHR;
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- SET_NUMERIC_STANDARD();
- SvNVX(sv) = atof(SvPVX(sv));
+ SvNVX(sv) = Atof(SvPVX(sv));
}
else {
dTHR;
return 0.0;
}
SvNOK_on(sv);
- DEBUG_c(SET_NUMERIC_STANDARD());
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c({
+ RESTORE_NUMERIC_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
+ (unsigned long)sv, SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#else
+ DEBUG_c({
+ RESTORE_NUMERIC_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
+ (unsigned long)sv, SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#endif
return SvNVX(sv);
}
S_asIV(pTHX_ SV *sv)
{
I32 numtype = looks_like_number(sv);
- double d;
+ NV d;
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return atol(SvPVX(sv)); /* XXXX 64-bit? */
+ return Atol(SvPVX(sv));
if (!numtype) {
dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- d = atof(SvPVX(sv));
+ d = Atof(SvPVX(sv));
return I_V(d);
}
#ifdef HAS_STRTOUL
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return strtoul(SvPVX(sv), Null(char**), 10);
+ return Strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- return U_V(atof(SvPVX(sv)));
+ return U_V(Atof(SvPVX(sv)));
}
/*
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
- /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
- * using atof() may lose precision. */
register char *s;
register char *send;
register char *sbegin;
nbegin = s;
/*
- * we return 1 if the number can be converted to _integer_ with atol()
- * and 2 if you need (int)atof().
+ * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
+ * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
+ * (int)atof().
*/
- /* next must be digit or '.' */
+ /* next must be digit or the radix separator */
if (isDIGIT(*s)) {
do {
s++;
else
numtype |= IS_NUMBER_TO_INT_BY_ATOL;
- if (*s == '.') {
+ if (*s == '.'
+#ifdef USE_LOCALE_NUMERIC
+ || IS_NUMERIC_RADIX(*s)
+#endif
+ ) {
s++;
numtype |= IS_NUMBER_NOT_IV;
- while (isDIGIT(*s)) /* optional digits after "." */
+ while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
}
- else if (*s == '.') {
+ else if (*s == '.'
+#ifdef USE_LOCALE_NUMERIC
+ || IS_NUMERIC_RADIX(*s)
+#endif
+ ) {
s++;
numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
- /* no digits before '.' means we need digits after it */
+ /* no digits before the radix means we need digits after it */
if (isDIGIT(*s)) {
do {
s++;
*lp = SvCUR(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) { /* XXXX 64-bit? */
+ if (SvIOKp(sv)) {
+#ifdef IV_IS_QUAD
+ if (SvIsUV(sv))
+ (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
+ else
+ (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
+#else
if (SvIsUV(sv))
(void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
else
(void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+#endif
tsv = Nullsv;
goto tokensave;
}
if (SvNOKp(sv)) {
- SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
+ Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
- /* XXXX 64-bit? */
+#ifdef IV_IS_QUAD
+ Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", PTR2UV(sv));
+#else
Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
+#endif
goto tokensaveref;
}
*lp = strlen(s);
return s;
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) { /* See note in sv_2uv() */
- /* XXXX 64-bit? IV may have better precision... */
- SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
- tsv = Nullsv;
- goto tokensave;
- }
- if (SvIOKp(sv)) {
- char *ebuf;
-
- if (SvIsUV(sv))
- tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
- else
- tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
- *ebuf = 0;
- tsv = Nullsv;
- goto tokensave;
- }
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
*lp = 0;
return "";
}
}
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
+ * 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);
else
#endif /*apollo*/
{
- SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, s);
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
}
errno = olderrno;
#ifdef FIXNEGATIVEZERO
}
else if (SvIOKp(sv)) {
U32 isIOK = SvIOK(sv);
+ U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- if (SvIsUV(sv)) {
+ if (isUIOK)
ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
- sv_setpvn(sv, ptr, ebuf - ptr);
- SvIsUV_on(sv);
- }
- else {
+ else
ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- sv_setpvn(sv, ptr, ebuf - ptr);
- }
+ SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ Move(ptr,SvPVX(sv),ebuf - ptr,char);
+ SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
+ *s = '\0';
if (isIOK)
SvIOK_on(sv);
else
SvIOKp_on(sv);
+ if (isUIOK)
+ SvIsUV_on(sv);
+ SvPOK_on(sv);
}
else {
dTHR;
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ if (ckWARN(WARN_UNINITIALIZED)
+ && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ {
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ }
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
+ (unsigned long)sv,SvPVX(sv)));
return SvPVX(sv);
tokensave:
MGVTBL* vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && (vtbl->svt_free != NULL))
- (VTBL->svt_free)(aTHX_ sv, mg);
+ CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
+ dTHR;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
- if (SvREFCNT(nsv) != 1)
- Perl_warn(aTHX_ "Reference miscount in sv_replace()");
+ if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
{
- io_close((IO*)sv);
+ io_close((IO*)sv, FALSE);
}
if (IoDIRP(sv)) {
PerlDir_close(IoDIRP(sv));
void
Perl_sv_free(pTHX_ SV *sv)
{
+ dTHR;
int refcount_is_zero;
if (!sv)
SvREFCNT(sv) = (~(U32)0)/2;
return;
}
- Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
return;
}
ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
return;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
- Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
+ if (ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ WARN_DEBUGGING,
+ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
return;
}
#endif
++len;
}
if (s != send) {
- Perl_warn(aTHX_ "Malformed UTF-8 character");
+ dTHR;
+ if (ckWARN_d(WARN_UTF8))
+ Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
--len;
}
*offsetp = len;
}
else
{
+#ifndef EPOC
/*The big, slow, and stupid way */
STDCHAR buf[8192];
+#else
+ /* Need to work around EPOC SDK features */
+ /* On WINS: MS VC5 generates calls to _chkstk, */
+ /* if a `large' stack frame is allocated */
+ /* gcc on MARM does not generate calls like these */
+ STDCHAR buf[1024];
+#endif
screamer2:
if (rslen) {
IV i;
if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
return;
- i = (IV)SvRV(sv);
+ i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setiv(sv, i);
}
if (flags & SVp_IOK) {
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
- sv_setnv(sv, (double)UV_MAX + 1.0);
+ sv_setnv(sv, (NV)UV_MAX + 1.0);
else
(void)SvIOK_only_UV(sv);
++SvUVX(sv);
} else {
if (SvIVX(sv) == IV_MAX)
- sv_setnv(sv, (double)IV_MAX + 1.0);
+ sv_setnv(sv, (NV)IV_MAX + 1.0);
else {
(void)SvIOK_only(sv);
++SvIVX(sv);
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (*d) {
- SET_NUMERIC_STANDARD();
- sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
+ sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
return;
}
d--;
IV i;
if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
return;
- i = (IV)SvRV(sv);
+ i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setiv(sv, i);
}
}
} else {
if (SvIVX(sv) == IV_MIN)
- sv_setnv(sv, (double)IV_MIN - 1.0);
+ sv_setnv(sv, (NV)IV_MIN - 1.0);
else {
(void)SvIOK_only(sv);
--SvIVX(sv);
(void)SvNOK_only(sv);
return;
}
- SET_NUMERIC_STANDARD();
- sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
+ sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
}
/* Make a string that will exist for the duration of the expression
dTHX;
register SV *sv;
va_list args;
-
- new_SV(sv);
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv = vnewSVpvf(pat, &args);
va_end(args);
return sv;
}
{
register SV *sv;
va_list args;
-
- new_SV(sv);
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv = vnewSVpvf(pat, &args);
va_end(args);
return sv;
}
SV *
-Perl_newSVnv(pTHX_ double n)
+Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
+{
+ register SV *sv;
+ new_SV(sv);
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ return sv;
+}
+
+SV *
+Perl_newSVnv(pTHX_ NV n)
{
register SV *sv;
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
+ dTHR;
register SV *sv;
if (!old)
return Nullsv;
if (SvTYPE(old) == SVTYPEMASK) {
- Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
return Nullsv;
}
new_SV(sv);
register I32 i;
register PMOP *pm;
register I32 max;
- char todo[256];
+ char todo[PERL_UCHAR_MAX+1];
if (!stash)
return;
Zero(todo, 256, char);
while (*s) {
- i = *s;
+ i = (unsigned char)*s;
if (s[1] == '-') {
s += 2;
}
- max = *s++;
+ max = (unsigned char)*s++;
for ( ; i <= max; i++) {
todo[i] = 1;
}
return sv_2uv(sv);
}
-double
+NV
Perl_sv_nv(pTHX_ register SV *sv)
{
if (SvNOK(sv))
SvSETMAGIC(rv);
}
else
- sv_setiv(newSVrv(rv,classname), (IV)pv);
+ sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
return rv;
}
}
SV*
-Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
+Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
{
sv_setnv(newSVrv(rv,classname), nv);
return rv;
dTHX;
va_list args;
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvf(sv, pat, &args);
va_end(args);
}
dTHX;
va_list args;
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
- SvSETMAGIC(sv);
}
#endif
{
va_list args;
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvf(sv, pat, &args);
va_end(args);
}
+void
+Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+{
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+}
void
Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
va_start(args, pat);
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
+}
+
+void
+Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+{
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
}
dTHX;
va_list args;
va_start(args, pat);
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvf(sv, pat, &args);
va_end(args);
}
dTHX;
va_list args;
va_start(args, pat);
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
- SvSETMAGIC(sv);
}
#endif
{
va_list args;
va_start(args, pat);
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvf(sv, pat, &args);
va_end(args);
}
void
+Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+{
+ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+}
+
+void
Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
va_list args;
va_start(args, pat);
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
+}
+
+void
+Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+{
+ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
}
void
-Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
sv_setpvn(sv, "", 0);
- sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
void
-Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
dTHR;
char *p;
char *eptr = Nullch;
STRLEN elen = 0;
- char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
+ /* 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 */
char c;
int i;
unsigned base;
IV iv;
UV uv;
- double nv;
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
switch (*q) {
case 'l':
-#if 0 /* when quads have better support within Perl */
- if (*(q + 1) == 'l') {
+#ifdef HAS_QUAD
+ if (*(q + 1) == 'l') { /* lld */
intsize = 'q';
q += 2;
break;
- }
+ }
+ case 'L': /* Ld */
+ case 'q': /* qd */
+ intsize = 'q';
+ q++;
+ break;
#endif
- /* FALL THROUGH */
case 'h':
+ /* FALL THROUGH */
case 'V':
intsize = *q++;
break;
case 'p':
if (args)
- uv = (UV)va_arg(*args, void*);
+ uv = PTR2UV(va_arg(*args, void*));
else
- uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
+ uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
base = 16;
goto integer;
case 'D':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'd':
case 'i':
default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+#ifdef HAS_QUAD
+ case 'q': iv = va_arg(*args, Quad_t); break;
+#endif
}
}
else {
default: iv = (int)iv; break;
case 'l': iv = (long)iv; break;
case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': iv = (Quad_t)iv; break;
+#endif
}
}
if (iv >= 0) {
goto integer;
case 'U':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'u':
base = 10;
goto uns_integer;
case 'O':
+#ifdef IV_IS_QUAD
+ intsize = 'q';
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'o':
base = 8;
default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+#ifdef HAS_QUAD
+ case 'q': uv = va_arg(*args, Quad_t); break;
+#endif
}
}
else {
default: uv = (unsigned)uv; break;
case 'l': uv = (unsigned long)uv; break;
case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': uv = (Quad_t)uv; break;
+#endif
}
}
dig = uv & 1;
*--eptr = '0' + dig;
} while (uv >>= 1);
- if (alt && *eptr != '0')
- *--eptr = '0';
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = 'b';
+ }
break;
default: /* it had better be ten or less */
+#if defined(PERL_Y2KWARN)
+ if (ckWARN(WARN_MISC)) {
+ STRLEN n;
+ char *s = SvPV(sv,n);
+ if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+ && (n == 2 || !isDIGIT(s[n-3])))
+ {
+ Perl_warner(aTHX_ WARN_MISC,
+ "Possible Y2K bug: %%%c %s",
+ c, "format string following '19'");
+ }
+ }
+#endif
do {
dig = uv % base;
*--eptr = '0' + dig;
/* This is evil, but floating point is even more evil */
if (args)
- nv = va_arg(*args, double);
+ nv = va_arg(*args, NV);
else
nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
Safefree(PL_efloatbuf);
PL_efloatsize = need + 20; /* more fudge */
New(906, PL_efloatbuf, PL_efloatsize, char);
+ PL_efloatbuf[0] = '\0';
}
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
+#ifdef USE_LONG_DOUBLE
+ {
+ char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
+ while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
+ }
+#endif
if (has_precis) {
base = precis;
do { *--eptr = '0' + (base % 10); } while (base /= 10);
*--eptr = '#';
*--eptr = '%';
- (void)sprintf(PL_efloatbuf, eptr, nv);
+ {
+ RESTORE_NUMERIC_STANDARD();
+ (void)sprintf(PL_efloatbuf, eptr, nv);
+ RESTORE_NUMERIC_LOCAL();
+ }
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
-#ifdef LC_NUMERIC
+#ifdef USE_LOCALE_NUMERIC
/*
* User-defined locales may include arbitrary characters.
- * And, unfortunately, some system may alloc the "C" locale
- * to be overridden by a malicious user.
+ * And, unfortunately, some (broken) systems may allow the
+ * "C" locale to be overridden by a malicious user.
+ * XXX This is an extreme way to cope with broken systems.
*/
- if (used_locale)
- *used_locale = TRUE;
-#endif /* LC_NUMERIC */
+ if (maybe_tainted && PL_tainting) {
+ /* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */
+ if (*eptr == '-' || *eptr == '+')
+ ++eptr;
+ while (isDIGIT(*eptr))
+ ++eptr;
+ if (*eptr == '.') {
+ ++eptr;
+ while (isDIGIT(*eptr))
+ ++eptr;
+ }
+ if (*eptr == 'e' || *eptr == 'E') {
+ ++eptr;
+ if (*eptr == '-' || *eptr == '+')
+ ++eptr;
+ while (isDIGIT(*eptr))
+ ++eptr;
+ }
+ if (*eptr)
+ *maybe_tainted = TRUE; /* results are suspect */
+ eptr = PL_efloatbuf;
+ }
+#endif /* USE_LOCALE_NUMERIC */
break;
default: *(va_arg(*args, int*)) = i; break;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
+#ifdef HAS_QUAD
+ case 'q': *(va_arg(*args, Quad_t*)) = i; break;
+#endif
}
}
else if (svix < svmax)
SV *msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
- if (c)
- Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
- c & 0xFF);
- else
+ if (c) {
+#ifdef UV_IS_QUAD
+ if (isPRINT(c))
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%%c\"", c & 0xFF);
+ else
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%\\%03" PERL_PRIo64 "\"",
+ (UV)c & 0xFF);
+#else
+ Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
+ "\"%%%c\"" : "\"%%\\%03o\"",
+ c & 0xFF);
+#endif
+ } else
sv_catpv(msg, "end of string");
Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
SvCUR(sv) = p - SvPVX(sv);
}
}
+
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#include "XSUB.h"
+#endif
+
+static void
+do_report_used(pTHXo_ SV *sv)
+{
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ PerlIO_printf(Perl_debug_log, "****\n");
+ sv_dump(sv);
+ }
+}
+
+static void
+do_clean_objs(pTHXo_ SV *sv)
+{
+ SV* rv;
+
+ 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);
+ }
+
+ /* XXX Might want to check arrays, etc. */
+}
+
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+static void
+do_clean_named_objs(pTHXo_ SV *sv)
+{
+ if (SvTYPE(sv) == SVt_PVGV) {
+ if ( SvOBJECT(GvSV(sv)) ||
+ GvAV(sv) && SvOBJECT(GvAV(sv)) ||
+ GvHV(sv) && SvOBJECT(GvHV(sv)) ||
+ GvIO(sv) && SvOBJECT(GvIO(sv)) ||
+ GvCV(sv) && SvOBJECT(GvCV(sv)) )
+ {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
+ SvREFCNT_dec(sv);
+ }
+ }
+}
+#endif
+
+static void
+do_clean_all(pTHXo_ SV *sv)
+{
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
+ SvFLAGS(sv) |= SVf_BREAK;
+ SvREFCNT_dec(sv);
+}
+
https://perl5.git.perl.org / perl5.git / blobdiff