X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=b21c9edf43c070209978edb30c004e99e1666029;hb=6bc102ca57c5133ccb41282f9b318b89d8ec7a82;hp=889d9f9f4385299f78b215b6a8e02a5e04b62e15;hpb=cea2e8a9dd23747fd2b66edc86c58c64e9970321;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 889d9f9..b21c9ed 100644 --- a/sv.c +++ b/sv.c @@ -15,38 +15,17 @@ #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 */ -#define VTBL *vtbl #define FCALL *f -#endif /* PERL_OBJECT */ - #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) +static void do_report_used(pTHXo_ SV *sv); +static void do_clean_objs(pTHXo_ SV *sv); +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void do_clean_named_objs(pTHXo_ SV *sv); +#endif +static void do_clean_all(pTHXo_ SV *sv); + + #ifdef PURIFY #define new_SV(p) \ @@ -205,7 +184,9 @@ S_del_sv(pTHX_ SV *p) ok = 1; } if (!ok) { - Perl_warn(aTHX_ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, + "Attempt to free non-arena SV: 0x%lx", (unsigned long)p); return; } } @@ -275,87 +256,36 @@ S_visit(pTHX_ SVFUNC_t f) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) - (FCALL)(aTHX_ sv); + (FCALL)(aTHXo_ sv); } } } #endif /* PURIFY */ -STATIC void -S_do_report_used(pTHX_ SV *sv) -{ - if (SvTYPE(sv) != SVTYPEMASK) { - /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ - PerlIO_printf(PerlIO_stderr(), "****\n"); - sv_dump(sv); - } -} - void Perl_sv_report_used(pTHX) { - visit(FUNC_NAME_TO_PTR(S_do_report_used)); + visit(do_report_used); } -STATIC void -S_do_clean_objs(pTHX_ SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -STATIC void -S_do_clean_named_objs(pTHX_ SV *sv) -{ - if (SvTYPE(sv) == SVt_PVGV) { - if ( SvOBJECT(GvSV(sv)) || - GvAV(sv) && SvOBJECT(GvAV(sv)) || - GvHV(sv) && SvOBJECT(GvHV(sv)) || - GvIO(sv) && SvOBJECT(GvIO(sv)) || - GvCV(sv) && SvOBJECT(GvCV(sv)) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) - SvREFCNT_dec(sv); - } - } -} -#endif - void Perl_sv_clean_objs(pTHX) { PL_in_clean_objs = TRUE; - visit(FUNC_NAME_TO_PTR(S_do_clean_objs)); + visit(do_clean_objs); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(FUNC_NAME_TO_PTR(S_do_clean_named_objs)); + visit(do_clean_named_objs); #endif PL_in_clean_objs = FALSE; } -STATIC void -S_do_clean_all(pTHX_ SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); -} - void Perl_sv_clean_all(pTHX) { PL_in_clean_all = TRUE; - visit(FUNC_NAME_TO_PTR(S_do_clean_all)); + visit(do_clean_all); PL_in_clean_all = FALSE; } @@ -435,12 +365,12 @@ S_more_xiv(pTHX) STATIC XPVNV* S_new_xnv(pTHX) { - double* xnv; + NV* xnv; LOCK_SV_MUTEX; if (!PL_xnv_root) more_xnv(); xnv = PL_xnv_root; - PL_xnv_root = *(double**)xnv; + PL_xnv_root = *(NV**)xnv; UNLOCK_SV_MUTEX; return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } @@ -448,9 +378,9 @@ S_new_xnv(pTHX) STATIC void S_del_xnv(pTHX_ XPVNV *p) { - double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); LOCK_SV_MUTEX; - *(double**)xnv = PL_xnv_root; + *(NV**)xnv = PL_xnv_root; PL_xnv_root = xnv; UNLOCK_SV_MUTEX; } @@ -458,17 +388,17 @@ S_del_xnv(pTHX_ XPVNV *p) STATIC void S_more_xnv(pTHX) { - register double* xnv; - register double* xnvend; - New(711, xnv, 1008/sizeof(double), double); - xnvend = &xnv[1008 / sizeof(double) - 1]; - xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ + register NV* xnv; + register NV* xnvend; + New(711, xnv, 1008/sizeof(NV), NV); + xnvend = &xnv[1008 / sizeof(NV) - 1]; + xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ PL_xnv_root = xnv; while (xnv < xnvend) { - *(double**)xnv = (double*)(xnv + 1); + *(NV**)xnv = (NV*)(xnv + 1); xnv++; } - *(double**)xnv = 0; + *(NV**)xnv = 0; } STATIC XRV* @@ -582,7 +512,7 @@ S_more_xpv(pTHX) # define my_safefree(s) safefree(s) #else STATIC void* -S_my_safemalloc(pTHX_ MEM_SIZE size) +S_my_safemalloc(MEM_SIZE size) { char *p; New(717, p, size, char); @@ -631,7 +561,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) U32 cur; U32 len; IV iv; - double nv; + NV nv; MAGIC* magic; HV* stash; @@ -656,7 +586,7 @@ Perl_sv_upgrade(pTHX_ 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; @@ -682,8 +612,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) pv = (char*)SvRV(sv); cur = 0; len = 0; - iv = (IV)pv; - nv = (double)(unsigned long)pv; + iv = (IV)PTR_CAST pv; + nv = (NV)(PTRV)pv; del_XRV(SvANY(sv)); magic = 0; stash = 0; @@ -1017,7 +947,7 @@ Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) } void -Perl_sv_setnv(pTHX_ register SV *sv, double num) +Perl_sv_setnv(pTHX_ register SV *sv, NV num) { SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { @@ -1049,7 +979,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, double num) } void -Perl_sv_setnv_mg(pTHX_ register SV *sv, double num) +Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) { sv_setnv(sv,num); SvSETMAGIC(sv); @@ -1110,7 +1040,7 @@ S_not_a_number(pTHX_ SV *sv) 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() */ @@ -1147,19 +1077,12 @@ Perl_sv_2iv(pTHX_ register SV *sv) SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) return SvIV(tmpstr); - return (IV)SvRV(sv); + return (IV)PTR_CAST SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return I_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } @@ -1174,23 +1097,30 @@ Perl_sv_2iv(pTHX_ 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: +#ifdef IV_IS_QUAD + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n", + (UV)PTR_CAST sv, + (UV)SvUVX(sv), (IV)SvUVX(sv))); +#else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%lu => %ld) (as unsigned)\n", (unsigned long)sv, (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv))); +#endif return (IV)SvUVX(sv); } } @@ -1208,20 +1138,23 @@ Perl_sv_2iv(pTHX_ 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%lx 2nv(%" PERL_PRIgldbl ")\n", + (unsigned long)sv, SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", + (unsigned long)sv, SvNVX(sv))); +#endif + if (SvNVX(sv) < (NV)IV_MAX + 0.5) SvIVX(sv) = I_V(SvNVX(sv)); else { SvUVX(sv) = U_V(SvNVX(sv)); @@ -1235,7 +1168,7 @@ Perl_sv_2iv(pTHX_ 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; @@ -1289,19 +1222,12 @@ Perl_sv_2uv(pTHX_ register SV *sv) SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) return SvUV(tmpstr); - return (UV)SvRV(sv); + return (UV)PTR_CAST SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } @@ -1316,7 +1242,7 @@ Perl_sv_2uv(pTHX_ 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); @@ -1328,10 +1254,17 @@ Perl_sv_2uv(pTHX_ register SV *sv) else { SvIVX(sv) = I_V(SvNVX(sv)); ret_zero: +#ifdef IV_IS_QUAD + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n", + (unsigned long)sv,(long)SvIVX(sv), + (long)(UV)SvIVX(sv))); +#else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%ld => %lu) (as signed)\n", (unsigned long)sv,(long)SvIVX(sv), (long)(UV)SvIVX(sv))); +#endif return (UV)SvIVX(sv); } } @@ -1349,19 +1282,22 @@ Perl_sv_2uv(pTHX_ 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); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2nv(%g)\n",(unsigned long)sv, - SvNVX(sv))); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", + (unsigned long)sv, SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", + (unsigned long)sv, SvNVX(sv))); +#endif if (SvNVX(sv) < -0.5) { SvIVX(sv) = I_V(SvNVX(sv)); goto ret_zero; @@ -1376,7 +1312,7 @@ Perl_sv_2uv(pTHX_ 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, @@ -1386,10 +1322,10 @@ Perl_sv_2uv(pTHX_ 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. */ @@ -1422,7 +1358,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } -double +NV Perl_sv_2nv(pTHX_ register SV *sv) { if (!sv) @@ -1435,14 +1371,13 @@ Perl_sv_2nv(pTHX_ 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)) { @@ -1458,22 +1393,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) return SvNV(tmpstr); - return (double)(unsigned long)SvRV(sv); + return (NV)(PTRV)SvRV(sv); } - if (SvREADONLY(sv)) { + if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; - if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) - not_a_number(sv); - SET_NUMERIC_STANDARD(); - return atof(SvPVX(sv)); - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) - return (double)SvUVX(sv); - else - return (double)SvIVX(sv); - } if (ckWARN(WARN_UNINITIALIZED)) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; @@ -1484,23 +1407,34 @@ Perl_sv_2nv(pTHX_ 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%lx num(%" PERL_PRIgldbl ")\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { - SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv); + SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); - SET_NUMERIC_STANDARD(); - SvNVX(sv) = atof(SvPVX(sv)); + SvNVX(sv) = Atof(SvPVX(sv)); } else { dTHR; @@ -1512,9 +1446,21 @@ Perl_sv_2nv(pTHX_ register SV *sv) return 0.0; } SvNOK_on(sv); - DEBUG_c(SET_NUMERIC_STANDARD()); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif return SvNVX(sv); } @@ -1522,17 +1468,16 @@ STATIC IV 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); } @@ -1543,15 +1488,14 @@ S_asUV(pTHX_ SV *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))); } /* @@ -1570,8 +1514,6 @@ S_asUV(pTHX_ SV *sv) I32 Perl_looks_like_number(pTHX_ SV *sv) { - /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but - * using atof() may lose precision. */ register char *s; register char *send; register char *sbegin; @@ -1601,11 +1543,12 @@ Perl_looks_like_number(pTHX_ 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++; @@ -1616,17 +1559,25 @@ Perl_looks_like_number(pTHX_ 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++; @@ -1716,17 +1667,23 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) *lp = SvCUR(sv); return SvPVX(sv); } - if (SvIOKp(sv)) { /* XXXX 64-bit? */ + if (SvIOKp(sv)) { +#ifdef IV_IS_QUAD + if (SvIsUV(sv)) + (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv)); + else + (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv)); +#else if (SvIsUV(sv)) (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); else (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); +#endif tsv = Nullsv; goto tokensave; } if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); + Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } @@ -1819,43 +1776,29 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); - /* XXXX 64-bit? */ +#ifdef IV_IS_QUAD + Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)PTR_CAST sv); +#else Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv); +#endif goto tokensaveref; } *lp = strlen(s); return s; } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { /* See note in sv_2uv() */ - /* XXXX 64-bit? IV may have better precision... */ - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (SvIOKp(sv)) { - char *ebuf; - - if (SvIsUV(sv)) - tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf); - else - tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf); - *ebuf = 0; - tsv = Nullsv; - goto tokensave; - } - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); *lp = 0; return ""; } } if (SvNOKp(sv)) { /* See note in sv_2uv() */ /* XXXX 64-bit? IV may have better precision... */ + /* I tried changing this for to be 64-bit-aware and + * the t/op/numconvert.t became very, very, angry. + * --jhi Sep 1999 */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvGROW(sv, 28); @@ -1867,8 +1810,7 @@ Perl_sv_2pv(pTHX_ 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 @@ -1883,30 +1825,36 @@ Perl_sv_2pv(pTHX_ 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)) + 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. */ @@ -1916,7 +1864,8 @@ Perl_sv_2pv(pTHX_ 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%lx 2pv(%s)\n", + (unsigned long)sv,SvPVX(sv))); return SvPVX(sv); tokensave: @@ -2769,7 +2718,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(aTHX_ sv, mg); + CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2935,10 +2884,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN void Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { + dTHR; U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); - if (SvREFCNT(nsv) != 1) - Perl_warn(aTHX_ "Reference miscount in sv_replace()"); + if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -3026,7 +2976,7 @@ Perl_sv_clear(pTHX_ 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)); @@ -3155,6 +3105,7 @@ Perl_sv_newref(pTHX_ SV *sv) void Perl_sv_free(pTHX_ SV *sv) { + dTHR; int refcount_is_zero; if (!sv) @@ -3169,7 +3120,8 @@ Perl_sv_free(pTHX_ SV *sv) SvREFCNT(sv) = (~(U32)0)/2; return; } - Perl_warn(aTHX_ "Attempt to free unreferenced scalar"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); return; } ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); @@ -3177,7 +3129,9 @@ Perl_sv_free(pTHX_ SV *sv) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); return; } #endif @@ -3283,7 +3237,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) ++len; } if (s != send) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); --len; } *offsetp = len; @@ -3643,8 +3599,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) { @@ -3727,7 +3691,7 @@ Perl_sv_inc(pTHX_ register SV *sv) IV i; if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; - i = (IV)SvRV(sv); + i = (IV)PTR_CAST SvRV(sv); sv_unref(sv); sv_setiv(sv, i); } @@ -3741,13 +3705,13 @@ Perl_sv_inc(pTHX_ 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); @@ -3766,8 +3730,7 @@ Perl_sv_inc(pTHX_ 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--; @@ -3828,7 +3791,7 @@ Perl_sv_dec(pTHX_ register SV *sv) IV i; if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; - i = (IV)SvRV(sv); + i = (IV)PTR_CAST SvRV(sv); sv_unref(sv); sv_setiv(sv, i); } @@ -3851,7 +3814,7 @@ Perl_sv_dec(pTHX_ 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); @@ -3866,8 +3829,7 @@ Perl_sv_dec(pTHX_ 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 @@ -3947,10 +3909,8 @@ Perl_newSVpvf_nocontext(const char* pat, ...) dTHX; register SV *sv; va_list args; - - new_SV(sv); va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } @@ -3961,16 +3921,23 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) { register SV *sv; va_list args; - - new_SV(sv); va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } SV * -Perl_newSVnv(pTHX_ double n) +Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +{ + register SV *sv; + new_SV(sv); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +SV * +Perl_newSVnv(pTHX_ NV n) { register SV *sv; @@ -4014,12 +3981,14 @@ Perl_newRV(pTHX_ SV *tmpRef) SV * Perl_newSVsv(pTHX_ register SV *old) { + dTHR; register SV *sv; if (!old) return Nullsv; if (SvTYPE(old) == SVTYPEMASK) { - Perl_warn(aTHX_ "semi-panic: attempt to dup freed string"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); return Nullsv; } new_SV(sv); @@ -4042,7 +4011,7 @@ Perl_sv_reset(pTHX_ 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; @@ -4061,11 +4030,11 @@ Perl_sv_reset(pTHX_ 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; } @@ -4262,7 +4231,7 @@ Perl_sv_uv(pTHX_ register SV *sv) return sv_2uv(sv); } -double +NV Perl_sv_nv(pTHX_ register SV *sv) { if (SvNOK(sv)) @@ -4426,7 +4395,7 @@ Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), (IV)pv); + sv_setiv(newSVrv(rv,classname), (IV)PTR_CAST pv); return rv; } @@ -4438,7 +4407,7 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) } SV* -Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv) +Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) { sv_setnv(newSVrv(rv,classname), nv); return rv; @@ -4575,7 +4544,7 @@ 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); } @@ -4586,9 +4555,8 @@ Perl_sv_setpvf_mg_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_mg(sv, pat, &args); va_end(args); - SvSETMAGIC(sv); } #endif @@ -4597,18 +4565,29 @@ 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 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); } @@ -4619,7 +4598,7 @@ Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf(sv, pat, &args); va_end(args); } @@ -4629,9 +4608,8 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf_mg(sv, pat, &args); va_end(args); - SvSETMAGIC(sv); } #endif @@ -4640,29 +4618,41 @@ 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 +Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + +void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf_mg(sv, pat, &args); va_end(args); +} + +void +Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); } void -Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { sv_setpvn(sv, "", 0); - sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); + sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } void -Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { dTHR; char *p; @@ -4716,13 +4706,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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; @@ -4810,15 +4805,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (*q) { case 'l': -#if 0 /* when quads have better support within Perl */ - if (*(q + 1) == 'l') { +#ifdef HAS_QUAD + if (*(q + 1) == 'l') { /* lld */ intsize = 'q'; q += 2; break; - } + } + case 'L': /* Ld */ + case 'q': /* qd */ + intsize = 'q'; + q++; + break; #endif - /* FALL THROUGH */ case 'h': + /* FALL THROUGH */ case 'V': intsize = *q++; break; @@ -4898,14 +4898,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'p': if (args) - uv = (UV)va_arg(*args, void*); + uv = (UV)PTR_CAST va_arg(*args, void*); else - uv = (svix < svmax) ? (UV)svargs[svix++] : 0; + uv = (svix < svmax) ? (UV)PTR_CAST 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': @@ -4915,6 +4919,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: iv = va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; +#ifdef HAS_QUAD + case 'q': iv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4924,6 +4931,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: iv = (int)iv; break; case 'l': iv = (long)iv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': iv = (Quad_t)iv; break; +#endif } } if (iv >= 0) { @@ -4939,7 +4949,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto integer; case 'U': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'u': base = 10; @@ -4950,7 +4964,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto uns_integer; case 'O': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'o': base = 8; @@ -4967,6 +4985,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: uv = va_arg(*args, unsigned); break; case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; +#ifdef HAS_QUAD + case 'q': uv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4976,6 +4997,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: uv = (unsigned)uv; break; case 'l': uv = (unsigned long)uv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': uv = (Quad_t)uv; break; +#endif } } @@ -5013,6 +5037,19 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '0'; 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; @@ -5040,7 +5077,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* 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; @@ -5062,11 +5099,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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); @@ -5086,20 +5130,45 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '#'; *--eptr = '%'; - (void)sprintf(PL_efloatbuf, eptr, nv); + { + RESTORE_NUMERIC_STANDARD(); + (void)sprintf(PL_efloatbuf, eptr, nv); + RESTORE_NUMERIC_LOCAL(); + } eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); -#ifdef LC_NUMERIC +#ifdef USE_LOCALE_NUMERIC /* * User-defined locales may include arbitrary characters. - * And, unfortunately, some system may alloc the "C" locale - * to be overridden by a malicious user. + * And, unfortunately, some (broken) systems may allow the + * "C" locale to be overridden by a malicious user. + * XXX This is an extreme way to cope with broken systems. */ - if (used_locale) - *used_locale = TRUE; -#endif /* LC_NUMERIC */ + if (maybe_tainted && PL_tainting) { + /* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */ + if (*eptr == '-' || *eptr == '+') + ++eptr; + while (isDIGIT(*eptr)) + ++eptr; + if (*eptr == '.') { + ++eptr; + while (isDIGIT(*eptr)) + ++eptr; + } + if (*eptr == 'e' || *eptr == 'E') { + ++eptr; + if (*eptr == '-' || *eptr == '+') + ++eptr; + while (isDIGIT(*eptr)) + ++eptr; + } + if (*eptr) + *maybe_tainted = TRUE; /* results are suspect */ + eptr = PL_efloatbuf; + } +#endif /* USE_LOCALE_NUMERIC */ break; @@ -5113,6 +5182,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; +#ifdef HAS_QUAD + case 'q': *(va_arg(*args, Quad_t*)) = i; break; +#endif } } else if (svix < svmax) @@ -5128,10 +5200,21 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SV *msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); - if (c) - Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", - c & 0xFF); - else + if (c) { +#ifdef UV_IS_QUAD + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03" PERL_PRIo64 "\"", + (UV)c & 0xFF); +#else + Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? + "\"%%%c\"" : "\"%%\\%03o\"", + c & 0xFF); +#endif + } else sv_catpv(msg, "end of string"); Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } @@ -5186,3 +5269,61 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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); +} +