X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=6324ffd54e2abd355dabc5e6f6436deee293761f;hb=d7d93a8159c0ca10065c583e76157a51736a62cd;hp=9cec7879f7081c7747c9fcc9be4ed4b422332a6e;hpb=ba106d47906768b6e657462b9a484fe0c3a0f0d5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 9cec787..6324ffd 100644 --- a/sv.c +++ b/sv.c @@ -12,66 +12,19 @@ */ #include "EXTERN.h" +#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 -#endif -#ifdef I_FLOAT -#include -#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 */ - -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 +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) -#endif /* PERL_OBJECT */ +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); -#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) #ifdef PURIFY @@ -108,7 +61,7 @@ static I32 registry_size; if (++i >= registry_size) \ i = 0; \ if (i == h) \ - die("SV registry bug"); \ + Perl_die(aTHX_ "SV registry bug"); \ } \ registry[i] = (b); \ } STMT_END @@ -117,7 +70,7 @@ static I32 registry_size; #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)) { @@ -144,14 +97,14 @@ reg_add(SV *sv) } 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; @@ -163,7 +116,7 @@ visit(SVFUNC f) } 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); @@ -217,7 +170,7 @@ sv_add_arena(char *ptr, U32 size, U32 flags) } STMT_END STATIC void -del_sv(SV *p) +S_del_sv(pTHX_ SV *p) { if (PL_debug & 32768) { SV* sva; @@ -231,7 +184,10 @@ del_sv(SV *p) 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%"UVxf, + PTR2UV(p)); return; } } @@ -245,7 +201,7 @@ del_sv(SV *p) #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; @@ -273,7 +229,7 @@ sv_add_arena(char *ptr, U32 size, U32 flags) /* sv_mutex must be held while calling more_sv() */ STATIC SV* -more_sv(void) +S_more_sv(pTHX) { register SV* sv; @@ -291,7 +247,7 @@ more_sv(void) } STATIC void -visit(SVFUNC f) +S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; @@ -301,92 +257,41 @@ visit(SVFUNC f) 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) +Perl_sv_report_used(pTHX) { - visit(FUNC_NAME_TO_PTR(do_report_used)); + visit(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) -{ - 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 -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; @@ -412,7 +317,7 @@ sv_free_arenas(void) } STATIC XPVIV* -new_xiv(void) +S_new_xiv(pTHX) { IV* xiv; LOCK_SV_MUTEX; @@ -428,7 +333,7 @@ new_xiv(void) } 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; @@ -438,7 +343,7 @@ del_xiv(XPVIV *p) } STATIC void -more_xiv(void) +S_more_xiv(pTHX) { register IV* xiv; register IV* xivend; @@ -459,46 +364,46 @@ more_xiv(void) } 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; @@ -511,7 +416,7 @@ new_xrv(void) } STATIC void -del_xrv(XRV *p) +S_del_xrv(pTHX_ XRV *p) { LOCK_SV_MUTEX; p->xrv_rv = (SV*)PL_xrv_root; @@ -520,7 +425,7 @@ del_xrv(XRV *p) } STATIC void -more_xrv(void) +S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; @@ -535,7 +440,7 @@ more_xrv(void) } STATIC XPV* -new_xpv(void) +S_new_xpv(pTHX) { XPV* xpv; LOCK_SV_MUTEX; @@ -548,7 +453,7 @@ new_xpv(void) } STATIC void -del_xpv(XPV *p) +S_del_xpv(pTHX_ XPV *p) { LOCK_SV_MUTEX; p->xpv_pv = (char*)PL_xpv_root; @@ -557,7 +462,7 @@ del_xpv(XPV *p) } STATIC void -more_xpv(void) +S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; @@ -571,6 +476,321 @@ more_xpv(void) 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) @@ -608,7 +828,7 @@ more_xpv(void) # 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); @@ -617,32 +837,73 @@ my_safemalloc(MEM_SIZE size) # 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) @@ -651,13 +912,13 @@ my_safemalloc(MEM_SIZE size) #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; @@ -682,7 +943,7 @@ sv_upgrade(register SV *sv, U32 mt) cur = 0; len = 0; iv = SvIVX(sv); - nv = (double)SvIVX(sv); + nv = (NV)SvIVX(sv); del_XIV(SvANY(sv)); magic = 0; stash = 0; @@ -708,8 +969,8 @@ sv_upgrade(register SV *sv, U32 mt) 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; @@ -759,12 +1020,12 @@ sv_upgrade(register SV *sv, U32 mt) 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; @@ -925,7 +1186,7 @@ sv_upgrade(register SV *sv, U32 mt) } int -sv_backoff(register SV *sv) +Perl_sv_backoff(pTHX_ register SV *sv) { assert(SvOOK(sv)); if (SvIVX(sv)) { @@ -940,13 +1201,14 @@ sv_backoff(register SV *sv) } char * -sv_grow(register SV *sv, register STRLEN newlen) +Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); + PerlIO_printf(Perl_debug_log, + "Allocation too large: %"UVxf"\n", (UV)newlen); my_exit(1); } #endif /* HAS_64K_LIMIT */ @@ -988,7 +1250,7 @@ sv_grow(register SV *sv, register STRLEN newlen) } void -sv_setiv(register SV *sv, IV i) +Perl_sv_setiv(pTHX_ register SV *sv, IV i) { SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { @@ -1011,7 +1273,7 @@ sv_setiv(register SV *sv, IV i) 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]); } } @@ -1021,14 +1283,14 @@ sv_setiv(register SV *sv, IV i) } 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); @@ -1036,14 +1298,14 @@ sv_setuv(register SV *sv, UV u) } 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)) { @@ -1065,7 +1327,7 @@ sv_setnv(register SV *sv, double num) 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]); } } @@ -1075,14 +1337,14 @@ sv_setnv(register SV *sv, double num) } 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]; @@ -1130,13 +1392,15 @@ not_a_number(SV *sv) *d = '\0'; if (PL_op) - warner(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 - 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() */ +/* 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() */ @@ -1146,7 +1410,7 @@ not_a_number(SV *sv) 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; @@ -1163,7 +1427,7 @@ sv_2iv(register SV *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; } @@ -1173,19 +1437,12 @@ sv_2iv(register SV *sv) 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)) - 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; } } @@ -1200,23 +1457,24 @@ sv_2iv(register SV *sv) 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: 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))); + "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", + PTR2UV(sv), + SvUVX(sv), + SvUVX(sv))); return (IV)SvUVX(sv); } } @@ -1234,20 +1492,23 @@ sv_2iv(register SV *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%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n", + PTR2UV(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)); @@ -1261,7 +1522,7 @@ sv_2iv(register SV *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; @@ -1277,19 +1538,19 @@ sv_2iv(register SV *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); return 0; } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", - (unsigned long)sv,(long)SvIVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", + PTR2UV(sv),SvIVX(sv))); return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } UV -sv_2uv(register SV *sv) +Perl_sv_2uv(pTHX_ register SV *sv) { if (!sv) return 0; @@ -1305,7 +1566,7 @@ sv_2uv(register SV *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; } @@ -1315,19 +1576,12 @@ sv_2uv(register SV *sv) 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)) - 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; } } @@ -1342,7 +1596,7 @@ sv_2uv(register SV *sv) 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); @@ -1355,9 +1609,10 @@ sv_2uv(register SV *sv) SvIVX(sv) = I_V(SvNVX(sv)); ret_zero: 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))); + "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n", + PTR2UV(sv), + SvIVX(sv), + (IV)(UV)SvIVX(sv))); return (UV)SvIVX(sv); } } @@ -1375,19 +1630,24 @@ sv_2uv(register SV *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); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2nv(%g)\n",(unsigned long)sv, - SvNVX(sv))); + "0x%"UVxf" 2nv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif if (SvNVX(sv) < -0.5) { SvIVX(sv) = I_V(SvNVX(sv)); goto ret_zero; @@ -1402,7 +1662,7 @@ sv_2uv(register SV *sv) 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, @@ -1412,10 +1672,10 @@ sv_2uv(register SV *sv) (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. */ @@ -1435,7 +1695,7 @@ sv_2uv(register SV *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); } if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -1443,13 +1703,13 @@ sv_2uv(register SV *sv) return 0; } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", - (unsigned long)sv,SvUVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", + (UV)sv,SvUVX(sv))); 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; @@ -1461,20 +1721,19 @@ sv_2nv(register SV *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)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } return 0; } @@ -1484,24 +1743,12 @@ sv_2nv(register SV *sv) 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)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; } } @@ -1510,74 +1757,96 @@ sv_2nv(register SV *sv) 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%"UVxf" num(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PTR2UV(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%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PTR2UV(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? */ + 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); } STATIC UV -asUV(SV *sv) +S_asUV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); #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))); } /* @@ -1594,10 +1863,8 @@ asUV(SV *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. */ register char *s; register char *send; register char *sbegin; @@ -1627,11 +1894,12 @@ looks_like_number(SV *sv) 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++; @@ -1642,17 +1910,25 @@ looks_like_number(SV *sv) 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++; @@ -1689,14 +1965,14 @@ looks_like_number(SV *sv) } 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; @@ -1724,7 +2000,7 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) } char * -sv_2pv(register SV *sv, STRLEN *lp) +Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { register char *s; int olderrno; @@ -1742,17 +2018,16 @@ sv_2pv(register SV *sv, STRLEN *lp) *lp = SvCUR(sv); return SvPVX(sv); } - if (SvIOKp(sv)) { /* XXXX 64-bit? */ + if (SvIOKp(sv)) { if (SvIsUV(sv)) - (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); + (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)); else - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); + (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); 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; } @@ -1760,7 +2035,7 @@ sv_2pv(register SV *sv, STRLEN *lp) 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 ""; @@ -1842,46 +2117,28 @@ sv_2pv(register SV *sv, STRLEN *lp) } 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%"UVxf")", PTR2UV(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 ""; } } 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); @@ -1893,8 +2150,7 @@ sv_2pv(register SV *sv, STRLEN *lp) else #endif /*apollo*/ { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, s); + Gconvert(SvNVX(sv), NV_DIG, 0, s); } errno = olderrno; #ifdef FIXNEGATIVEZERO @@ -1909,30 +2165,36 @@ sv_2pv(register SV *sv, STRLEN *lp) } 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. */ @@ -1942,7 +2204,8 @@ sv_2pv(register SV *sv, STRLEN *lp) *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%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); return SvPVX(sv); tokensave: @@ -1987,7 +2250,7 @@ sv_2pv(register SV *sv, STRLEN *lp) /* 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); @@ -2029,7 +2292,7 @@ sv_2bool(register SV *sv) */ void -sv_setsv(SV *dstr, register SV *sstr) +Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { dTHR; register U32 sflags; @@ -2132,10 +2395,10 @@ sv_setsv(SV *dstr, register SV *sstr) 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: @@ -2154,7 +2417,7 @@ sv_setsv(SV *dstr, register SV *sstr) /* 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 */ @@ -2250,7 +2513,7 @@ sv_setsv(SV *dstr, register SV *sstr) * 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)) { @@ -2258,7 +2521,7 @@ sv_setsv(SV *dstr, register SV *sstr) && 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)); @@ -2396,7 +2659,7 @@ sv_setsv(SV *dstr, register SV *sstr) 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); @@ -2405,14 +2668,14 @@ sv_setsv(SV *dstr, register SV *sstr) } 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 @@ -2434,14 +2697,14 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) } 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; @@ -2461,14 +2724,14 @@ sv_setpv(register SV *sv, register const char *ptr) } 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); @@ -2489,19 +2752,19 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) } 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); @@ -2510,7 +2773,7 @@ sv_force_normal(register SV *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 */ { @@ -2542,7 +2805,7 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in } 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; @@ -2559,14 +2822,14 @@ sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len) } 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; @@ -2577,14 +2840,14 @@ sv_catsv(SV *dstr, register SV *sstr) } 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; @@ -2604,14 +2867,14 @@ sv_catpv(register SV *sv, register const char *ptr) } 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; @@ -2626,14 +2889,14 @@ newSV(STRLEN len) /* 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))) { @@ -2775,7 +3038,7 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) 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)) @@ -2783,7 +3046,7 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) } int -sv_unmagic(SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *sv, int type) { MAGIC* mg; MAGIC** mgp; @@ -2794,8 +3057,8 @@ sv_unmagic(SV *sv, int type) if (mg->mg_type == type) { MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; - if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(sv, mg); + if (vtbl && vtbl->svt_free) + 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); @@ -2817,17 +3080,17 @@ sv_unmagic(SV *sv, int type) } 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); @@ -2838,7 +3101,7 @@ sv_rvweaken(SV *sv) } STATIC void -sv_add_backref(SV *tsv, SV *sv) +S_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; MAGIC *mg; @@ -2853,7 +3116,7 @@ sv_add_backref(SV *tsv, SV *sv) } STATIC void -sv_del_backref(SV *sv) +S_sv_del_backref(pTHX_ SV *sv) { AV *av; SV **svp; @@ -2861,7 +3124,7 @@ sv_del_backref(SV *sv) 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); @@ -2874,7 +3137,7 @@ sv_del_backref(SV *sv) } 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; @@ -2885,7 +3148,7 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) 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); @@ -2919,7 +3182,7 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) 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) { @@ -2959,12 +3222,13 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN 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); @@ -2985,7 +3249,7 @@ sv_replace(register SV *sv, register SV *nsv) } void -sv_clear(register SV *sv) +Perl_sv_clear(pTHX_ register SV *sv) { HV* stash; assert(sv); @@ -3015,8 +3279,8 @@ sv_clear(register SV *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; @@ -3028,7 +3292,7 @@ sv_clear(register SV *sv) 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; @@ -3052,7 +3316,7 @@ sv_clear(register SV *sv) IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) { - io_close((IO*)sv); + io_close((IO*)sv, FALSE); } if (IoDIRP(sv)) { PerlDir_close(IoDIRP(sv)); @@ -3171,7 +3435,7 @@ sv_clear(register SV *sv) } SV * -sv_newref(SV *sv) +Perl_sv_newref(pTHX_ SV *sv) { if (sv) ATOMIC_INC(SvREFCNT(sv)); @@ -3179,8 +3443,9 @@ sv_newref(SV *sv) } void -sv_free(SV *sv) +Perl_sv_free(pTHX_ SV *sv) { + dTHR; int refcount_is_zero; if (!sv) @@ -3195,7 +3460,8 @@ sv_free(SV *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)); @@ -3203,7 +3469,10 @@ sv_free(SV *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%"UVxf, + PTR2UV(sv)); return; } #endif @@ -3218,7 +3487,7 @@ sv_free(SV *sv) } STRLEN -sv_len(register SV *sv) +Perl_sv_len(pTHX_ register SV *sv) { char *junk; STRLEN len; @@ -3234,7 +3503,7 @@ sv_len(register SV *sv) } STRLEN -sv_len_utf8(register SV *sv) +Perl_sv_len_utf8(pTHX_ register SV *sv) { U8 *s; U8 *send; @@ -3259,7 +3528,7 @@ sv_len_utf8(register SV *sv) } 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; @@ -3290,7 +3559,7 @@ sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) } void -sv_pos_b2u(register SV *sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) { U8 *s; U8 *send; @@ -3301,7 +3570,7 @@ sv_pos_b2u(register SV *sv, I32* offsetp) 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) { @@ -3309,7 +3578,9 @@ sv_pos_b2u(register SV *sv, I32* offsetp) ++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; @@ -3317,7 +3588,7 @@ sv_pos_b2u(register SV *sv, I32* offsetp) } I32 -sv_eq(register SV *str1, register SV *str2) +Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) { char *pv1; STRLEN cur1; @@ -3343,7 +3614,7 @@ sv_eq(register SV *str1, register SV *str2) } 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; @@ -3369,7 +3640,7 @@ sv_cmp(register SV *str1, register SV *str2) } 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 @@ -3424,7 +3695,7 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) * according to the locale settings. */ char * -sv_collxfrm(SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { MAGIC *mg; @@ -3470,7 +3741,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) #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; @@ -3580,11 +3851,11 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: if (cnt > 0) { @@ -3614,24 +3885,25 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) } DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", + PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + 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 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=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + 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 */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; @@ -3655,12 +3927,12 @@ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 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=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + 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 */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -3669,8 +3941,16 @@ thats_really_all_folks: } 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) { @@ -3734,7 +4014,7 @@ screamer2: void -sv_inc(register SV *sv) +Perl_sv_inc(pTHX_ register SV *sv) { register char *d; int flags; @@ -3747,13 +4027,13 @@ sv_inc(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)) { 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); } @@ -3767,13 +4047,13 @@ sv_inc(register SV *sv) 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); @@ -3792,8 +4072,7 @@ sv_inc(register SV *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--; @@ -3836,7 +4115,7 @@ sv_inc(register SV *sv) } void -sv_dec(register SV *sv) +Perl_sv_dec(pTHX_ register SV *sv) { int flags; @@ -3848,13 +4127,13 @@ sv_dec(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)) { 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); } @@ -3877,7 +4156,7 @@ sv_dec(register SV *sv) } } 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); @@ -3892,8 +4171,7 @@ sv_dec(register SV *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 @@ -3902,7 +4180,7 @@ sv_dec(register SV *sv) * permanent location. */ SV * -sv_mortalcopy(SV *oldstr) +Perl_sv_mortalcopy(pTHX_ SV *oldstr) { dTHR; register SV *sv; @@ -3916,7 +4194,7 @@ sv_mortalcopy(SV *oldstr) } SV * -sv_newmortal(void) +Perl_sv_newmortal(pTHX) { dTHR; register SV *sv; @@ -3931,7 +4209,7 @@ sv_newmortal(void) /* same thing without the copying */ SV * -sv_2mortal(register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *sv) { dTHR; if (!sv) @@ -3945,7 +4223,7 @@ sv_2mortal(register SV *sv) } SV * -newSVpv(const char *s, STRLEN len) +Perl_newSVpv(pTHX_ const char *s, STRLEN len) { register SV *sv; @@ -3957,7 +4235,7 @@ newSVpv(const char *s, STRLEN len) } SV * -newSVpvn(const char *s, STRLEN len) +Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { register SV *sv; @@ -3966,22 +4244,42 @@ newSVpvn(const char *s, STRLEN len) 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; @@ -3991,7 +4289,7 @@ newSVnv(double n) } SV * -newSViv(IV i) +Perl_newSViv(pTHX_ IV i) { register SV *sv; @@ -4001,7 +4299,7 @@ newSViv(IV i) } SV * -newRV_noinc(SV *tmpRef) +Perl_newRV_noinc(pTHX_ SV *tmpRef) { dTHR; register SV *sv; @@ -4015,7 +4313,7 @@ newRV_noinc(SV *tmpRef) } SV * -newRV(SV *tmpRef) +Perl_newRV(pTHX_ SV *tmpRef) { return newRV_noinc(SvREFCNT_inc(tmpRef)); } @@ -4023,14 +4321,16 @@ newRV(SV *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); @@ -4045,7 +4345,7 @@ newSVsv(register SV *old) } void -sv_reset(register char *s, HV *stash) +Perl_sv_reset(pTHX_ register char *s, HV *stash) { register HE *entry; register GV *gv; @@ -4053,7 +4353,7 @@ sv_reset(register char *s, HV *stash) register I32 i; register PMOP *pm; register I32 max; - char todo[256]; + char todo[PERL_UCHAR_MAX+1]; if (!stash) return; @@ -4072,11 +4372,11 @@ sv_reset(register char *s, HV *stash) 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; } @@ -4117,7 +4417,7 @@ sv_reset(register char *s, HV *stash) } IO* -sv_2io(SV *sv) +Perl_sv_2io(pTHX_ SV *sv) { IO* io; GV* gv; @@ -4131,11 +4431,11 @@ sv_2io(SV *sv) 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); @@ -4144,14 +4444,14 @@ sv_2io(SV *sv) 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; @@ -4192,7 +4492,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) 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; @@ -4217,14 +4517,14 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) 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) @@ -4252,7 +4552,7 @@ sv_true(register SV *sv) } IV -sv_iv(register SV *sv) +Perl_sv_iv(pTHX_ register SV *sv) { if (SvIOK(sv)) { if (SvIsUV(sv)) @@ -4263,7 +4563,7 @@ sv_iv(register SV *sv) } UV -sv_uv(register SV *sv) +Perl_sv_uv(pTHX_ register SV *sv) { if (SvIOK(sv)) { if (SvIsUV(sv)) @@ -4273,8 +4573,8 @@ sv_uv(register SV *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); @@ -4282,7 +4582,7 @@ sv_nv(register SV *sv) } char * -sv_pv(SV *sv) +Perl_sv_pv(pTHX_ SV *sv) { STRLEN n_a; @@ -4293,7 +4593,7 @@ sv_pv(SV *sv) } char * -sv_pvn(SV *sv, STRLEN *lp) +Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) { if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -4303,7 +4603,7 @@ sv_pvn(SV *sv, STRLEN *lp) } char * -sv_pvn_force(SV *sv, STRLEN *lp) +Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { char *s; @@ -4316,7 +4616,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) 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 @@ -4335,15 +4635,15 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(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%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); } } return SvPVX(sv); } char * -sv_reftype(SV *sv, int ob) +Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) return HvNAME(SvSTASH(sv)); @@ -4374,7 +4674,7 @@ sv_reftype(SV *sv, int ob) } int -sv_isobject(SV *sv) +Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; @@ -4389,7 +4689,7 @@ sv_isobject(SV *sv) } int -sv_isa(SV *sv, const char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *name) { if (!sv) return 0; @@ -4405,7 +4705,7 @@ sv_isa(SV *sv, const char *name) } SV* -newSVrv(SV *rv, const char *classname) +Perl_newSVrv(pTHX_ SV *rv, const char *classname) { dTHR; SV *sv; @@ -4430,49 +4730,49 @@ newSVrv(SV *rv, const char *classname) } 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); SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), (IV)pv); + sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); return rv; } 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; @@ -4494,7 +4794,7 @@ sv_bless(SV *sv, HV *stash) } STATIC void -sv_unglob(SV *sv) +S_sv_unglob(pTHX_ SV *sv) { assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); @@ -4512,7 +4812,7 @@ sv_unglob(SV *sv) } void -sv_unref(SV *sv) +Perl_sv_unref(pTHX_ SV *sv) { SV* rv = SvRV(sv); @@ -4531,13 +4831,13 @@ sv_unref(SV *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'); @@ -4547,7 +4847,7 @@ sv_untaint(SV *sv) } bool -sv_tainted(SV *sv) +Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); @@ -4558,7 +4858,7 @@ sv_tainted(SV *sv) } void -sv_setpviv(SV *sv, IV iv) +Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; @@ -4569,7 +4869,7 @@ sv_setpviv(SV *sv, IV iv) void -sv_setpviv_mg(SV *sv, IV iv) +Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; @@ -4579,54 +4879,122 @@ sv_setpviv_mg(SV *sv, IV iv) SvSETMAGIC(sv); } +#if defined(PERL_IMPLICIT_CONTEXT) void -sv_setpvf(SV *sv, const char* pat, ...) +Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) { + 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); } void -sv_setpvf_mg(SV *sv, const char* pat, ...) +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 +Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + 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); } +#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 *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 -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 *maybe_tainted) { dTHR; char *p; @@ -4680,13 +5048,18 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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; @@ -4773,16 +5146,24 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* SIZE */ switch (*q) { +#ifdef Quad_t + case 'L': /* Ld */ + case 'q': /* qd */ + intsize = 'q'; + q++; + break; +#endif case 'l': -#if 0 /* when quads have better support within Perl */ - if (*(q + 1) == 'l') { +#ifdef Quad_t + if (*(q + 1) == 'l') { /* lld */ intsize = 'q'; q += 2; break; - } + } #endif /* FALL THROUGH */ case 'h': + /* FALL THROUGH */ case 'V': intsize = *q++; break; @@ -4862,14 +5243,18 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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': @@ -4879,6 +5264,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: iv = va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; +#ifdef Quad_t + case 'q': iv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4888,6 +5276,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: iv = (int)iv; break; case 'l': iv = (long)iv; break; case 'V': break; +#ifdef Quad_t + case 'q': iv = (Quad_t)iv; break; +#endif } } if (iv >= 0) { @@ -4903,7 +5294,11 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto integer; case 'U': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'u': base = 10; @@ -4914,7 +5309,11 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto uns_integer; case 'O': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'o': base = 8; @@ -4931,6 +5330,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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 Quad_t + case 'q': uv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4940,6 +5342,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: uv = (unsigned)uv; break; case 'l': uv = (unsigned long)uv; break; case 'V': break; +#ifdef Quad_t + case 'q': uv = (Quad_t)uv; break; +#endif } } @@ -4950,7 +5355,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, case 16: if (!uv) alt = FALSE; - p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); do { dig = uv & 15; *--eptr = p[dig]; @@ -4973,10 +5379,25 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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; @@ -5004,7 +5425,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* 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; @@ -5013,7 +5434,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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); } @@ -5026,11 +5447,18 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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); @@ -5050,21 +5478,14 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, *--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 - /* - * User-defined locales may include arbitrary characters. - * And, unfortunately, some system may alloc the "C" locale - * to be overridden by a malicious user. - */ - if (used_locale) - *used_locale = TRUE; -#endif /* LC_NUMERIC */ - break; /* SPECIAL */ @@ -5077,6 +5498,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; +#ifdef Quad_t + case 'q': *(va_arg(*args, Quad_t*)) = i; break; +#endif } } else if (svix < svmax) @@ -5090,14 +5514,19 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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\"", - c & 0xFF); - else + if (c) { + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03"UVof"\"", + (UV)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 ... */ @@ -5150,3 +5579,60 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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%"UVxf"\n", PTR2UV(sv)) );) + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); +} +