X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=4bdf847c735fd135cd516e9719e6692e496f5038;hb=ef0a8c2a9e34cffb618d4fd6e7676362dedc9421;hp=be8870f48ab676fabe04dfc81ce17296a4e25607;hpb=86058a2d0cb92466b4e8a316b21562a79c7559b9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index be8870f..4bdf847 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -12,6 +12,7 @@ */ #include "EXTERN.h" +#define PERL_IN_SV_C #include "perl.h" #ifdef OVR_DBL_DIG @@ -37,59 +38,42 @@ #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_mortalgrow _((void)); -static void sv_unglob _((SV* sv)); -static void sv_check_thinkfirst _((SV *sv)); - -#ifndef PURIFY -static void *my_safemalloc(MEM_SIZE size); -#endif - -typedef void (*SVFUNC) _((SV*)); #define VTBL *vtbl +#endif /* PERL_OBJECT */ + #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_check_thinkfirst(sv) #ifdef PURIFY -#define new_SV(p) \ - do { \ - LOCK_SV_MUTEX; \ - (p) = (SV*)safemalloc(sizeof(SV)); \ - reg_add(p); \ - UNLOCK_SV_MUTEX; \ - } while (0) - -#define del_SV(p) \ - do { \ - LOCK_SV_MUTEX; \ - reg_remove(p); \ - Safefree((char*)(p)); \ - UNLOCK_SV_MUTEX; \ - } while (0) +#define new_SV(p) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + (p) = (SV*)safemalloc(sizeof(SV)); \ + reg_add(p); \ + UNLOCK_SV_MUTEX; \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + } STMT_END + +#define del_SV(p) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + reg_remove(p); \ + Safefree((char*)(p)); \ + UNLOCK_SV_MUTEX; \ + } STMT_END static SV **registry; static I32 registry_size; @@ -97,25 +81,24 @@ static I32 registry_size; #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) #define REG_REPLACE(sv,a,b) \ - do { \ - void* p = sv->sv_any; \ - I32 h = REGHASH(sv, registry_size); \ - I32 i = h; \ - while (registry[i] != (a)) { \ - if (++i >= registry_size) \ - i = 0; \ - if (i == h) \ - die("SV registry bug"); \ - } \ - registry[i] = (b); \ - } while (0) + STMT_START { \ + void* p = sv->sv_any; \ + I32 h = REGHASH(sv, registry_size); \ + I32 i = h; \ + while (registry[i] != (a)) { \ + if (++i >= registry_size) \ + i = 0; \ + if (i == h) \ + Perl_die(aTHX_ "SV registry bug"); \ + } \ + registry[i] = (b); \ + } STMT_END #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) -static void -reg_add(sv) -SV* sv; +STATIC void +S_reg_add(pTHX_ SV *sv) { if (PL_sv_count >= (registry_size >> 1)) { @@ -141,17 +124,15 @@ SV* sv; ++PL_sv_count; } -static void -reg_remove(sv) -SV* sv; +STATIC void +S_reg_remove(pTHX_ SV *sv) { REG_REMOVE(sv); --PL_sv_count; } -static void -visit(f) -SVFUNC f; +STATIC void +S_visit(pTHX_ SVFUNC_t f) { I32 i; @@ -163,10 +144,7 @@ SVFUNC f; } void -sv_add_arena(ptr, size, flags) -char* ptr; -U32 size; -U32 flags; +Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { if (!(flags & SVf_FAKE)) Safefree(ptr); @@ -178,44 +156,49 @@ U32 flags; * "A time to plant, and a time to uproot what was planted..." */ -#define plant_SV(p) \ - do { \ - SvANY(p) = (void *)PL_sv_root; \ - SvFLAGS(p) = SVTYPEMASK; \ - PL_sv_root = (p); \ - --PL_sv_count; \ - } while (0) +#define plant_SV(p) \ + STMT_START { \ + SvANY(p) = (void *)PL_sv_root; \ + SvFLAGS(p) = SVTYPEMASK; \ + PL_sv_root = (p); \ + --PL_sv_count; \ + } STMT_END /* sv_mutex must be held while calling uproot_SV() */ -#define uproot_SV(p) \ - do { \ - (p) = PL_sv_root; \ - PL_sv_root = (SV*)SvANY(p); \ - ++PL_sv_count; \ - } while (0) - -#define new_SV(p) do { \ - LOCK_SV_MUTEX; \ - if (PL_sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv(); \ - UNLOCK_SV_MUTEX; \ - } while (0) +#define uproot_SV(p) \ + STMT_START { \ + (p) = PL_sv_root; \ + PL_sv_root = (SV*)SvANY(p); \ + ++PL_sv_count; \ + } STMT_END + +#define new_SV(p) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv(); \ + UNLOCK_SV_MUTEX; \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + } STMT_END #ifdef DEBUGGING -#define del_SV(p) do { \ - LOCK_SV_MUTEX; \ - if (PL_debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p); \ - UNLOCK_SV_MUTEX; \ - } while (0) +#define del_SV(p) \ + STMT_START { \ + LOCK_SV_MUTEX; \ + if (PL_debug & 32768) \ + del_sv(p); \ + else \ + plant_SV(p); \ + UNLOCK_SV_MUTEX; \ + } STMT_END STATIC void -del_sv(SV *p) +S_del_sv(pTHX_ SV *p) { if (PL_debug & 32768) { SV* sva; @@ -229,7 +212,9 @@ 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%lx", (unsigned long)p); return; } } @@ -243,7 +228,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; @@ -271,7 +256,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; @@ -289,7 +274,7 @@ more_sv(void) } STATIC void -visit(SVFUNC f) +S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; @@ -299,92 +284,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) -{ - visit(FUNC_NAME_TO_PTR(do_report_used)); -} - -STATIC void -do_clean_objs(SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -STATIC void -do_clean_named_objs(SV *sv) +Perl_sv_report_used(pTHX) { - if (SvTYPE(sv) == SVt_PVGV) { - if ( SvOBJECT(GvSV(sv)) || - GvAV(sv) && SvOBJECT(GvAV(sv)) || - GvHV(sv) && SvOBJECT(GvHV(sv)) || - GvIO(sv) && SvOBJECT(GvIO(sv)) || - GvCV(sv) && SvOBJECT(GvCV(sv)) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) - SvREFCNT_dec(sv); - } - } + visit(do_report_used); } -#endif void -sv_clean_objs(void) +Perl_sv_clean_objs(pTHX) { PL_in_clean_objs = TRUE; - visit(FUNC_NAME_TO_PTR(do_clean_objs)); + visit(do_clean_objs); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); + visit(do_clean_named_objs); #endif PL_in_clean_objs = FALSE; } -STATIC void -do_clean_all(SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); -} - void -sv_clean_all(void) +Perl_sv_clean_all(pTHX) { PL_in_clean_all = TRUE; - visit(FUNC_NAME_TO_PTR(do_clean_all)); + visit(do_clean_all); PL_in_clean_all = FALSE; } void -sv_free_arenas(void) +Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; @@ -410,7 +344,7 @@ sv_free_arenas(void) } STATIC XPVIV* -new_xiv(void) +S_new_xiv(pTHX) { IV* xiv; LOCK_SV_MUTEX; @@ -426,7 +360,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; @@ -436,7 +370,7 @@ del_xiv(XPVIV *p) } STATIC void -more_xiv(void) +S_more_xiv(pTHX) { register IV* xiv; register IV* xivend; @@ -457,46 +391,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; @@ -509,7 +443,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; @@ -518,7 +452,7 @@ del_xrv(XRV *p) } STATIC void -more_xrv(void) +S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; @@ -533,7 +467,7 @@ more_xrv(void) } STATIC XPV* -new_xpv(void) +S_new_xpv(pTHX) { XPV* xpv; LOCK_SV_MUTEX; @@ -546,7 +480,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; @@ -555,7 +489,7 @@ del_xpv(XPV *p) } STATIC void -more_xpv(void) +S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; @@ -606,7 +540,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); @@ -649,13 +583,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; @@ -680,7 +614,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; @@ -707,7 +641,7 @@ sv_upgrade(register SV *sv, U32 mt) cur = 0; len = 0; iv = (IV)pv; - nv = (double)(unsigned long)pv; + nv = (NV)(unsigned long)pv; del_XRV(SvANY(sv)); magic = 0; stash = 0; @@ -757,12 +691,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; @@ -923,7 +857,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)) { @@ -938,7 +872,7 @@ 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; @@ -986,7 +920,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)) { @@ -1002,11 +936,6 @@ sv_setiv(register SV *sv, IV i) break; case SVt_PVGV: - if (SvFAKE(sv)) { - sv_unglob(sv); - break; - } - /* FALL THROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1014,7 +943,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]); } } @@ -1024,30 +953,29 @@ 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) { - if (u <= IV_MAX) - sv_setiv(sv, u); - else - sv_setnv(sv, (double)u); + sv_setiv(sv, 0); + SvIsUV_on(sv); + SvUVX(sv) = 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)) { @@ -1062,11 +990,6 @@ sv_setnv(register SV *sv, double num) break; case SVt_PVGV: - if (SvFAKE(sv)) { - sv_unglob(sv); - break; - } - /* FALL THROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1074,7 +997,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]); } } @@ -1084,14 +1007,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]; @@ -1139,14 +1062,23 @@ not_a_number(SV *sv) *d = '\0'; if (PL_op) - warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, + Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, PL_op_name[PL_op->op_type]); else - warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); + Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } +/* the number can be converted to _integer_ with atol() */ +#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() */ +#define IS_NUMBER_NEG 0x08 /* not good to cache UV */ + +/* Actually, ISO C leaves conversion of UV to IV undefined, but + 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; @@ -1155,10 +1087,7 @@ sv_2iv(register SV *sv) if (SvIOKp(sv)) return SvIVX(sv); if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_V(SvNVX(sv)); + return I_V(SvNVX(sv)); } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); @@ -1166,72 +1095,129 @@ 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; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvIV(tmpstr); -#endif /* OVERLOAD */ + return SvIV(tmpstr); return (IV)SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_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; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return (IV)(SvUVX(sv)); + } + else { + return SvIVX(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? + */ + + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); + (void)SvIOK_on(sv); - if (SvNVX(sv) < 0.0) + if (SvNVX(sv) < (NV)IV_MAX + 0.5) SvIVX(sv) = I_V(SvNVX(sv)); - else + 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))); + return (IV)SvUVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvIVX(sv) = asIV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache an IV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such an IV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + 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. */ + NV d; + + 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%lx 2nv(%Lg)\n", + (unsigned long)sv, SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", + (unsigned long)sv, SvNVX(sv))); +#endif + if (SvNVX(sv) < (NV)IV_MAX + 0.5) + SvIVX(sv) = I_V(SvNVX(sv)); + else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + goto ret_iv_max; + } + } + else if (numtype) { + /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */ + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = 0; + (void)SvIOK_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(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))); - return 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; @@ -1247,68 +1233,147 @@ 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; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvUV(tmpstr); -#endif /* OVERLOAD */ + return SvUV(tmpstr); return (UV)SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return SvUVX(sv); + } + else { + return (UV)SvIVX(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? + */ + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); (void)SvIOK_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); + if (SvNVX(sv) >= -0.5) { + SvIsUV_on(sv); + SvUVX(sv) = U_V(SvNVX(sv)); + } + else { + 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))); + return (UV)SvIVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvUVX(sv) = asUV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache a UV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + if (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. */ + NV d; + + d = Atof(SvPVX(sv)); /* XXXX 64-bit? */ + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n", + (unsigned long)sv, SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", + (unsigned long)sv, SvNVX(sv))); +#endif + if (SvNVX(sv) < -0.5) { + SvIVX(sv) = I_V(SvNVX(sv)); + goto ret_zero; + } else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + } + } + else if (numtype & IS_NUMBER_NEG) { + /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */ + } + else if (numtype) { /* Non-negative */ + /* The NV may be reconstructed from UV - safe to cache UV, + which may be calculated by strtoul()/atol. */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); +#ifdef HAS_STRTOUL + SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */ +#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? */ +#endif + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } } else { 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. */ + sv_upgrade(sv, SVt_IV); return 0; } + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", (unsigned long)sv,SvUVX(sv))); - return 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; @@ -1320,41 +1385,34 @@ 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)) - return (double)SvIVX(sv); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + 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; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) - return SvNV(tmpstr); -#endif /* OVERLOAD */ - return (double)(unsigned long)SvRV(sv); + return SvNV(tmpstr); + return (NV)(unsigned long)SvRV(sv); } - if (SvREADONLY(sv)) { + if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; - if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) - not_a_number(sv); - SET_NUMERIC_STANDARD(); - return atof(SvPVX(sv)); - } - if (SvIOKp(sv)) - 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; } } @@ -1363,65 +1421,87 @@ 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%lx num(%Lg)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { - SvNVX(sv) = (double)SvIVX(sv); + SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); - SET_NUMERIC_STANDARD(); - SvNVX(sv) = atof(SvPVX(sv)); + SvNVX(sv) = Atof(SvPVX(sv)); } else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + if (SvTYPE(sv) < SVt_NV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_NV); return 0.0; } SvNOK_on(sv); - DEBUG_c(SET_NUMERIC_STANDARD()); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n", + (unsigned long)sv, SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif return SvNVX(sv); } STATIC IV -asIV(SV *sv) +S_asIV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); - double d; + NV d; - if (numtype == 1) - return atol(SvPVX(sv)); + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return atol(SvPVX(sv)); /* XXXX 64-bit? */ if (!numtype) { dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - SET_NUMERIC_STANDARD(); - d = atof(SvPVX(sv)); - if (d < 0.0) - return I_V(d); - else - return (IV) U_V(d); + 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 == 1) + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) return strtoul(SvPVX(sv), Null(char**), 10); #endif if (!numtype) { @@ -1429,17 +1509,32 @@ asUV(SV *sv) if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - SET_NUMERIC_STANDARD(); - return U_V(atof(SvPVX(sv))); + return U_V(Atof(SvPVX(sv))); } +/* + * Returns a combination of (advisory only - can get false negatives) + * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, + * IS_NUMBER_NEG + * 0 if does not look like number. + * + * In fact possible values are 0 and + * IS_NUMBER_TO_INT_BY_ATOL 123 + * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 + * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * with a possible addition of IS_NUMBER_NEG. + */ + 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; - I32 numtype; + register char *nbegin; + I32 numtype = 0; STRLEN len; if (SvPOK(sv)) { @@ -1455,23 +1550,50 @@ looks_like_number(SV *sv) s = sbegin; while (isSPACE(*s)) s++; - if (*s == '+' || *s == '-') + if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') s++; - /* next must be digit or '.' */ + nbegin = s; + /* + * 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 the radix separator */ if (isDIGIT(*s)) { do { s++; } while (isDIGIT(*s)); - if (*s == '.') { + + if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */ + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; + else + numtype |= IS_NUMBER_TO_INT_BY_ATOL; + + if (*s == '.' +#ifdef USE_LOCALE_NUMERIC + || IS_NUMERIC_RADIX(*s) +#endif + ) { s++; - while (isDIGIT(*s)) /* optional digits after "." */ + numtype |= IS_NUMBER_NOT_IV; + 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++; - /* no digits before '.' means we need digits after it */ + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; + /* no digits before the radix means we need digits after it */ if (isDIGIT(*s)) { do { s++; @@ -1483,15 +1605,10 @@ looks_like_number(SV *sv) else return 0; - /* - * we return 1 if the number can be converted to _integer_ with atol() - * and 2 if you need (int)atof(). - */ - numtype = 1; - /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { - numtype = 2; + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; if (*s == '+' || *s == '-') s++; @@ -1508,17 +1625,53 @@ looks_like_number(SV *sv) if (s >= send) return numtype; if (len == 10 && memEQ(sbegin, "0 but true", 10)) - return 1; + return IS_NUMBER_TO_INT_BY_ATOL; return 0; } char * -sv_2pv(register SV *sv, STRLEN *lp) +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 * +uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +{ + STRLEN len; + char *ptr = buf + TYPE_CHARS(UV); + char *ebuf = ptr; + int sign; + char *p; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + +char * +Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { register char *s; int olderrno; SV *tsv; - char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char *tmpbuf = tbuf; if (!sv) { *lp = 0; @@ -1530,13 +1683,15 @@ sv_2pv(register SV *sv, STRLEN *lp) *lp = SvCUR(sv); return SvPVX(sv); } - if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); + if (SvIOKp(sv)) { /* XXXX 64-bit? */ + if (SvIsUV(sv)) + (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); + else + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; @@ -1545,7 +1700,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 ""; @@ -1553,11 +1708,9 @@ sv_2pv(register SV *sv, STRLEN *lp) } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) - return SvPV(tmpstr,*lp); -#endif /* OVERLOAD */ + return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) s = "NULLREF"; @@ -1629,38 +1782,26 @@ 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); - sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); + /* XXXX 64-bit? */ + Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv); goto tokensaveref; } *lp = strlen(s); return s; } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); - 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 ""; } } - (void)SvUPGRADE(sv, SVt_PV); - if (SvNOKp(sv)) { + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvGROW(sv, 28); @@ -1672,7 +1813,6 @@ sv_2pv(register SV *sv, STRLEN *lp) else #endif /*apollo*/ { - SET_NUMERIC_STANDARD(); Gconvert(SvNVX(sv), DBL_DIG, 0, s); } errno = olderrno; @@ -1687,29 +1827,48 @@ sv_2pv(register SV *sv, STRLEN *lp) #endif } else if (SvIOKp(sv)) { - U32 oldIOK = SvIOK(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); - olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpviv(sv, SvIVX(sv)); - errno = olderrno; + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); - if (oldIOK) + *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. */ + sv_upgrade(sv, SVt_PV); return ""; } *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: @@ -1754,7 +1913,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); @@ -1762,14 +1921,10 @@ sv_2bool(register SV *sv) if (!SvOK(sv)) return 0; if (SvROK(sv)) { -#ifdef OVERLOAD - { dTHR; SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) - return SvTRUE(tmpsv); - } -#endif /* OVERLOAD */ + return SvTRUE(tmpsv); return SvRV(sv) != 0; } if (SvPOKp(sv)) { @@ -1800,7 +1955,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; @@ -1815,16 +1970,8 @@ sv_setsv(SV *dstr, register SV *sstr) stype = SvTYPE(sstr); dtype = SvTYPE(dstr); - if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) { - sv_unglob(dstr); /* so fake GLOB won't perpetuate */ - sv_setpvn(dstr, "", 0); - (void)SvPOK_only(dstr); - dtype = SvTYPE(dstr); - } - -#ifdef OVERLOAD SvAMAGIC_off(dstr); -#endif /* OVERLOAD */ + /* There's a lot of redundancy below but we're going for speed here */ switch (stype) { @@ -1851,6 +1998,8 @@ sv_setsv(SV *dstr, register SV *sstr) } (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); SvTAINT(dstr); return; } @@ -1909,10 +2058,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: @@ -1931,7 +2080,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 */ @@ -1955,9 +2104,9 @@ sv_setsv(SV *dstr, register SV *sstr) } } if (stype == SVt_PVLV) - SvUPGRADE(dstr, SVt_PVNV); + (void)SvUPGRADE(dstr, SVt_PVNV); else - SvUPGRADE(dstr, stype); + (void)SvUPGRADE(dstr, stype); } sflags = SvFLAGS(sstr); @@ -2027,7 +2176,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)) { @@ -2035,7 +2184,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)); @@ -2078,7 +2227,8 @@ sv_setsv(SV *dstr, register SV *sstr) } if (SvPVX(dstr)) { (void)SvOOK_off(dstr); /* backoff */ - Safefree(SvPVX(dstr)); + if (SvLEN(dstr)) + Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } } @@ -2092,12 +2242,12 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } -#ifdef OVERLOAD if (SvAMAGIC(sstr)) { SvAMAGIC_on(dstr); } -#endif /* OVERLOAD */ } else if (sflags & SVp_POK) { @@ -2117,7 +2267,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvFLAGS(dstr) &= ~SVf_OOK; Safefree(SvPVX(dstr) - SvIVX(dstr)); } - else + else if (SvLEN(dstr)) Safefree(SvPVX(dstr)); } (void)SvPOK_only(dstr); @@ -2148,6 +2298,8 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { @@ -2156,16 +2308,21 @@ sv_setsv(SV *dstr, register SV *sstr) if (SvIOK(sstr)) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } else { if (dtype == SVt_PVGV) { if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Undefined value assigned to typeglob"); + Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob"); } else (void)SvOK_off(dstr); @@ -2174,14 +2331,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 @@ -2191,12 +2348,7 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) (void)SvOK_off(sv); return; } - if (SvTYPE(sv) >= SVt_PV) { - if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) - sv_unglob(sv); - } - else - sv_upgrade(sv, SVt_PV); + (void)SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); dptr = SvPVX(sv); @@ -2208,14 +2360,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; @@ -2225,12 +2377,7 @@ sv_setpv(register SV *sv, register const char *ptr) return; } len = strlen(ptr); - if (SvTYPE(sv) >= SVt_PV) { - if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) - sv_unglob(sv); - } - else - sv_upgrade(sv, SVt_PV); + (void)SvUPGRADE(sv, SVt_PV); SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); @@ -2240,14 +2387,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); @@ -2256,7 +2403,7 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) return; } (void)SvOOK_off(sv); - if (SvPVX(sv)) + if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); SvPVX(sv) = ptr; @@ -2268,26 +2415,28 @@ 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); } -STATIC void -sv_check_thinkfirst(register SV *sv) +void +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); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + sv_unglob(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 */ { @@ -2300,10 +2449,17 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { + if (!SvLEN(sv)) { /* make copy of shared string */ + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } SvIVX(sv) = 0; SvFLAGS(sv) |= SVf_OOK; } - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK); + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; @@ -2312,7 +2468,7 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in } void -sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { STRLEN tlen; char *junk; @@ -2329,14 +2485,14 @@ sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) } void -sv_catpvn_mg(register SV *sv, register 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; @@ -2347,14 +2503,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 char *ptr) +Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; STRLEN tlen; @@ -2374,21 +2530,18 @@ sv_catpv(register SV *sv, register char *ptr) } void -sv_catpv_mg(register SV *sv, register 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; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (len) { sv_upgrade(sv, SVt_PV); SvGROW(sv, len + 1); @@ -2399,14 +2552,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, 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))) { @@ -2441,7 +2594,6 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) case 0: mg->mg_virtual = &PL_vtbl_sv; break; -#ifdef OVERLOAD case 'A': mg->mg_virtual = &PL_vtbl_amagic; break; @@ -2451,7 +2603,6 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) case 'c': mg->mg_virtual = 0; break; -#endif /* OVERLOAD */ case 'B': mg->mg_virtual = &PL_vtbl_bm; break; @@ -2540,6 +2691,9 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) case '.': mg->mg_virtual = &PL_vtbl_pos; break; + case '<': + mg->mg_virtual = &PL_vtbl_backref; + break; case '~': /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ @@ -2547,7 +2701,7 @@ sv_magic(register SV *sv, SV *obj, int how, 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)) @@ -2555,7 +2709,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) } int -sv_unmagic(SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *sv, int type) { MAGIC* mg; MAGIC** mgp; @@ -2567,7 +2721,7 @@ sv_unmagic(SV *sv, int type) MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(sv, mg); + (VTBL->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2588,8 +2742,65 @@ sv_unmagic(SV *sv, int type) return 0; } +SV * +Perl_sv_rvweaken(pTHX_ SV *sv) +{ + SV *tsv; + if (!SvOK(sv)) /* let undefs pass */ + return sv; + if (!SvROK(sv)) + Perl_croak(aTHX_ "Can't weaken a nonreference"); + else if (SvWEAKREF(sv)) { + dTHR; + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Reference is already weak"); + return sv; + } + tsv = SvRV(sv); + sv_add_backref(tsv, sv); + SvWEAKREF_on(sv); + SvREFCNT_dec(tsv); + return sv; +} + +STATIC void +S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +{ + AV *av; + MAGIC *mg; + if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<'))) + av = (AV*)mg->mg_obj; + else { + av = newAV(); + sv_magic(tsv, (SV*)av, '<', NULL, 0); + SvREFCNT_dec(av); /* for sv_magic */ + } + av_push(av,sv); +} + +STATIC void +S_sv_del_backref(pTHX_ SV *sv) +{ + AV *av; + SV **svp; + I32 i; + SV *tsv = SvRV(sv); + MAGIC *mg; + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<'))) + Perl_croak(aTHX_ "panic: del_backref"); + av = (AV *)mg->mg_obj; + svp = AvARRAY(av); + i = AvFILLp(av); + while (i >= 0) { + if (svp[i] == sv) { + svp[i] = &PL_sv_undef; /* XXX */ + } + i--; + } +} + 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; @@ -2600,7 +2811,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); @@ -2634,7 +2845,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) { @@ -2674,12 +2885,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); @@ -2700,7 +2912,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); @@ -2730,8 +2942,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; @@ -2740,6 +2952,14 @@ sv_clear(register SV *sv) } while (SvOBJECT(sv) && SvSTASH(sv) != stash); del_XRV(SvANY(&tmpref)); + + if (SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", + HvNAME(stash)); + /* DESTROY gave object new lease on life */ + return; + } } if (SvOBJECT(sv)) { @@ -2748,12 +2968,6 @@ sv_clear(register SV *sv) if (SvTYPE(sv) != SVt_PVIO) --PL_sv_objcount; /* XXX Might want something more general */ } - if (SvREFCNT(sv)) { - if (PL_in_clean_objs) - croak("DESTROY created new reference to dead object"); - /* DESTROY gave object new lease on life */ - return; - } } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) mg_free(sv); @@ -2764,7 +2978,13 @@ sv_clear(register SV *sv) IoIFP(sv) != PerlIO_stdin() && IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) - io_close((IO*)sv); + { + io_close((IO*)sv, FALSE); + } + if (IoDIRP(sv)) { + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = 0; + } Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2801,8 +3021,12 @@ sv_clear(register SV *sv) /* FALL THROUGH */ case SVt_PV: case SVt_RV: - if (SvROK(sv)) - SvREFCNT_dec(SvRV(sv)); + if (SvROK(sv)) { + if (SvWEAKREF(sv)) + sv_del_backref(sv); + else + SvREFCNT_dec(SvRV(sv)); + } else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); break; @@ -2874,7 +3098,7 @@ sv_clear(register SV *sv) } SV * -sv_newref(SV *sv) +Perl_sv_newref(pTHX_ SV *sv) { if (sv) ATOMIC_INC(SvREFCNT(sv)); @@ -2882,8 +3106,9 @@ sv_newref(SV *sv) } void -sv_free(SV *sv) +Perl_sv_free(pTHX_ SV *sv) { + dTHR; int refcount_is_zero; if (!sv) @@ -2898,7 +3123,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)); @@ -2906,7 +3132,9 @@ 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%lx", (unsigned long)sv); return; } #endif @@ -2921,7 +3149,7 @@ sv_free(SV *sv) } STRLEN -sv_len(register SV *sv) +Perl_sv_len(pTHX_ register SV *sv) { char *junk; STRLEN len; @@ -2937,7 +3165,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; @@ -2962,7 +3190,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; @@ -2993,7 +3221,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; @@ -3004,7 +3232,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) { @@ -3012,7 +3240,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; @@ -3020,7 +3250,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; @@ -3046,7 +3276,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; @@ -3072,7 +3302,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 @@ -3127,7 +3357,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; @@ -3173,7 +3403,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; @@ -3185,6 +3415,7 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) SV_CHECK_THINKFIRST(sv); (void)SvUPGRADE(sv, SVt_PV); + SvSCREAM_off(sv); if (RsSNARF(PL_rs)) { @@ -3371,8 +3602,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) { @@ -3436,7 +3675,7 @@ screamer2: void -sv_inc(register SV *sv) +Perl_sv_inc(pTHX_ register SV *sv) { register char *d; int flags; @@ -3449,13 +3688,12 @@ 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; -#ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; -#endif /* OVERLOAD */ + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) + return; i = (IV)SvRV(sv); sv_unref(sv); sv_setiv(sv, i); @@ -3468,11 +3706,19 @@ sv_inc(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MAX) - sv_setnv(sv, (double)IV_MAX + 1.0); - else { - (void)SvIOK_only(sv); - ++SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == UV_MAX) + 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, (NV)IV_MAX + 1.0); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } } return; } @@ -3487,8 +3733,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--; @@ -3531,7 +3776,7 @@ sv_inc(register SV *sv) } void -sv_dec(register SV *sv) +Perl_sv_dec(pTHX_ register SV *sv) { int flags; @@ -3543,13 +3788,12 @@ 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; -#ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; -#endif /* OVERLOAD */ + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) + return; i = (IV)SvRV(sv); sv_unref(sv); sv_setiv(sv, i); @@ -3562,11 +3806,22 @@ sv_dec(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (double)IV_MIN - 1.0); - else { - (void)SvIOK_only(sv); - --SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == 0) { + (void)SvIOK_only(sv); + SvIVX(sv) = -1; + } + else { + (void)SvIOK_only_UV(sv); + --SvUVX(sv); + } + } else { + if (SvIVX(sv) == IV_MIN) + sv_setnv(sv, (NV)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } } return; } @@ -3577,8 +3832,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 @@ -3586,74 +3840,55 @@ sv_dec(register SV *sv) * hopefully we won't free it until it has been assigned to a * permanent location. */ -STATIC void -sv_mortalgrow(void) -{ - dTHR; - PL_tmps_max += (PL_tmps_max < 512) ? 128 : 512; - Renew(PL_tmps_stack, PL_tmps_max, SV*); -} - SV * -sv_mortalcopy(SV *oldstr) +Perl_sv_mortalcopy(pTHX_ SV *oldstr) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setsv(sv,oldstr); - if (++PL_tmps_ix >= PL_tmps_max) - sv_mortalgrow(); - PL_tmps_stack[PL_tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } SV * -sv_newmortal(void) +Perl_sv_newmortal(pTHX) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; - if (++PL_tmps_ix >= PL_tmps_max) - sv_mortalgrow(); - PL_tmps_stack[PL_tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; return sv; } /* same thing without the copying */ SV * -sv_2mortal(register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *sv) { dTHR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) return sv; - if (++PL_tmps_ix >= PL_tmps_max) - sv_mortalgrow(); - PL_tmps_stack[PL_tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } SV * -newSVpv(char *s, STRLEN len) +Perl_newSVpv(pTHX_ const char *s, STRLEN len) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (!len) len = strlen(s); sv_setpvn(sv,s,len); @@ -3661,71 +3896,76 @@ newSVpv(char *s, STRLEN len) } SV * -newSVpvn(char *s, STRLEN len) +Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setpvn(sv,s,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); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; +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; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setnv(sv,n); return sv; } SV * -newSViv(IV i) +Perl_newSViv(pTHX_ IV i) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setiv(sv,i); return sv; } SV * -newRV_noinc(SV *tmpRef) +Perl_newRV_noinc(pTHX_ SV *tmpRef) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); SvTEMP_off(tmpRef); SvRV(sv) = tmpRef; @@ -3734,7 +3974,7 @@ newRV_noinc(SV *tmpRef) } SV * -newRV(SV *tmpRef) +Perl_newRV(pTHX_ SV *tmpRef) { return newRV_noinc(SvREFCNT_inc(tmpRef)); } @@ -3742,20 +3982,19 @@ 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); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (SvTEMP(old)) { SvTEMP_off(old); sv_setsv(sv,old); @@ -3767,7 +4006,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; @@ -3775,7 +4014,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; @@ -3794,11 +4033,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; } @@ -3839,7 +4078,7 @@ sv_reset(register char *s, HV *stash) } IO* -sv_2io(SV *sv) +Perl_sv_2io(pTHX_ SV *sv) { IO* io; GV* gv; @@ -3853,11 +4092,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); @@ -3866,14 +4105,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; @@ -3914,7 +4153,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; @@ -3930,20 +4169,23 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) ENTER; tmpsv = NEWSV(704,0); gv_efullname3(tmpsv, gv, Nullch); + /* XXX this is probably not what they think they're getting. + * It has the same effect as "sub name;", i.e. just a forward + * declaration! */ newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, tmpsv), Nullop, 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) @@ -3971,23 +4213,29 @@ sv_true(register SV *sv) } IV -sv_iv(register SV *sv) +Perl_sv_iv(pTHX_ register SV *sv) { - if (SvIOK(sv)) + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return (IV)SvUVX(sv); return SvIVX(sv); + } return sv_2iv(sv); } UV -sv_uv(register SV *sv) +Perl_sv_uv(pTHX_ register SV *sv) { - if (SvIOK(sv)) - return SvUVX(sv); + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(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); @@ -3995,7 +4243,18 @@ sv_nv(register SV *sv) } char * -sv_pvn(SV *sv, STRLEN *lp) +Perl_sv_pv(pTHX_ SV *sv) +{ + STRLEN n_a; + + if (SvPOK(sv)) + return SvPVX(sv); + + return sv_2pv(sv, &n_a); +} + +char * +Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) { if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -4005,31 +4264,21 @@ 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; - if (SvREADONLY(sv)) { - dTHR; - if (PL_curcop != &PL_compiling) - croak(PL_no_modify); - } + if (SvTHINKFIRST(sv) && !SvROK(sv)) + sv_force_normal(sv); if (SvPOK(sv)) { *lp = SvCUR(sv); } else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { - if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) { - sv_unglob(sv); - s = SvPVX(sv); - *lp = SvCUR(sv); - } - else { - dTHR; - croak("Can't coerce %s to string in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); - } + dTHR; + Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } else s = sv_2pv(sv, lp); @@ -4055,7 +4304,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) } char * -sv_reftype(SV *sv, int ob) +Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) return HvNAME(SvSTASH(sv)); @@ -4086,7 +4335,7 @@ sv_reftype(SV *sv, int ob) } int -sv_isobject(SV *sv) +Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; @@ -4101,7 +4350,7 @@ sv_isobject(SV *sv) } int -sv_isa(SV *sv, char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *name) { if (!sv) return 0; @@ -4117,26 +4366,21 @@ sv_isa(SV *sv, char *name) } SV* -newSVrv(SV *rv, char *classname) +Perl_newSVrv(pTHX_ SV *rv, const char *classname) { dTHR; SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 0; - SvFLAGS(sv) = 0; SV_CHECK_THINKFIRST(rv); -#ifdef OVERLOAD SvAMAGIC_off(rv); -#endif /* OVERLOAD */ if (SvTYPE(rv) < SVt_RV) sv_upgrade(rv, SVt_RV); (void)SvOK_off(rv); - SvRV(rv) = SvREFCNT_inc(sv); + SvRV(rv) = sv; SvROK_on(rv); if (classname) { @@ -4147,7 +4391,7 @@ newSVrv(SV *rv, char *classname) } SV* -sv_setref_pv(SV *rv, char *classname, void *pv) +Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) { if (!pv) { sv_setsv(rv, &PL_sv_undef); @@ -4159,37 +4403,37 @@ sv_setref_pv(SV *rv, char *classname, void *pv) } SV* -sv_setref_iv(SV *rv, 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, 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, char *classname, char *pv, I32 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; @@ -4202,18 +4446,16 @@ sv_bless(SV *sv, HV *stash) (void)SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); -#ifdef OVERLOAD if (Gv_AMG(stash)) SvAMAGIC_on(sv); else SvAMAGIC_off(sv); -#endif /* OVERLOAD */ return sv; } STATIC void -sv_unglob(SV *sv) +S_sv_unglob(pTHX_ SV *sv) { assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); @@ -4231,10 +4473,16 @@ sv_unglob(SV *sv) } void -sv_unref(SV *sv) +Perl_sv_unref(pTHX_ SV *sv) { SV* rv = SvRV(sv); - + + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + return; + } SvRV(sv) = 0; SvROK_off(sv); if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) @@ -4244,13 +4492,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'); @@ -4260,7 +4508,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'); @@ -4271,94 +4519,143 @@ sv_tainted(SV *sv) } void -sv_setpviv(SV *sv, IV iv) +Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { - STRLEN len; - char buf[TYPE_DIGITS(UV)]; - char *ptr = buf + sizeof(buf); - int sign; - UV uv; - char *p; + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - sv_setpvn(sv, "", 0); - if (iv >= 0) { - uv = iv; - sign = 0; - } else { - uv = -iv; - sign = 1; - } - do { - *--ptr = '0' + (uv % 10); - } while (uv /= 10); - len = (buf + sizeof(buf)) - ptr; - /* taking advantage of SvCUR(sv) == 0 */ - SvGROW(sv, sign + len + 1); - p = SvPVX(sv); - if (sign) - *p++ = '-'; - memcpy(p, ptr, len); - p += len; - *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + sv_setpvn(sv, ptr, ebuf - ptr); } void -sv_setpviv_mg(SV *sv, IV iv) +Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { - sv_setpviv(sv,iv); + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + + sv_setpvn(sv, ptr, ebuf - ptr); 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_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + 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_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 -sv_catpvf(SV *sv, const char* pat, ...) +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); } +#endif + +void +Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + 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 -sv_catpvf_mg(SV *sv, const char* pat, ...) +Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf_mg(sv, pat, &args); va_end(args); +} + +void +Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); } void -sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { sv_setpvn(sv, "", 0); sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); } void -sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { dTHR; char *p; @@ -4418,7 +4715,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, unsigned base; IV iv; UV uv; - double nv; + NV nv; STRLEN have; STRLEN need; STRLEN gap; @@ -4736,7 +5033,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; @@ -4745,7 +5042,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); } @@ -4763,6 +5060,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; +#ifdef USE_LONG_DOUBLE + *--eptr = 'L'; +#endif if (has_precis) { base = precis; do { *--eptr = '0' + (base % 10); } while (base /= 10); @@ -4782,7 +5082,11 @@ 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); @@ -4822,14 +5126,14 @@ 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\"", + Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", c & 0xFF); else sv_catpv(msg, "end of string"); - warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -4882,3 +5186,61 @@ 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) { + /* 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); +} +