*/
#include "EXTERN.h"
+#define PERL_IN_SV_C
#include "perl.h"
#ifdef OVR_DBL_DIG
#endif
#ifdef PERL_OBJECT
-#define FCALL this->*f
#define VTBL this->*vtbl
-
#else /* !PERL_OBJECT */
-
-static IV asIV (SV* sv);
-static UV asUV (SV* sv);
-static SV *more_sv (void);
-static void more_xiv (void);
-static void more_xnv (void);
-static void more_xpv (void);
-static void more_xrv (void);
-static XPVIV *new_xiv (void);
-static XPVNV *new_xnv (void);
-static XPV *new_xpv (void);
-static XRV *new_xrv (void);
-static void del_xiv (XPVIV* p);
-static void del_xnv (XPVNV* p);
-static void del_xpv (XPV* p);
-static void del_xrv (XRV* p);
-static void sv_unglob (SV* sv);
-static void sv_add_backref (SV *tsv, SV *sv);
-static void sv_del_backref (SV *sv);
-
-#ifndef PURIFY
-static void *my_safemalloc(MEM_SIZE size);
-#endif
-
-typedef void (*SVFUNC) (SV*);
#define VTBL *vtbl
-#define FCALL *f
-
#endif /* PERL_OBJECT */
+#define FCALL *f
#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) \
if (++i >= registry_size) \
i = 0; \
if (i == h) \
- die("SV registry bug"); \
+ Perl_die(aTHX_ "SV registry bug"); \
} \
registry[i] = (b); \
} STMT_END
#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
STATIC void
-reg_add(SV *sv)
+S_reg_add(pTHX_ SV *sv)
{
if (PL_sv_count >= (registry_size >> 1))
{
}
STATIC void
-reg_remove(SV *sv)
+S_reg_remove(pTHX_ SV *sv)
{
REG_REMOVE(sv);
--PL_sv_count;
}
STATIC void
-visit(SVFUNC f)
+S_visit(pTHX_ SVFUNC_t f)
{
I32 i;
}
void
-sv_add_arena(char *ptr, U32 size, U32 flags)
+Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
if (!(flags & SVf_FAKE))
Safefree(ptr);
} STMT_END
STATIC void
-del_sv(SV *p)
+S_del_sv(pTHX_ SV *p)
{
if (PL_debug & 32768) {
SV* sva;
ok = 1;
}
if (!ok) {
- warn("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;
}
}
#endif /* DEBUGGING */
void
-sv_add_arena(char *ptr, U32 size, U32 flags)
+Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
SV* sva = (SV*)ptr;
register SV* sv;
/* sv_mutex must be held while calling more_sv() */
STATIC SV*
-more_sv(void)
+S_more_sv(pTHX)
{
register SV* sv;
}
STATIC void
-visit(SVFUNC f)
+S_visit(pTHX_ SVFUNC_t f)
{
SV* sva;
SV* sv;
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK)
- (FCALL)(sv);
+ (FCALL)(aTHXo_ sv);
}
}
}
#endif /* PURIFY */
-STATIC void
-do_report_used(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
-sv_report_used(void)
-{
- visit(FUNC_NAME_TO_PTR(do_report_used));
-}
-
-STATIC void
-do_clean_objs(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(SV *sv)
+Perl_sv_report_used(pTHX)
{
- 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);
- }
- }
+ visit(do_report_used);
}
-#endif
void
-sv_clean_objs(void)
+Perl_sv_clean_objs(pTHX)
{
PL_in_clean_objs = TRUE;
- visit(FUNC_NAME_TO_PTR(do_clean_objs));
+ visit(do_clean_objs);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
/* some barnacles may yet remain, clinging to typeglobs */
- visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
+ visit(do_clean_named_objs);
#endif
PL_in_clean_objs = FALSE;
}
-STATIC void
-do_clean_all(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
-sv_clean_all(void)
+Perl_sv_clean_all(pTHX)
{
PL_in_clean_all = TRUE;
- visit(FUNC_NAME_TO_PTR(do_clean_all));
+ visit(do_clean_all);
PL_in_clean_all = FALSE;
}
void
-sv_free_arenas(void)
+Perl_sv_free_arenas(pTHX)
{
SV* sva;
SV* svanext;
}
STATIC XPVIV*
-new_xiv(void)
+S_new_xiv(pTHX)
{
IV* xiv;
LOCK_SV_MUTEX;
}
STATIC void
-del_xiv(XPVIV *p)
+S_del_xiv(pTHX_ XPVIV *p)
{
IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
LOCK_SV_MUTEX;
}
STATIC void
-more_xiv(void)
+S_more_xiv(pTHX)
{
register IV* xiv;
register IV* xivend;
}
STATIC XPVNV*
-new_xnv(void)
+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
-del_xnv(XPVNV *p)
+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
-more_xnv(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*
-new_xrv(void)
+S_new_xrv(pTHX)
{
XRV* xrv;
LOCK_SV_MUTEX;
}
STATIC void
-del_xrv(XRV *p)
+S_del_xrv(pTHX_ XRV *p)
{
LOCK_SV_MUTEX;
p->xrv_rv = (SV*)PL_xrv_root;
}
STATIC void
-more_xrv(void)
+S_more_xrv(pTHX)
{
register XRV* xrv;
register XRV* xrvend;
}
STATIC XPV*
-new_xpv(void)
+S_new_xpv(pTHX)
{
XPV* xpv;
LOCK_SV_MUTEX;
}
STATIC void
-del_xpv(XPV *p)
+S_del_xpv(pTHX_ XPV *p)
{
LOCK_SV_MUTEX;
p->xpv_pv = (char*)PL_xpv_root;
}
STATIC void
-more_xpv(void)
+S_more_xpv(pTHX)
{
register XPV* xpv;
register XPV* xpvend;
# define my_safefree(s) safefree(s)
#else
STATIC void*
-my_safemalloc(MEM_SIZE size)
+S_my_safemalloc(MEM_SIZE size)
{
char *p;
New(717, p, size, char);
#define del_XPVIO(p) my_safefree((char*)p)
bool
-sv_upgrade(register SV *sv, U32 mt)
+Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
char* pv;
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;
cur = 0;
len = 0;
iv = (IV)pv;
- nv = (double)(unsigned long)pv;
+ nv = (NV)(unsigned long)pv;
del_XRV(SvANY(sv));
magic = 0;
stash = 0;
del_XPVMG(SvANY(sv));
break;
default:
- croak("Can't upgrade that kind of scalar");
+ Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
}
switch (mt) {
case SVt_NULL:
- croak("Can't upgrade to undef");
+ Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
SvANY(sv) = new_XIV();
SvIVX(sv) = iv;
}
int
-sv_backoff(register SV *sv)
+Perl_sv_backoff(pTHX_ register SV *sv)
{
assert(SvOOK(sv));
if (SvIVX(sv)) {
}
char *
-sv_grow(register SV *sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
{
register char *s;
}
void
-sv_setiv(register SV *sv, IV i)
+Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
SV_CHECK_THINKFIRST(sv);
switch (SvTYPE(sv)) {
case SVt_PVIO:
{
dTHR;
- croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
PL_op_desc[PL_op->op_type]);
}
}
}
void
-sv_setiv_mg(register SV *sv, IV i)
+Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
{
sv_setiv(sv,i);
SvSETMAGIC(sv);
}
void
-sv_setuv(register SV *sv, UV u)
+Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
sv_setiv(sv, 0);
SvIsUV_on(sv);
}
void
-sv_setuv_mg(register SV *sv, UV u)
+Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
sv_setuv(sv,u);
SvSETMAGIC(sv);
}
void
-sv_setnv(register SV *sv, double num)
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
SV_CHECK_THINKFIRST(sv);
switch (SvTYPE(sv)) {
case SVt_PVIO:
{
dTHR;
- croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
+ Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
PL_op_name[PL_op->op_type]);
}
}
}
void
-sv_setnv_mg(register SV *sv, double num)
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
{
sv_setnv(sv,num);
SvSETMAGIC(sv);
}
STATIC void
-not_a_number(SV *sv)
+S_not_a_number(pTHX_ SV *sv)
{
dTHR;
char tmpbuf[64];
*d = '\0';
if (PL_op)
- warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
+ Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
PL_op_name[PL_op->op_type]);
else
- warner(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() */
until proven guilty, assume that things are not that bad... */
IV
-sv_2iv(register SV *sv)
+Perl_sv_2iv(pTHX_ register SV *sv)
{
if (!sv)
return 0;
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
return SvIV(tmpstr);
return (IV)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))
- warner(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;
}
}
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));
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(%Lg)\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));
else {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_IV);
}
UV
-sv_2uv(register SV *sv)
+Perl_sv_2uv(pTHX_ register SV *sv)
{
if (!sv)
return 0;
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
return SvUV(tmpstr);
return (UV)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))
- warner(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 (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)); /* XXXX 64-bit? */
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(%Lg)\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 (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
}
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
-double
-sv_2nv(register SV *sv)
+NV
+Perl_sv_2nv(pTHX_ register SV *sv)
{
if (!sv)
return 0.0;
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)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
return SvNV(tmpstr);
- return (double)(unsigned long)SvRV(sv);
+ return (NV)(unsigned long)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))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ 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(%Lg)\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;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
if (SvTYPE(sv) < SVt_NV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_NV);
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(%Lg)\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);
}
STATIC IV
-asIV(SV *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? */
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- d = atof(SvPVX(sv));
+ d = Atof(SvPVX(sv));
return I_V(d);
}
STATIC UV
-asUV(SV *sv)
+S_asUV(pTHX_ SV *sv)
{
I32 numtype = looks_like_number(sv);
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- SET_NUMERIC_STANDARD();
- return U_V(atof(SvPVX(sv)));
+ return U_V(Atof(SvPVX(sv)));
}
/*
*/
I32
-looks_like_number(SV *sv)
+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. */
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++;
}
char *
-sv_2pv_nolen(register SV *sv)
+Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
STRLEN n_a;
return sv_2pv(sv, &n_a);
}
/* We assume that buf is at least TYPE_CHARS(UV) long. */
-STATIC char *
+static char *
uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
STRLEN len;
}
char *
-sv_2pv(register SV *sv, STRLEN *lp)
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
{
register char *s;
int olderrno;
goto tokensave;
}
if (SvNOKp(sv)) {
- SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
}
*lp = 0;
return "";
}
tsv = NEWSV(0,0);
if (SvOBJECT(sv))
- sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
/* XXXX 64-bit? */
- sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
+ Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
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))
- warner(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 "";
}
else
#endif /*apollo*/
{
- SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, s);
}
errno = olderrno;
}
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))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ 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:
/* This function is only called on magical items */
bool
-sv_2bool(register SV *sv)
+Perl_sv_2bool(pTHX_ register SV *sv)
{
if (SvGMAGICAL(sv))
mg_get(sv);
*/
void
-sv_setsv(SV *dstr, register SV *sstr)
+Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
dTHR;
register U32 sflags;
case SVt_PVCV:
case SVt_PVIO:
if (PL_op)
- croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
+ Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
PL_op_name[PL_op->op_type]);
else
- croak("Bizarre copy of %s", sv_reftype(sstr, 0));
+ Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
break;
case SVt_PVGV:
/* ahem, death to those who redefine active sort subs */
else if (PL_curstackinfo->si_type == PERLSI_SORT
&& GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
- croak("Can't redefine active sort subroutine %s",
+ Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
PL_sortcop == CvSTART(cv))
- croak(
+ Perl_croak(aTHX_
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
- warner(WARN_REDEFINE, const_sv ?
+ Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
"Constant subroutine %s redefined"
: "Subroutine %s redefined",
GvENAME((GV*)dstr));
else {
if (dtype == SVt_PVGV) {
if (ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
}
void
-sv_setsv_mg(SV *dstr, register SV *sstr)
+Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
sv_setsv(dstr,sstr);
SvSETMAGIC(dstr);
}
void
-sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
register char *dptr;
assert(len >= 0); /* STRLEN is probably unsigned, so this may
}
void
-sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
sv_setpvn(sv,ptr,len);
SvSETMAGIC(sv);
}
void
-sv_setpv(register SV *sv, register const char *ptr)
+Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
{
register STRLEN len;
}
void
-sv_setpv_mg(register SV *sv, register const char *ptr)
+Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
sv_setpv(sv,ptr);
SvSETMAGIC(sv);
}
void
-sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
+Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
}
void
-sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
+Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
sv_usepvn(sv,ptr,len);
SvSETMAGIC(sv);
}
void
-sv_force_normal(register SV *sv)
+Perl_sv_force_normal(pTHX_ register SV *sv)
{
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv))
sv_unref(sv);
}
void
-sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
+Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
{
}
void
-sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
STRLEN tlen;
char *junk;
}
void
-sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
sv_catpvn(sv,ptr,len);
SvSETMAGIC(sv);
}
void
-sv_catsv(SV *dstr, register SV *sstr)
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
char *s;
STRLEN len;
}
void
-sv_catsv_mg(SV *dstr, register SV *sstr)
+Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
sv_catsv(dstr,sstr);
SvSETMAGIC(dstr);
}
void
-sv_catpv(register SV *sv, register const char *ptr)
+Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
{
register STRLEN len;
STRLEN tlen;
}
void
-sv_catpv_mg(register SV *sv, register const char *ptr)
+Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
sv_catpv(sv,ptr);
SvSETMAGIC(sv);
}
SV *
-newSV(STRLEN len)
+Perl_newSV(pTHX_ STRLEN len)
{
register SV *sv;
/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
void
-sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+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))
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
}
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
SvRMAGICAL_on(sv);
break;
default:
- croak("Don't know how to handle magic of type '%c'", how);
+ Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
}
mg_magical(sv);
if (SvGMAGICAL(sv))
}
int
-sv_unmagic(SV *sv, int type)
+Perl_sv_unmagic(pTHX_ SV *sv, int type)
{
MAGIC* mg;
MAGIC** mgp;
MGVTBL* vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && (vtbl->svt_free != NULL))
- (VTBL->svt_free)(sv, mg);
+ (VTBL->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
}
SV *
-sv_rvweaken(SV *sv)
+Perl_sv_rvweaken(pTHX_ SV *sv)
{
SV *tsv;
if (!SvOK(sv)) /* let undefs pass */
return sv;
if (!SvROK(sv))
- croak("Can't weaken a nonreference");
+ Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
dTHR;
if (ckWARN(WARN_MISC))
- warner(WARN_MISC, "Reference is already weak");
+ Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
}
STATIC void
-sv_add_backref(SV *tsv, SV *sv)
+S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
}
STATIC void
-sv_del_backref(SV *sv)
+S_sv_del_backref(pTHX_ SV *sv)
{
AV *av;
SV **svp;
SV *tsv = SvRV(sv);
MAGIC *mg;
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
- croak("panic: del_backref");
+ Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
i = AvFILLp(av);
}
void
-sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
+Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
{
register char *big;
register char *mid;
if (!bigstr)
- croak("Can't modify non-existent substring");
+ Perl_croak(aTHX_ "Can't modify non-existent substring");
SvPV_force(bigstr, curlen);
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
bigend = big + SvCUR(bigstr);
if (midend > bigend)
- croak("panic: sv_insert");
+ Perl_croak(aTHX_ "panic: sv_insert");
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
/* make sv point to what nstr did */
void
-sv_replace(register SV *sv, register SV *nsv)
+Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
+ dTHR;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
- if (SvREFCNT(nsv) != 1)
- warn("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);
}
void
-sv_clear(register SV *sv)
+Perl_sv_clear(pTHX_ register SV *sv)
{
HV* stash;
assert(sv);
PUSHMARK(SP);
PUSHs(&tmpref);
PUTBACK;
- perl_call_sv((SV*)GvCV(destructor),
- G_DISCARD|G_EVAL|G_KEEPERR);
+ call_sv((SV*)GvCV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR);
SvREFCNT(sv)--;
POPSTACK;
SPAGAIN;
if (SvREFCNT(sv)) {
if (PL_in_clean_objs)
- croak("DESTROY created new reference to dead object '%s'",
+ Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
HvNAME(stash));
/* DESTROY gave object new lease on life */
return;
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
{
- io_close((IO*)sv);
+ io_close((IO*)sv, FALSE);
}
if (IoDIRP(sv)) {
PerlDir_close(IoDIRP(sv));
}
SV *
-sv_newref(SV *sv)
+Perl_sv_newref(pTHX_ SV *sv)
{
if (sv)
ATOMIC_INC(SvREFCNT(sv));
}
void
-sv_free(SV *sv)
+Perl_sv_free(pTHX_ SV *sv)
{
+ dTHR;
int refcount_is_zero;
if (!sv)
SvREFCNT(sv) = (~(U32)0)/2;
return;
}
- warn("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)) {
- warn("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
}
STRLEN
-sv_len(register SV *sv)
+Perl_sv_len(pTHX_ register SV *sv)
{
char *junk;
STRLEN len;
}
STRLEN
-sv_len_utf8(register SV *sv)
+Perl_sv_len_utf8(pTHX_ register SV *sv)
{
U8 *s;
U8 *send;
}
void
-sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp)
+Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
U8 *start;
U8 *s;
}
void
-sv_pos_b2u(register SV *sv, I32* offsetp)
+Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
{
U8 *s;
U8 *send;
s = (U8*)SvPV(sv, len);
if (len < *offsetp)
- croak("panic: bad byte offset");
+ Perl_croak(aTHX_ "panic: bad byte offset");
send = s + *offsetp;
len = 0;
while (s < send) {
++len;
}
if (s != send) {
- warn("Malformed UTF-8 character");
+ dTHR;
+ if (ckWARN_d(WARN_UTF8))
+ Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
--len;
}
*offsetp = len;
}
I32
-sv_eq(register SV *str1, register SV *str2)
+Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
{
char *pv1;
STRLEN cur1;
}
I32
-sv_cmp(register SV *str1, register SV *str2)
+Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
{
STRLEN cur1 = 0;
char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
}
I32
-sv_cmp_locale(register SV *sv1, register SV *sv2)
+Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
{
#ifdef USE_LOCALE_COLLATE
* according to the locale settings.
*/
char *
-sv_collxfrm(SV *sv, STRLEN *nxp)
+Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
MAGIC *mg;
#endif /* USE_LOCALE_COLLATE */
char *
-sv_gets(register SV *sv, register PerlIO *fp, I32 append)
+Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
dTHR;
char *rsptr;
}
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) {
void
-sv_inc(register SV *sv)
+Perl_sv_inc(pTHX_ register SV *sv)
{
register char *d;
int flags;
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
IV 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--;
}
void
-sv_dec(register SV *sv)
+Perl_sv_dec(pTHX_ register SV *sv)
{
int flags;
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
IV 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
* permanent location. */
SV *
-sv_mortalcopy(SV *oldstr)
+Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
dTHR;
register SV *sv;
}
SV *
-sv_newmortal(void)
+Perl_sv_newmortal(pTHX)
{
dTHR;
register SV *sv;
/* same thing without the copying */
SV *
-sv_2mortal(register SV *sv)
+Perl_sv_2mortal(pTHX_ register SV *sv)
{
dTHR;
if (!sv)
}
SV *
-newSVpv(const char *s, STRLEN len)
+Perl_newSVpv(pTHX_ const char *s, STRLEN len)
{
register SV *sv;
}
SV *
-newSVpvn(const char *s, STRLEN len)
+Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
{
register SV *sv;
return sv;
}
+#if defined(PERL_IMPLICIT_CONTEXT)
SV *
-newSVpvf(const char* pat, ...)
+Perl_newSVpvf_nocontext(const char* pat, ...)
{
+ dTHX;
register SV *sv;
va_list args;
+ va_start(args, pat);
+ sv = vnewSVpvf(pat, &args);
+ va_end(args);
+ return sv;
+}
+#endif
- new_SV(sv);
+SV *
+Perl_newSVpvf(pTHX_ const char* pat, ...)
+{
+ register SV *sv;
+ va_list args;
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_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 *
-newSVnv(double n)
+Perl_newSVnv(pTHX_ NV n)
{
register SV *sv;
}
SV *
-newSViv(IV i)
+Perl_newSViv(pTHX_ IV i)
{
register SV *sv;
}
SV *
-newRV_noinc(SV *tmpRef)
+Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
dTHR;
register SV *sv;
}
SV *
-newRV(SV *tmpRef)
+Perl_newRV(pTHX_ SV *tmpRef)
{
return newRV_noinc(SvREFCNT_inc(tmpRef));
}
/* make an exact duplicate of old */
SV *
-newSVsv(register SV *old)
+Perl_newSVsv(pTHX_ register SV *old)
{
+ dTHR;
register SV *sv;
if (!old)
return Nullsv;
if (SvTYPE(old) == SVTYPEMASK) {
- warn("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);
}
void
-sv_reset(register char *s, HV *stash)
+Perl_sv_reset(pTHX_ register char *s, HV *stash)
{
register HE *entry;
register GV *gv;
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;
}
}
IO*
-sv_2io(SV *sv)
+Perl_sv_2io(pTHX_ SV *sv)
{
IO* io;
GV* gv;
gv = (GV*)sv;
io = GvIO(gv);
if (!io)
- croak("Bad filehandle: %s", GvNAME(gv));
+ Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
break;
default:
if (!SvOK(sv))
- croak(PL_no_usym, "filehandle");
+ Perl_croak(aTHX_ PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
else
io = 0;
if (!io)
- croak("Bad filehandle: %s", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
break;
}
return io;
}
CV *
-sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref)
+Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
GV *gv;
CV *cv;
else if(isGV(sv))
gv = (GV*)sv;
else
- croak("Not a subroutine reference");
+ Perl_croak(aTHX_ "Not a subroutine reference");
}
else if (isGV(sv))
gv = (GV*)sv;
Nullop);
LEAVE;
if (!GvCVu(gv))
- croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
}
return GvCVu(gv);
}
}
I32
-sv_true(register SV *sv)
+Perl_sv_true(pTHX_ register SV *sv)
{
dTHR;
if (!sv)
}
IV
-sv_iv(register SV *sv)
+Perl_sv_iv(pTHX_ register SV *sv)
{
if (SvIOK(sv)) {
if (SvIsUV(sv))
}
UV
-sv_uv(register SV *sv)
+Perl_sv_uv(pTHX_ register SV *sv)
{
if (SvIOK(sv)) {
if (SvIsUV(sv))
return sv_2uv(sv);
}
-double
-sv_nv(register SV *sv)
+NV
+Perl_sv_nv(pTHX_ register SV *sv)
{
if (SvNOK(sv))
return SvNVX(sv);
}
char *
-sv_pv(SV *sv)
+Perl_sv_pv(pTHX_ SV *sv)
{
STRLEN n_a;
}
char *
-sv_pvn(SV *sv, STRLEN *lp)
+Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
if (SvPOK(sv)) {
*lp = SvCUR(sv);
}
char *
-sv_pvn_force(SV *sv, STRLEN *lp)
+Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
char *s;
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
dTHR;
- croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
+ Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
PL_op_name[PL_op->op_type]);
}
else
}
char *
-sv_reftype(SV *sv, int ob)
+Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
if (ob && SvOBJECT(sv))
return HvNAME(SvSTASH(sv));
}
int
-sv_isobject(SV *sv)
+Perl_sv_isobject(pTHX_ SV *sv)
{
if (!sv)
return 0;
}
int
-sv_isa(SV *sv, const char *name)
+Perl_sv_isa(pTHX_ SV *sv, const char *name)
{
if (!sv)
return 0;
}
SV*
-newSVrv(SV *rv, const char *classname)
+Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
dTHR;
SV *sv;
}
SV*
-sv_setref_pv(SV *rv, const char *classname, void *pv)
+Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
}
SV*
-sv_setref_iv(SV *rv, const char *classname, IV iv)
+Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
{
sv_setiv(newSVrv(rv,classname), iv);
return rv;
}
SV*
-sv_setref_nv(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;
}
SV*
-sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n)
+Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
{
sv_setpvn(newSVrv(rv,classname), pv, n);
return rv;
}
SV*
-sv_bless(SV *sv, HV *stash)
+Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
dTHR;
SV *tmpRef;
if (!SvROK(sv))
- croak("Can't bless non-reference value");
+ Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
if (SvREADONLY(tmpRef))
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
}
STATIC void
-sv_unglob(SV *sv)
+S_sv_unglob(pTHX_ SV *sv)
{
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
}
void
-sv_unref(SV *sv)
+Perl_sv_unref(pTHX_ SV *sv)
{
SV* rv = SvRV(sv);
}
void
-sv_taint(SV *sv)
+Perl_sv_taint(pTHX_ SV *sv)
{
sv_magic((sv), Nullsv, 't', Nullch, 0);
}
void
-sv_untaint(SV *sv)
+Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
}
bool
-sv_tainted(SV *sv)
+Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
}
void
-sv_setpviv(SV *sv, IV iv)
+Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
void
-sv_setpviv_mg(SV *sv, IV iv)
+Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
SvSETMAGIC(sv);
}
+#if defined(PERL_IMPLICIT_CONTEXT)
+void
+Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvf(sv, pat, &args);
+ va_end(args);
+}
+
+
+void
+Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvf_mg(sv, pat, &args);
+ va_end(args);
+}
+#endif
+
void
-sv_setpvf(SV *sv, const char* pat, ...)
+Perl_sv_setpvf(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(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
-sv_setpvf_mg(SV *sv, const char* pat, ...)
+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);
}
+#if defined(PERL_IMPLICIT_CONTEXT)
+void
+Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvf(sv, pat, &args);
+ va_end(args);
+}
+
+void
+Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvf_mg(sv, pat, &args);
+ va_end(args);
+}
+#endif
+
void
-sv_catpvf(SV *sv, const char* pat, ...)
+Perl_sv_catpvf(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(sv, pat, &args);
va_end(args);
}
void
-sv_catpvf_mg(SV *sv, const char* pat, ...)
+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
-sv_vsetpvfn(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 *used_locale)
{
sv_setpvn(sv, "", 0);
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
}
void
-sv_vcatpvfn(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 *used_locale)
{
dTHR;
char *p;
unsigned base;
IV iv;
UV uv;
- double nv;
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
/* 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;
i = PERL_INT_MIN;
(void)frexp(nv, &i);
if (i == PERL_INT_MIN)
- die("panic: frexp");
+ Perl_die(aTHX_ "panic: frexp");
if (i > 0)
need = BIT_DIGITS(i);
}
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
+#ifdef USE_LONG_DOUBLE
+ *--eptr = 'L';
+#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);
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
- sv_setpvf(msg, "Invalid conversion in %s: ",
+ Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
if (c)
- sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
+ Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
c & 0xFF);
else
sv_catpv(msg, "end of string");
- warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
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) {
+ /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
+ PerlIO_printf(PerlIO_stderr(), "****\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);
+}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff