X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=042ffcc907c502365a6c7b4381ddeba3b3343831;hb=fdf134946da249a71c49962435817212b8fa195a;hp=1abc3fdae1c36a0929021bf1466682a26d130570;hpb=51ae5c030790e9d7687dbb390fdaa072649341b3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 1abc3fd..042ffcc 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. @@ -36,88 +36,96 @@ #endif #endif -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__) -# define FAST_SV_GETS -#endif - -static IV asIV _((SV* sv)); -static UV asUV _((SV* sv)); -static SV *more_sv _((void)); -static XPVIV *more_xiv _((void)); -static XPVNV *more_xnv _((void)); -static XPV *more_xpv _((void)); -static XRV *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)); - -#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv) +#ifdef PERL_OBJECT +#define FCALL this->*f +#define VTBL this->*vtbl + +#else /* !PERL_OBJECT */ + +static IV asIV (SV* sv); +static UV asUV (SV* sv); +static SV *more_sv (void); +static void more_xiv (void); +static void more_xnv (void); +static void more_xpv (void); +static void more_xrv (void); +static XPVIV *new_xiv (void); +static XPVNV *new_xnv (void); +static XPV *new_xpv (void); +static XRV *new_xrv (void); +static void del_xiv (XPVIV* p); +static void del_xnv (XPVNV* p); +static void del_xpv (XPV* p); +static void del_xrv (XRV* p); +static void sv_unglob (SV* sv); +static void sv_add_backref (SV *tsv, SV *sv); +static void sv_del_backref (SV *sv); #ifndef PURIFY static void *my_safemalloc(MEM_SIZE size); #endif -typedef void (*SVFUNC) _((SV*)); +typedef void (*SVFUNC) (SV*); +#define VTBL *vtbl +#define FCALL *f + +#endif /* PERL_OBJECT */ + +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(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 regsize; +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, regsize); \ - I32 i = h; \ - while (registry[i] != (a)) { \ - if (++i >= regsize) \ - 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) \ + die("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 +reg_add(SV *sv) { - if (sv_count >= (regsize >> 1)) + if (PL_sv_count >= (registry_size >> 1)) { SV **oldreg = registry; - I32 oldsize = regsize; + I32 oldsize = registry_size; - regsize = regsize ? ((regsize << 2) + 1) : 2037; - Newz(707, registry, regsize, SV*); + registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; + Newz(707, registry, registry_size, SV*); if (oldreg) { I32 i; @@ -132,35 +140,30 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } -static void -reg_remove(sv) -SV* sv; +STATIC void +reg_remove(SV *sv) { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } -static void -visit(f) -SVFUNC f; +STATIC void +visit(SVFUNC f) { I32 i; - for (i = 0; i < regsize; ++i) { + for (i = 0; i < registry_size; ++i) { SV* sv = registry[i]; - if (sv) + if (sv && SvTYPE(sv) != SVTYPEMASK) (*f)(sv); } } void -sv_add_arena(ptr, size, flags) -char* ptr; -U32 size; -U32 flags; +sv_add_arena(char *ptr, U32 size, U32 flags) { if (!(flags & SVf_FAKE)) Safefree(ptr); @@ -172,51 +175,56 @@ U32 flags; * "A time to plant, and a time to uproot what was planted..." */ -#define plant_SV(p) \ - do { \ - SvANY(p) = (void *)sv_root; \ - SvFLAGS(p) = SVTYPEMASK; \ - sv_root = (p); \ - --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) = sv_root; \ - sv_root = (SV*)SvANY(p); \ - ++sv_count; \ - } while (0) - -#define new_SV(p) do { \ - LOCK_SV_MUTEX; \ - if (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 (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p); \ - UNLOCK_SV_MUTEX; \ - } while (0) - -static void +#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) { - if (debug & 32768) { + if (PL_debug & 32768) { SV* sva; SV* sv; SV* svend; int ok = 0; - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { sv = sva + 1; svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) @@ -245,12 +253,12 @@ sv_add_arena(char *ptr, U32 size, U32 flags) Zero(sva, size, char); /* The first SV in an arena isn't an SV. */ - SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */ + SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ SvFLAGS(sva) = flags; /* FAKE if not to be freed */ - sv_arenaroot = sva; - sv_root = sva + 1; + PL_sv_arenaroot = sva; + PL_sv_root = sva + 1; svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; @@ -264,14 +272,14 @@ sv_add_arena(char *ptr, U32 size, U32 flags) } /* sv_mutex must be held while calling more_sv() */ -static SV* +STATIC SV* more_sv(void) { register SV* sv; - if (nice_chunk) { - sv_add_arena(nice_chunk, nice_chunk_size, 0); - nice_chunk = Nullch; + if (PL_nice_chunk) { + sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); + PL_nice_chunk = Nullch; } else { char *chunk; /* must use New here to match call to */ @@ -282,25 +290,25 @@ more_sv(void) return sv; } -static void +STATIC void visit(SVFUNC f) { SV* sva; SV* sv; register SV* svend; - for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) - (*f)(sv); + (FCALL)(sv); } } } #endif /* PURIFY */ -static void +STATIC void do_report_used(SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { @@ -313,10 +321,10 @@ do_report_used(SV *sv) void sv_report_used(void) { - visit(do_report_used); + visit(FUNC_NAME_TO_PTR(do_report_used)); } -static void +STATIC void do_clean_objs(SV *sv) { SV* rv; @@ -332,7 +340,7 @@ do_clean_objs(SV *sv) } #ifndef DISABLE_DESTRUCTOR_KLUDGE -static void +STATIC void do_clean_named_objs(SV *sv) { if (SvTYPE(sv) == SVt_PVGV) { @@ -345,41 +353,36 @@ do_clean_named_objs(SV *sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) SvREFCNT_dec(sv); } - else if (GvSV(sv)) - do_clean_objs(GvSV(sv)); } } #endif -static bool in_clean_objs = FALSE; - void sv_clean_objs(void) { - in_clean_objs = TRUE; + PL_in_clean_objs = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_objs)); #ifndef DISABLE_DESTRUCTOR_KLUDGE - visit(do_clean_named_objs); + /* some barnacles may yet remain, clinging to typeglobs */ + visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); #endif - visit(do_clean_objs); - in_clean_objs = FALSE; + PL_in_clean_objs = FALSE; } -static void +STATIC void do_clean_all(SV *sv) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } -static bool in_clean_all = FALSE; - void sv_clean_all(void) { - in_clean_all = TRUE; - visit(do_clean_all); - in_clean_all = FALSE; + PL_in_clean_all = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_all)); + PL_in_clean_all = FALSE; } void @@ -391,7 +394,7 @@ sv_free_arenas(void) /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ - for (sva = sv_arenaroot; sva; sva = svanext) { + for (sva = PL_sv_arenaroot; sva; sva = svanext) { svanext = (SV*) SvANY(sva); while (svanext && SvFAKE(svanext)) svanext = (SV*) SvANY(svanext); @@ -400,76 +403,85 @@ sv_free_arenas(void) Safefree((void *)sva); } - sv_arenaroot = 0; - sv_root = 0; + if (PL_nice_chunk) + Safefree(PL_nice_chunk); + PL_nice_chunk = Nullch; + PL_nice_chunk_size = 0; + PL_sv_arenaroot = 0; + PL_sv_root = 0; } -static XPVIV* +STATIC XPVIV* new_xiv(void) { - IV** xiv; - if (xiv_root) { - xiv = xiv_root; - /* - * See comment in more_xiv() -- RAM. - */ - xiv_root = (IV**)*xiv; - return (XPVIV*)((char*)xiv - sizeof(XPV)); - } - return more_xiv(); + IV* xiv; + LOCK_SV_MUTEX; + if (!PL_xiv_root) + more_xiv(); + xiv = PL_xiv_root; + /* + * See comment in more_xiv() -- RAM. + */ + PL_xiv_root = *(IV**)xiv; + UNLOCK_SV_MUTEX; + return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } -static void +STATIC void del_xiv(XPVIV *p) { - IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); - *xiv = (IV *)xiv_root; - xiv_root = xiv; + IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); + LOCK_SV_MUTEX; + *(IV**)xiv = PL_xiv_root; + PL_xiv_root = xiv; + UNLOCK_SV_MUTEX; } -static XPVIV* +STATIC void more_xiv(void) { - register IV** xiv; - register IV** xivend; + register IV* xiv; + register IV* xivend; XPV* ptr; New(705, ptr, 1008/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ - xiv_arenaroot = ptr; /* to keep Purify happy */ + ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ + PL_xiv_arenaroot = ptr; /* to keep Purify happy */ - xiv = (IV**) ptr; - xivend = &xiv[1008 / sizeof(IV *) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */ - xiv_root = xiv; + xiv = (IV*) ptr; + xivend = &xiv[1008 / sizeof(IV) - 1]; + xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ + PL_xiv_root = xiv; while (xiv < xivend) { - *xiv = (IV *)(xiv + 1); + *(IV**)xiv = (IV *)(xiv + 1); xiv++; } - *xiv = 0; - return new_xiv(); + *(IV**)xiv = 0; } -static XPVNV* +STATIC XPVNV* new_xnv(void) { double* xnv; - if (xnv_root) { - xnv = xnv_root; - xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - sizeof(XPVIV)); - } - return more_xnv(); + LOCK_SV_MUTEX; + if (!PL_xnv_root) + more_xnv(); + xnv = PL_xnv_root; + PL_xnv_root = *(double**)xnv; + UNLOCK_SV_MUTEX; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } -static void +STATIC void del_xnv(XPVNV *p) { - double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); - *(double**)xnv = xnv_root; - xnv_root = xnv; + double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + LOCK_SV_MUTEX; + *(double**)xnv = PL_xnv_root; + PL_xnv_root = xnv; + UNLOCK_SV_MUTEX; } -static XPVNV* +STATIC void more_xnv(void) { register double* xnv; @@ -477,83 +489,86 @@ more_xnv(void) New(711, xnv, 1008/sizeof(double), double); xnvend = &xnv[1008 / sizeof(double) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ - xnv_root = xnv; + PL_xnv_root = xnv; while (xnv < xnvend) { *(double**)xnv = (double*)(xnv + 1); xnv++; } *(double**)xnv = 0; - return new_xnv(); } -static XRV* +STATIC XRV* new_xrv(void) { XRV* xrv; - if (xrv_root) { - xrv = xrv_root; - xrv_root = (XRV*)xrv->xrv_rv; - return xrv; - } - return more_xrv(); + LOCK_SV_MUTEX; + if (!PL_xrv_root) + more_xrv(); + xrv = PL_xrv_root; + PL_xrv_root = (XRV*)xrv->xrv_rv; + UNLOCK_SV_MUTEX; + return xrv; } -static void +STATIC void del_xrv(XRV *p) { - p->xrv_rv = (SV*)xrv_root; - xrv_root = p; + LOCK_SV_MUTEX; + p->xrv_rv = (SV*)PL_xrv_root; + PL_xrv_root = p; + UNLOCK_SV_MUTEX; } -static XRV* +STATIC void more_xrv(void) { register XRV* xrv; register XRV* xrvend; - New(712, xrv_root, 1008/sizeof(XRV), XRV); - xrv = xrv_root; + New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); + xrv = PL_xrv_root; xrvend = &xrv[1008 / sizeof(XRV) - 1]; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); xrv++; } xrv->xrv_rv = 0; - return new_xrv(); } -static XPV* +STATIC XPV* new_xpv(void) { XPV* xpv; - if (xpv_root) { - xpv = xpv_root; - xpv_root = (XPV*)xpv->xpv_pv; - return xpv; - } - return more_xpv(); + LOCK_SV_MUTEX; + if (!PL_xpv_root) + more_xpv(); + xpv = PL_xpv_root; + PL_xpv_root = (XPV*)xpv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpv; } -static void +STATIC void del_xpv(XPV *p) { - p->xpv_pv = (char*)xpv_root; - xpv_root = p; + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpv_root; + PL_xpv_root = p; + UNLOCK_SV_MUTEX; } -static XPV* +STATIC void more_xpv(void) { register XPV* xpv; register XPV* xpvend; - New(713, xpv_root, 1008/sizeof(XPV), XPV); - xpv = xpv_root; + New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); + xpv = PL_xpv_root; xpvend = &xpv[1008 / sizeof(XPV) - 1]; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); xpv++; } xpv->xpv_pv = 0; - return new_xpv(); } #ifdef PURIFY @@ -590,9 +605,9 @@ more_xpv(void) #ifdef PURIFY # define my_safemalloc(s) safemalloc(s) -# define my_safefree(s) free(s) +# define my_safefree(s) safefree(s) #else -static void* +STATIC void* my_safemalloc(MEM_SIZE size) { char *p; @@ -681,7 +696,7 @@ sv_upgrade(register SV *sv, U32 mt) cur = 0; len = 0; nv = SvNVX(sv); - iv = I_32(nv); + iv = I_V(nv); magic = 0; stash = 0; del_XNV(SvANY(sv)); @@ -909,154 +924,6 @@ sv_upgrade(register SV *sv, U32 mt) return TRUE; } -#ifdef DEBUGGING -char * -sv_peek(SV *sv) -{ - SV *t = sv_newmortal(); - STRLEN prevlen; - int unref = 0; - - sv_setpvn(t, "", 0); - retry: - if (!sv) { - sv_catpv(t, "VOID"); - goto finish; - } - else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { - sv_catpv(t, "WILD"); - goto finish; - } - else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) { - if (sv == &sv_undef) { - sv_catpv(t, "SV_UNDEF"); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - else if (sv == &sv_no) { - sv_catpv(t, "SV_NO"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 0 && - SvNVX(sv) == 0.0) - goto finish; - } - else { - sv_catpv(t, "SV_YES"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 1 && - SvPVX(sv) && *SvPVX(sv) == '1' && - SvNVX(sv) == 1.0) - goto finish; - } - sv_catpv(t, ":"); - } - else if (SvREFCNT(sv) == 0) { - sv_catpv(t, "("); - unref++; - } - if (SvROK(sv)) { - sv_catpv(t, "\\"); - if (SvCUR(t) + unref > 10) { - SvCUR(t) = unref + 3; - *SvEND(t) = '\0'; - sv_catpv(t, "..."); - goto finish; - } - sv = (SV*)SvRV(sv); - goto retry; - } - switch (SvTYPE(sv)) { - default: - sv_catpv(t, "FREED"); - goto finish; - - case SVt_NULL: - sv_catpv(t, "UNDEF"); - goto finish; - case SVt_IV: - sv_catpv(t, "IV"); - break; - case SVt_NV: - sv_catpv(t, "NV"); - break; - case SVt_RV: - sv_catpv(t, "RV"); - break; - case SVt_PV: - sv_catpv(t, "PV"); - break; - case SVt_PVIV: - sv_catpv(t, "PVIV"); - break; - case SVt_PVNV: - sv_catpv(t, "PVNV"); - break; - case SVt_PVMG: - sv_catpv(t, "PVMG"); - break; - case SVt_PVLV: - sv_catpv(t, "PVLV"); - break; - case SVt_PVAV: - sv_catpv(t, "AV"); - break; - case SVt_PVHV: - sv_catpv(t, "HV"); - break; - case SVt_PVCV: - if (CvGV(sv)) - sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv))); - else - sv_catpv(t, "CV()"); - goto finish; - case SVt_PVGV: - sv_catpv(t, "GV"); - break; - case SVt_PVBM: - sv_catpv(t, "BM"); - break; - case SVt_PVFM: - sv_catpv(t, "FM"); - break; - case SVt_PVIO: - sv_catpv(t, "IO"); - break; - } - - if (SvPOKp(sv)) { - if (!SvPVX(sv)) - sv_catpv(t, "(null)"); - if (SvOOK(sv)) - sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv)); - else - sv_catpvf(t, "(\"%.127s\")",SvPVX(sv)); - } - else if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - sv_catpvf(t, "(%g)",SvNVX(sv)); - } - else if (SvIOKp(sv)) - sv_catpvf(t, "(%ld)",(long)SvIVX(sv)); - else - sv_catpv(t, "()"); - - finish: - if (unref) { - while (unref--) - sv_catpv(t, ")"); - } - return SvPV(t, na); -} -#endif - int sv_backoff(register SV *sv) { @@ -1073,11 +940,7 @@ sv_backoff(register SV *sv) } char * -#ifndef DOSISH -sv_grow(register SV *sv, register I32 newlen) -#else -sv_grow(SV* sv, unsigned long newlen) -#endif +sv_grow(register SV *sv, register STRLEN newlen) { register char *s; @@ -1106,8 +969,16 @@ sv_grow(SV* sv, unsigned long newlen) else s = SvPVX(sv); if (newlen > SvLEN(sv)) { /* need more room? */ - if (SvLEN(sv) && s) + if (SvLEN(sv) && s) { +#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) + STRLEN l = malloced_size((void*)SvPVX(sv)); + if (newlen <= l) { + SvLEN_set(sv, l); + return s; + } else +#endif Renew(s,newlen,char); + } else New(703,s,newlen,char); SvPV_set(sv, s); @@ -1133,11 +1004,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: @@ -1146,7 +1012,7 @@ sv_setiv(register SV *sv, IV i) { dTHR; croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), - op_desc[op->op_type]); + PL_op_desc[PL_op->op_type]); } } (void)SvIOK_only(sv); /* validate number */ @@ -1164,10 +1030,9 @@ sv_setiv_mg(register SV *sv, IV i) void sv_setuv(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 @@ -1190,20 +1055,9 @@ sv_setnv(register SV *sv, double num) case SVt_PV: case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); - /* FALL THROUGH */ - case SVt_PVNV: - case SVt_PVMG: - case SVt_PVBM: - case SVt_PVLV: - if (SvOOK(sv)) - (void)SvOOK_off(sv); break; + case SVt_PVGV: - if (SvFAKE(sv)) { - sv_unglob(sv); - break; - } - /* FALL THROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1212,7 +1066,7 @@ sv_setnv(register SV *sv, double num) { dTHR; croak("Can't coerce %s to number in %s", sv_reftype(sv,0), - op_name[op->op_type]); + PL_op_name[PL_op->op_type]); } } SvNVX(sv) = num; @@ -1227,7 +1081,7 @@ sv_setnv_mg(register SV *sv, double num) SvSETMAGIC(sv); } -static void +STATIC void not_a_number(SV *sv) { dTHR; @@ -1275,13 +1129,22 @@ not_a_number(SV *sv) } *d = '\0'; - if (op) - warn("Argument \"%s\" isn't numeric in %s", tmpbuf, - op_name[op->op_type]); + if (PL_op) + warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, + PL_op_name[PL_op->op_type]); else - warn("Argument \"%s\" isn't numeric", tmpbuf); + warner(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) { @@ -1292,76 +1155,137 @@ 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); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(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)); + return I_V(SvNVX(sv)); } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(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) < (double)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. */ + double d; + + SET_NUMERIC_STANDARD(); + 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) + 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 (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(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 @@ -1378,21 +1302,19 @@ sv_2uv(register SV *sv) if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(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)) { @@ -1401,41 +1323,129 @@ sv_2uv(register SV *sv) } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(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. */ + double d; + + SET_NUMERIC_STANDARD(); + d = atof(SvPVX(sv)); /* XXXX 64-bit? */ + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%lx 2nv(%g)\n",(unsigned long)sv, + SvNVX(sv))); + if (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 (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(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 @@ -1448,42 +1458,50 @@ sv_2nv(register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + dTHR; + 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 (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (double)SvUVX(sv); + else + return (double)SvIVX(sv); + } if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(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 SvNV(tmpstr); return (double)(unsigned long)SvRV(sv); } if (SvREADONLY(sv)) { + dTHR; if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(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 (dowarn) - warn(warn_uninit); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (double)SvUVX(sv); + else + return (double)SvIVX(sv); + } + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; } } @@ -1501,18 +1519,22 @@ sv_2nv(register SV *sv) if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { - SvNVX(sv) = (double)SvIVX(sv); + SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + dTHR; + if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(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); @@ -1522,46 +1544,65 @@ sv_2nv(register SV *sv) return SvNVX(sv); } -static IV +STATIC IV asIV(SV *sv) { I32 numtype = looks_like_number(sv); double d; - if (numtype == 1) - return atol(SvPVX(sv)); - if (!numtype && dowarn) - not_a_number(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); + return I_V(d); } -static UV +STATIC UV asUV(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 && dowarn) - not_a_number(sv); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } SET_NUMERIC_STANDARD(); 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) { + /* 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)) { @@ -1577,22 +1618,40 @@ 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++; + nbegin = s; + /* + * we return 1 if the number can be converted to _integer_ with atol() + * and 2 if you need (int)atof(). + */ + /* next must be digit or '.' */ if (isDIGIT(*s)) { do { s++; } while (isDIGIT(*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 == '.') { s++; + numtype |= IS_NUMBER_NOT_IV; while (isDIGIT(*s)) /* optional digits after "." */ s++; } } else if (*s == '.') { s++; + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; /* no digits before '.' means we need digits after it */ if (isDIGIT(*s)) { do { @@ -1605,15 +1664,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++; @@ -1630,17 +1684,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_nolen(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 * sv_2pv(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; @@ -1652,8 +1742,11 @@ 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; } @@ -1664,10 +1757,10 @@ sv_2pv(register SV *sv, STRLEN *lp) goto tokensave; } if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, PL_warn_uninit); } *lp = 0; return ""; @@ -1675,16 +1768,61 @@ 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"; else { + MAGIC *mg; + switch (SvTYPE(sv)) { + case SVt_PVMG: + if ( ((SvFLAGS(sv) & + (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|SVs_RMG)) + && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") + && (mg = mg_find(sv, 'r'))) { + dTHR; + regexp *re = (regexp *)mg->mg_obj; + + if (!mg->mg_ptr) { + char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; + + while(ch = *fptr++) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); + Copy("(?", mg->mg_ptr, 2, char); + Copy(reflags, mg->mg_ptr+2, left, char); + Copy(":", mg->mg_ptr+left+2, 1, char); + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; + } + PL_reginterp_cnt += re->program[0].next_off; + *lp = mg->mg_len; + return mg->mg_ptr; + } + /* Fall through */ case SVt_NULL: case SVt_IV: case SVt_NV: @@ -1692,14 +1830,13 @@ sv_2pv(register SV *sv, STRLEN *lp) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: - case SVt_PVMG: s = "SCALAR"; break; + case SVt_PVBM: s = "SCALAR"; break; case SVt_PVLV: s = "LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMLINE"; break; + case SVt_PVFM: s = "FORMAT"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } @@ -1708,6 +1845,7 @@ sv_2pv(register SV *sv, STRLEN *lp) sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); + /* XXXX 64-bit? */ sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); goto tokensaveref; } @@ -1715,25 +1853,35 @@ sv_2pv(register SV *sv, STRLEN *lp) return s; } if (SvREADONLY(sv)) { - if (SvNOKp(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)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(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; } - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(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); @@ -1760,23 +1908,35 @@ sv_2pv(register SV *sv, STRLEN *lp) #endif } else if (SvIOKp(sv)) { - U32 oldIOK = SvIOK(sv); + U32 isIOK = SvIOK(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 (SvIsUV(sv)) { + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + sv_setpvn(sv, ptr, ebuf - ptr); + SvIsUV_on(sv); + } + else { + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + sv_setpvn(sv, ptr, ebuf - ptr); + } s = SvEND(sv); - if (oldIOK) + if (isIOK) SvIOK_on(sv); else SvIOKp_on(sv); } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(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); @@ -1835,14 +1995,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)) { @@ -1884,44 +2040,65 @@ sv_setsv(SV *dstr, register SV *sstr) return; SV_CHECK_THINKFIRST(dstr); if (!sstr) - sstr = &sv_undef; + sstr = &PL_sv_undef; 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) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + undef_sstr: + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: - if (dtype != SVt_IV && dtype < SVt_PVIV) { - if (dtype < SVt_IV) + if (SvIOK(sstr)) { + switch (dtype) { + case SVt_NULL: sv_upgrade(dstr, SVt_IV); - else if (dtype == SVt_NV) + break; + case SVt_NV: sv_upgrade(dstr, SVt_PVNV); - else + break; + case SVt_RV: + case SVt_PV: sv_upgrade(dstr, SVt_PVIV); + break; + } + (void)SvIOK_only(dstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_NV: - if (dtype != SVt_NV && dtype < SVt_PVNV) { - if (dtype < SVt_NV) + if (SvNOK(sstr)) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: sv_upgrade(dstr, SVt_NV); - else + break; + case SVt_RV: + case SVt_PV: + case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); + break; + } + SvNVX(dstr) = SvNVX(sstr); + (void)SvNOK_only(dstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_RV: if (dtype < SVt_RV) sv_upgrade(dstr, SVt_RV); @@ -1929,7 +2106,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -1954,9 +2131,9 @@ sv_setsv(SV *dstr, register SV *sstr) case SVt_PVHV: case SVt_PVCV: case SVt_PVIO: - if (op) + if (PL_op) croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), - op_name[op->op_type]); + PL_op_name[PL_op->op_type]); else croak("Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -1975,8 +2152,8 @@ sv_setsv(SV *dstr, register SV *sstr) SvFAKE_on(dstr); /* can coerce to non-glob */ } /* ahem, death to those who redefine active sort subs */ - else if (curstackinfo->si_type == SI_SORT - && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) + else if (PL_curstackinfo->si_type == PERLSI_SORT + && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); @@ -1984,7 +2161,7 @@ sv_setsv(SV *dstr, register SV *sstr) gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -2001,9 +2178,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); @@ -2011,7 +2188,6 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - dTHR; SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; int intro = GvINTRO(dstr); @@ -2023,7 +2199,7 @@ sv_setsv(SV *dstr, register SV *sstr) Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); GvSV(dstr) = NEWSV(72,0); - GvLINE(dstr) = curcop->cop_line; + GvLINE(dstr) = PL_curcop->cop_line; GvEGV(dstr) = (GV*)dstr; } GvMULTI_on(dstr); @@ -2034,7 +2210,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_AV_on(dstr); break; case SVt_PVHV: @@ -2043,7 +2219,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: @@ -2052,7 +2228,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = Nullcv; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - sub_generation++; + PL_sub_generation++; } SAVESPTR(GvCV(dstr)); } @@ -2064,22 +2240,27 @@ sv_setsv(SV *dstr, register SV *sstr) if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { + SV *const_sv = cv_const_sv(cv); + bool const_changed = TRUE; + if(const_sv) + const_changed = sv_cmp(const_sv, + op_const_sv(CvSTART((CV*)sref), + Nullcv)); /* ahem, death to those who redefine * active sort subs */ - if (curstackinfo->si_type == SI_SORT && - sortcop == CvSTART(cv)) + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) croak( "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if (cv_const_sv(cv)) - warn("Constant subroutine %s redefined", - GvENAME((GV*)dstr)); - else if (dowarn) { + if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) { if (!(CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) - warn("Subroutine %s redefined", + warner(WARN_REDEFINE, const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", GvENAME((GV*)dstr)); } } @@ -2089,9 +2270,9 @@ sv_setsv(SV *dstr, register SV *sstr) GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - sub_generation++; + PL_sub_generation++; } - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_CV_on(dstr); break; case SVt_PVIO: @@ -2107,7 +2288,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_SV_on(dstr); break; } @@ -2120,7 +2301,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; } } @@ -2134,12 +2316,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) { @@ -2159,7 +2341,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); @@ -2190,6 +2372,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) { @@ -2198,14 +2382,24 @@ 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 { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } @@ -2228,12 +2422,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); @@ -2262,12 +2451,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); @@ -2292,7 +2476,8 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) (void)SvOK_off(sv); return; } - if (SvPVX(sv)) + (void)SvOOK_off(sv); + if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); SvPVX(sv) = ptr; @@ -2310,16 +2495,18 @@ sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) SvSETMAGIC(sv); } -static void -sv_check_thinkfirst(register SV *sv) +void +sv_force_normal(register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); } if (SvROK(sv)) sv_unref(sv); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + sv_unglob(sv); } void @@ -2336,10 +2523,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; @@ -2348,7 +2542,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) +sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len) { STRLEN tlen; char *junk; @@ -2365,7 +2559,7 @@ sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) } void -sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len) +sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len) { sv_catpvn(sv,ptr,len); SvSETMAGIC(sv); @@ -2390,7 +2584,7 @@ sv_catsv_mg(SV *dstr, register SV *sstr) } void -sv_catpv(register SV *sv, register char *ptr) +sv_catpv(register SV *sv, register const char *ptr) { register STRLEN len; STRLEN tlen; @@ -2410,25 +2604,18 @@ sv_catpv(register SV *sv, register char *ptr) } void -sv_catpv_mg(register SV *sv, register char *ptr) +sv_catpv_mg(register SV *sv, register const char *ptr) { sv_catpv(sv,ptr); SvSETMAGIC(sv); } SV * -#ifdef LEAKTEST -newSV(I32 x, STRLEN len) -#else newSV(STRLEN len) -#endif { 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); @@ -2439,14 +2626,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) +sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) { MAGIC* mg; if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling && !strchr("gBf", how)) - croak(no_modify); + if (PL_curcop != &PL_compiling && !strchr("gBf", how)) + croak(PL_no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2479,100 +2666,107 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) switch (how) { case 0: - mg->mg_virtual = &vtbl_sv; + mg->mg_virtual = &PL_vtbl_sv; break; -#ifdef OVERLOAD case 'A': - mg->mg_virtual = &vtbl_amagic; + mg->mg_virtual = &PL_vtbl_amagic; break; case 'a': - mg->mg_virtual = &vtbl_amagicelem; + mg->mg_virtual = &PL_vtbl_amagicelem; break; case 'c': mg->mg_virtual = 0; break; -#endif /* OVERLOAD */ case 'B': - mg->mg_virtual = &vtbl_bm; + mg->mg_virtual = &PL_vtbl_bm; + break; + case 'D': + mg->mg_virtual = &PL_vtbl_regdata; + break; + case 'd': + mg->mg_virtual = &PL_vtbl_regdatum; break; case 'E': - mg->mg_virtual = &vtbl_env; + mg->mg_virtual = &PL_vtbl_env; break; case 'f': - mg->mg_virtual = &vtbl_fm; + mg->mg_virtual = &PL_vtbl_fm; break; case 'e': - mg->mg_virtual = &vtbl_envelem; + mg->mg_virtual = &PL_vtbl_envelem; break; case 'g': - mg->mg_virtual = &vtbl_mglob; + mg->mg_virtual = &PL_vtbl_mglob; break; case 'I': - mg->mg_virtual = &vtbl_isa; + mg->mg_virtual = &PL_vtbl_isa; break; case 'i': - mg->mg_virtual = &vtbl_isaelem; + mg->mg_virtual = &PL_vtbl_isaelem; break; case 'k': - mg->mg_virtual = &vtbl_nkeys; + mg->mg_virtual = &PL_vtbl_nkeys; break; case 'L': SvRMAGICAL_on(sv); mg->mg_virtual = 0; break; case 'l': - mg->mg_virtual = &vtbl_dbline; + mg->mg_virtual = &PL_vtbl_dbline; break; #ifdef USE_THREADS case 'm': - mg->mg_virtual = &vtbl_mutex; + mg->mg_virtual = &PL_vtbl_mutex; break; #endif /* USE_THREADS */ #ifdef USE_LOCALE_COLLATE case 'o': - mg->mg_virtual = &vtbl_collxfrm; + mg->mg_virtual = &PL_vtbl_collxfrm; break; #endif /* USE_LOCALE_COLLATE */ case 'P': - mg->mg_virtual = &vtbl_pack; + mg->mg_virtual = &PL_vtbl_pack; break; case 'p': case 'q': - mg->mg_virtual = &vtbl_packelem; + mg->mg_virtual = &PL_vtbl_packelem; break; case 'r': - mg->mg_virtual = &vtbl_regexp; + mg->mg_virtual = &PL_vtbl_regexp; break; case 'S': - mg->mg_virtual = &vtbl_sig; + mg->mg_virtual = &PL_vtbl_sig; break; case 's': - mg->mg_virtual = &vtbl_sigelem; + mg->mg_virtual = &PL_vtbl_sigelem; break; case 't': - mg->mg_virtual = &vtbl_taint; + mg->mg_virtual = &PL_vtbl_taint; mg->mg_len = 1; break; case 'U': - mg->mg_virtual = &vtbl_uvar; + mg->mg_virtual = &PL_vtbl_uvar; break; case 'v': - mg->mg_virtual = &vtbl_vec; + mg->mg_virtual = &PL_vtbl_vec; break; case 'x': - mg->mg_virtual = &vtbl_substr; + mg->mg_virtual = &PL_vtbl_substr; break; case 'y': - mg->mg_virtual = &vtbl_defelem; + mg->mg_virtual = &PL_vtbl_defelem; break; case '*': - mg->mg_virtual = &vtbl_glob; + mg->mg_virtual = &PL_vtbl_glob; break; case '#': - mg->mg_virtual = &vtbl_arylen; + mg->mg_virtual = &PL_vtbl_arylen; break; case '.': - mg->mg_virtual = &vtbl_pos; + 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. */ @@ -2600,8 +2794,8 @@ sv_unmagic(SV *sv, int type) if (mg->mg_type == type) { MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - (*vtbl->svt_free)(sv, mg); + if (vtbl && (vtbl->svt_free != NULL)) + (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2622,6 +2816,63 @@ sv_unmagic(SV *sv, int type) return 0; } +SV * +sv_rvweaken(SV *sv) +{ + SV *tsv; + if (!SvOK(sv)) /* let undefs pass */ + return sv; + if (!SvROK(sv)) + croak("Can't weaken a nonreference"); + else if (SvWEAKREF(sv)) { + dTHR; + if (ckWARN(WARN_MISC)) + warner(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 +sv_add_backref(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 +sv_del_backref(SV *sv) +{ + AV *av; + SV **svp; + I32 i; + SV *tsv = SvRV(sv); + MAGIC *mg; + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<'))) + croak("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) { @@ -2630,10 +2881,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } i = littlelen - len; if (i > 0) { /* string might grow */ @@ -2735,50 +2993,53 @@ sv_clear(register SV *sv) if (SvOBJECT(sv)) { dTHR; - if (defstash) { /* Still have a symbol table? */ + if (PL_defstash) { /* Still have a symbol table? */ djSP; GV* destructor; - SV ref; + SV tmpref; - Zero(&ref, 1, SV); - sv_upgrade(&ref, SVt_RV); - SvROK_on(&ref); - SvREADONLY_on(&ref); /* DESTROY() could be naughty */ - SvREFCNT(&ref) = 1; + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; do { stash = SvSTASH(sv); destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); if (destructor) { ENTER; - PUSHSTACK(SI_DESTROY); - SvRV(&ref) = SvREFCNT_inc(sv); + PUSHSTACKi(PERLSI_DESTROY); + SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); - PUSHs(&ref); + PUSHs(&tmpref); PUTBACK; perl_call_sv((SV*)GvCV(destructor), G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; - POPSTACK(); + POPSTACK; + SPAGAIN; LEAVE; } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - del_XRV(SvANY(&ref)); + del_XRV(SvANY(&tmpref)); + + if (SvREFCNT(sv)) { + if (PL_in_clean_objs) + croak("DESTROY created new reference to dead object '%s'", + HvNAME(stash)); + /* DESTROY gave object new lease on life */ + return; + } } if (SvOBJECT(sv)) { SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ if (SvTYPE(sv) != SVt_PVIO) - --sv_objcount; /* XXX Might want something more general */ - } - if (SvREFCNT(sv)) { - if (in_clean_objs) - croak("DESTROY created new reference to dead object"); - /* DESTROY gave object new lease on life */ - return; + --PL_sv_objcount; /* XXX Might want something more general */ } } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) @@ -2786,10 +3047,17 @@ sv_clear(register SV *sv) stash = NULL; switch (SvTYPE(sv)) { case SVt_PVIO: - if (IoIFP(sv) != PerlIO_stdin() && + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) + { io_close((IO*)sv); + } + if (IoDIRP(sv)) { + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = 0; + } Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2806,6 +3074,9 @@ sv_clear(register SV *sv) case SVt_PVAV: av_undef((AV*)sv); break; + case SVt_PVLV: + SvREFCNT_dec(LvTARG(sv)); + goto freescalar; case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); @@ -2815,7 +3086,6 @@ sv_clear(register SV *sv) -- JohnPC, 27 Mar 1998 */ stash = GvSTASH(sv); /* FALL THROUGH */ - case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -2824,8 +3094,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; @@ -2911,15 +3185,16 @@ sv_free(SV *sv) if (!sv) return; - if (SvREADONLY(sv)) { - if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) - return; - } if (SvREFCNT(sv) == 0) { if (SvFLAGS(sv) & SVf_BREAK) return; - if (in_clean_all) /* All is fair */ + if (PL_in_clean_all) /* All is fair */ + return; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; return; + } warn("Attempt to free unreferenced scalar"); return; } @@ -2928,29 +3203,117 @@ sv_free(SV *sv) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); + warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + return; + } +#endif + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } + sv_clear(sv); + if (! SvREFCNT(sv)) + del_SV(sv); +} + +STRLEN +sv_len(register SV *sv) +{ + char *junk; + STRLEN len; + + if (!sv) + return 0; + + if (SvGMAGICAL(sv)) + len = mg_length(sv); + else + junk = SvPV(sv, len); + return len; +} + +STRLEN +sv_len_utf8(register SV *sv) +{ + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return 0; + +#ifdef NOTYET + if (SvGMAGICAL(sv)) + len = mg_length(sv); + else +#endif + s = (U8*)SvPV(sv, len); + send = s + len; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + len++; + } + return len; +} + +void +sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) +{ + U8 *start; + U8 *s; + U8 *send; + I32 uoffset = *offsetp; + STRLEN len; + + if (!sv) return; - } -#endif - sv_clear(sv); - if (! SvREFCNT(sv)) - del_SV(sv); + + start = s = (U8*)SvPV(sv, len); + send = s + len; + while (s < send && uoffset--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + *offsetp = s - start; + if (lenp) { + I32 ulen = *lenp; + start = s; + while (s < send && ulen--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + *lenp = s - start; + } + return; } -STRLEN -sv_len(register SV *sv) +void +sv_pos_b2u(register SV *sv, I32* offsetp) { - char *junk; + U8 *s; + U8 *send; STRLEN len; if (!sv) - return 0; + return; - if (SvGMAGICAL(sv)) - len = mg_len(sv); - else - junk = SvPV(sv, len); - return len; + s = (U8*)SvPV(sv, len); + if (len < *offsetp) + croak("panic: bad byte offset"); + send = s + *offsetp; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + ++len; + } + if (s != send) { + warn("Malformed UTF-8 character"); + --len; + } + *offsetp = len; + return; } I32 @@ -3014,7 +3377,7 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) STRLEN len1, len2; I32 retval; - if (collation_standard) + if (PL_collation_standard) goto raw_compare; len1 = 0; @@ -3066,7 +3429,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) MAGIC *mg; mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; - if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { + if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { char *s, *xf; STRLEN len, xlen; @@ -3077,7 +3440,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) if (SvREADONLY(sv)) { SAVEFREEPV(xf); *nxp = xlen; - return xf + sizeof(collation_ix); + return xf + sizeof(PL_collation_ix); } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); @@ -3096,7 +3459,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) } if (mg && mg->mg_ptr) { *nxp = mg->mg_len; - return mg->mg_ptr + sizeof(collation_ix); + return mg->mg_ptr + sizeof(PL_collation_ix); } else { *nxp = 0; @@ -3119,21 +3482,43 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) SV_CHECK_THINKFIRST(sv); (void)SvUPGRADE(sv, SVt_PV); + SvSCREAM_off(sv); - if (RsSNARF(rs)) { + if (RsSNARF(PL_rs)) { rsptr = NULL; rslen = 0; } - else if (RsPARA(rs)) { + else if (RsRECORD(PL_rs)) { + I32 recsize, bytesread; + char *buffer; + + /* Grab the size of the record we're getting */ + recsize = SvIV(SvRV(PL_rs)); + (void)SvPOK_only(sv); /* Validate pointer */ + buffer = SvGROW(sv, recsize + 1); + /* Go yank in */ +#ifdef VMS + /* VMS wants read instead of fread, because fread doesn't respect */ + /* RMS record boundaries. This is not necessarily a good thing to be */ + /* doing, but we've got no other real choice */ + bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); +#else + bytesread = PerlIO_read(fp, buffer, recsize); +#endif + SvCUR_set(sv, bytesread); + buffer[bytesread] = '\0'; + return(SvCUR(sv) ? SvPVX(sv) : Nullch); + } + else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } else - rsptr = SvPV(rs, rslen); + rsptr = SvPV(PL_rs, rslen); rslast = rslen ? rsptr[rslen - 1] : '\0'; - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ if (PerlIO_eof(fp)) return 0; @@ -3330,7 +3715,7 @@ screamer2: } } - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ i = PerlIO_getc(fp); if (i != '\n') { @@ -3356,21 +3741,23 @@ sv_inc(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); } if (SvROK(sv)) { -#ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; -#endif /* OVERLOAD */ - sv_unref(sv); + IV i; + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) + return; + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } - if (SvGMAGICAL(sv)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { (void)SvNOK_only(sv); @@ -3378,11 +3765,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, (double)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); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } } return; } @@ -3409,10 +3804,24 @@ sv_inc(register SV *sv) *(d--) = '0'; } else { +#ifdef EBCDIC + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (*d != 'z' && *d != 'Z') { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; +#else ++*d; if (isALPHA(*d)) return; *(d--) -= 'z' - 'a' + 1; +#endif } } /* oh,oh, the number grew */ @@ -3433,21 +3842,23 @@ sv_dec(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); } if (SvROK(sv)) { -#ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; -#endif /* OVERLOAD */ - sv_unref(sv); + IV i; + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) + return; + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } - if (SvGMAGICAL(sv)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; @@ -3455,11 +3866,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, (double)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } } return; } @@ -3479,14 +3901,6 @@ 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; - tmps_max += (tmps_max < 512) ? 128 : 512; - Renew(tmps_stack, tmps_max, SV*); -} - SV * sv_mortalcopy(SV *oldstr) { @@ -3494,13 +3908,9 @@ sv_mortalcopy(SV *oldstr) register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setsv(sv,oldstr); - if (++tmps_ix >= tmps_max) - sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } @@ -3512,12 +3922,9 @@ sv_newmortal(void) register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; - if (++tmps_ix >= tmps_max) - sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; return sv; } @@ -3529,24 +3936,20 @@ sv_2mortal(register SV *sv) dTHR; if (!sv) return sv; - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (++tmps_ix >= tmps_max) - sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) + return sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } SV * -newSVpv(char *s, STRLEN len) +newSVpv(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); @@ -3554,43 +3957,23 @@ newSVpv(char *s, STRLEN len) } SV * -newSVpvn(s,len) -char *s; -STRLEN len; +newSVpvn(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; } -#ifdef I_STDARG SV * newSVpvf(const char* pat, ...) -#else -/*VARARGS0*/ -SV * -newSVpvf(pat, va_alist) -const char *pat; -va_dcl -#endif { register SV *sv; va_list args; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); return sv; @@ -3603,9 +3986,6 @@ newSVnv(double n) register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setnv(sv,n); return sv; } @@ -3616,40 +3996,28 @@ newSViv(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(SV *ref) +newRV_noinc(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(ref); - SvRV(sv) = SvREFCNT_inc(ref); + SvTEMP_off(tmpRef); + SvRV(sv) = tmpRef; SvROK_on(sv); return sv; } - - SV * -Perl_newRV_noinc(SV *ref) +newRV(SV *tmpRef) { - register SV *sv; - - sv = newRV(ref); - SvREFCNT_dec(ref); - return sv; + return newRV_noinc(SvREFCNT_inc(tmpRef)); } /* make an exact duplicate of old */ @@ -3666,9 +4034,6 @@ newSVsv(register SV *old) return Nullsv; } new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (SvTEMP(old)) { SvTEMP_off(old); sv_setsv(sv,old); @@ -3695,7 +4060,7 @@ sv_reset(register char *s, HV *stash) if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -3717,12 +4082,18 @@ sv_reset(register char *s, HV *stash) } for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) { + entry; + entry = HeNEXT(entry)) + { if (!todo[(U8)*HeKEY(entry)]) continue; gv = (GV*)HeVAL(entry); sv = GvSV(gv); + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + continue; + } (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); @@ -3736,7 +4107,7 @@ sv_reset(register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef VMS /* VMS has no environ array */ - if (gv == envgv) + if (gv == PL_envgv) environ[0] = Nullch; #endif } @@ -3750,6 +4121,7 @@ sv_2io(SV *sv) { IO* io; GV* gv; + STRLEN n_a; switch (SvTYPE(sv)) { case SVt_PVIO: @@ -3763,16 +4135,16 @@ sv_2io(SV *sv) break; default: if (!SvOK(sv)) - croak(no_usym, "filehandle"); + croak(PL_no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); + gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,na)); + croak("Bad filehandle: %s", SvPV(sv,n_a)); break; } return io; @@ -3783,6 +4155,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; + STRLEN n_a; if (!sv) return *gvp = Nullgv, Nullcv; @@ -3805,17 +4178,26 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) != SVt_PVCV) + dTHR; + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVCV) { + cv = (CV*)sv; + *gvp = Nullgv; + *st = CvSTASH(cv); + return cv; + } + else if(isGV(sv)) + gv = (GV*)sv; + else croak("Not a subroutine reference"); - *gvp = Nullgv; - *st = CvSTASH(cv); - return cv; } - if (isGV(sv)) + else if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV); + gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -3826,13 +4208,16 @@ 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,na)); + croak("Unable to create sub named \"%s\"", SvPV(sv,n_a)); } return GvCVu(gv); } @@ -3869,16 +4254,22 @@ sv_true(register SV *sv) IV sv_iv(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) { - if (SvIOK(sv)) - return SvUVX(sv); + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); + } return sv_2uv(sv); } @@ -3891,6 +4282,17 @@ sv_nv(register SV *sv) } char * +sv_pv(SV *sv) +{ + STRLEN n_a; + + if (SvPOK(sv)) + return SvPVX(sv); + + return sv_2pv(sv, &n_a); +} + +char * sv_pvn(SV *sv, STRLEN *lp) { if (SvPOK(sv)) { @@ -3905,27 +4307,17 @@ sv_pvn_force(SV *sv, STRLEN *lp) { char *s; - if (SvREADONLY(sv)) { - dTHR; - if (curcop != &compiling) - croak(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), - op_name[op->op_type]); - } + dTHR; + croak("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); @@ -3975,7 +4367,7 @@ sv_reftype(SV *sv, int ob) case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; - case SVt_PVFM: return "FORMLINE"; + case SVt_PVFM: return "FORMAT"; default: return "UNKNOWN"; } } @@ -3997,7 +4389,7 @@ sv_isobject(SV *sv) } int -sv_isa(SV *sv, char *name) +sv_isa(SV *sv, const char *name) { if (!sv) return 0; @@ -4013,26 +4405,21 @@ sv_isa(SV *sv, char *name) } SV* -newSVrv(SV *rv, char *classname) +newSVrv(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) { @@ -4043,10 +4430,10 @@ newSVrv(SV *rv, char *classname) } SV* -sv_setref_pv(SV *rv, char *classname, void *pv) +sv_setref_pv(SV *rv, const char *classname, void *pv) { if (!pv) { - sv_setsv(rv, &sv_undef); + sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); } else @@ -4055,21 +4442,21 @@ sv_setref_pv(SV *rv, char *classname, void *pv) } SV* -sv_setref_iv(SV *rv, char *classname, IV iv) +sv_setref_iv(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) +sv_setref_nv(SV *rv, const char *classname, double nv) { sv_setnv(newSVrv(rv,classname), nv); return rv; } SV* -sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n) +sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n) { sv_setpvn(newSVrv(rv,classname), pv, n); return rv; @@ -4079,42 +4466,44 @@ SV* sv_bless(SV *sv, HV *stash) { dTHR; - SV *ref; + SV *tmpRef; if (!SvROK(sv)) croak("Can't bless non-reference value"); - ref = SvRV(sv); - if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) { - if (SvREADONLY(ref)) - croak(no_modify); - if (SvOBJECT(ref)) { - if (SvTYPE(ref) != SVt_PVIO) - --sv_objcount; - SvREFCNT_dec(SvSTASH(ref)); + tmpRef = SvRV(sv); + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(tmpRef)) + croak(PL_no_modify); + if (SvOBJECT(tmpRef)) { + if (SvTYPE(tmpRef) != SVt_PVIO) + --PL_sv_objcount; + SvREFCNT_dec(SvSTASH(tmpRef)); } } - SvOBJECT_on(ref); - if (SvTYPE(ref) != SVt_PVIO) - ++sv_objcount; - (void)SvUPGRADE(ref, SVt_PVMG); - SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); + SvOBJECT_on(tmpRef); + if (SvTYPE(tmpRef) != SVt_PVIO) + ++PL_sv_objcount; + (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 +STATIC void sv_unglob(SV *sv) { assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); if (GvGP(sv)) gp_free((GV*)sv); + if (GvSTASH(sv)) { + SvREFCNT_dec(GvSTASH(sv)); + GvSTASH(sv) = Nullhv; + } sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); GvMULTI_off(sv); @@ -4126,7 +4515,13 @@ void sv_unref(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)) @@ -4165,130 +4560,59 @@ sv_tainted(SV *sv) void sv_setpviv(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) { - 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); } -#ifdef I_STDARG void sv_setpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_setpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); } -#ifdef I_STDARG void sv_setpvf_mg(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_setpvf_mg(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); SvSETMAGIC(sv); } -#ifdef I_STDARG void sv_catpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_catpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); } -#ifdef I_STDARG void sv_catpvf_mg(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_catpvf_mg(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); SvSETMAGIC(sv); @@ -4351,15 +4675,12 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, STRLEN precis = 0; char esignbuf[4]; + U8 utf8buf[10]; STRLEN esignlen = 0; char *eptr = Nullch; STRLEN elen = 0; char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */ - - static char *efloatbuf = Nullch; - static STRLEN efloatsize = 0; - char c; int i; unsigned base; @@ -4479,6 +4800,16 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto string; case 'c': + if (IN_UTF8) { + if (args) + uv = va_arg(*args, int); + else + uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + + eptr = (char*)utf8buf; + elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; + goto string; + } if (args) c = va_arg(*args, int); else @@ -4497,8 +4828,19 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, elen = sizeof nullstr - 1; } } - else if (svix < svmax) + else if (svix < svmax) { eptr = SvPVx(svargs[svix++], elen); + if (IN_UTF8) { + if (has_precis && precis < elen) { + I32 p = precis; + sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ + precis = p; + } + if (width) { /* fudge width (can't fudge elen) */ + width += elen - sv_len_utf8(svargs[svix - 1]); + } + } + } goto string; case '_': @@ -4567,6 +4909,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, base = 10; goto uns_integer; + case 'b': + base = 2; + goto uns_integer; + case 'O': intsize = 'l'; /* FALL THROUGH */ @@ -4622,6 +4968,14 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, if (alt && *eptr != '0') *--eptr = '0'; break; + case 2: + do { + dig = uv & 1; + *--eptr = '0' + dig; + } while (uv >>= 1); + if (alt && *eptr != '0') + *--eptr = '0'; + break; default: /* it had better be ten or less */ do { dig = uv % base; @@ -4668,10 +5022,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, need = width; need += 20; /* fudge factor */ - if (efloatsize < need) { - Safefree(efloatbuf); - efloatsize = need + 20; /* more fudge */ - New(906, efloatbuf, efloatsize, char); + if (PL_efloatsize < need) { + Safefree(PL_efloatbuf); + PL_efloatsize = need + 20; /* more fudge */ + New(906, PL_efloatbuf, PL_efloatsize, char); } eptr = ebuf + sizeof ebuf; @@ -4696,10 +5050,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, *--eptr = '#'; *--eptr = '%'; - (void)sprintf(efloatbuf, eptr, nv); + (void)sprintf(PL_efloatbuf, eptr, nv); - eptr = efloatbuf; - elen = strlen(efloatbuf); + eptr = PL_efloatbuf; + elen = strlen(PL_efloatbuf); #ifdef LC_NUMERIC /* @@ -4733,17 +5087,17 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: unknown: - if (!args && dowarn && - (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { + 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: ", - (op->op_type == OP_PRTF) ? "printf" : "sprintf"); + (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); if (c) sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", c & 0xFF); else sv_catpv(msg, "end of string"); - warn("%_", msg); /* yes, this is reentrant */ + warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -4796,282 +5150,3 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, SvCUR(sv) = p - SvPVX(sv); } } - -#ifdef DEBUGGING -void -sv_dump(SV *sv) -{ - SV *d = sv_newmortal(); - char *s; - U32 flags; - U32 type; - - if (!sv) { - PerlIO_printf(Perl_debug_log, "SV = 0\n"); - return; - } - - flags = SvFLAGS(sv); - type = SvTYPE(sv); - - sv_setpvf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (", - (unsigned long)SvANY(sv), (long)SvREFCNT(sv)); - if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); - if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); - if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); - if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); - if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,"); - if (flags & SVs_GMG) sv_catpv(d, "GMG,"); - if (flags & SVs_SMG) sv_catpv(d, "SMG,"); - if (flags & SVs_RMG) sv_catpv(d, "RMG,"); - - if (flags & SVf_IOK) sv_catpv(d, "IOK,"); - if (flags & SVf_NOK) sv_catpv(d, "NOK,"); - if (flags & SVf_POK) sv_catpv(d, "POK,"); - if (flags & SVf_ROK) sv_catpv(d, "ROK,"); - if (flags & SVf_OOK) sv_catpv(d, "OOK,"); - if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); - if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); - -#ifdef OVERLOAD - if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); -#endif /* OVERLOAD */ - if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); - if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); - if (flags & SVp_POK) sv_catpv(d, "pPOK,"); - if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,"); - - switch (type) { - case SVt_PVCV: - case SVt_PVFM: - if (CvANON(sv)) sv_catpv(d, "ANON,"); - if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); - if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); - if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); - if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); - break; - case SVt_PVHV: - if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); - if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); - break; - case SVt_PVGV: - if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); - if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); - if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); - if (GvIMPORTED(sv)) { - sv_catpv(d, "IMPORT"); - if (GvIMPORTED(sv) == GVf_IMPORTED) - sv_catpv(d, "ALL,"); - else { - sv_catpv(d, "("); - if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV"); - if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV"); - if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV"); - if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV"); - sv_catpv(d, " ),"); - } - } - case SVt_PVBM: - if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); - break; - } - - if (*(SvEND(d) - 1) == ',') - SvPVX(d)[--SvCUR(d)] = '\0'; - sv_catpv(d, ")"); - s = SvPVX(d); - - PerlIO_printf(Perl_debug_log, "SV = "); - switch (type) { - case SVt_NULL: - PerlIO_printf(Perl_debug_log, "NULL%s\n", s); - return; - case SVt_IV: - PerlIO_printf(Perl_debug_log, "IV%s\n", s); - break; - case SVt_NV: - PerlIO_printf(Perl_debug_log, "NV%s\n", s); - break; - case SVt_RV: - PerlIO_printf(Perl_debug_log, "RV%s\n", s); - break; - case SVt_PV: - PerlIO_printf(Perl_debug_log, "PV%s\n", s); - break; - case SVt_PVIV: - PerlIO_printf(Perl_debug_log, "PVIV%s\n", s); - break; - case SVt_PVNV: - PerlIO_printf(Perl_debug_log, "PVNV%s\n", s); - break; - case SVt_PVBM: - PerlIO_printf(Perl_debug_log, "PVBM%s\n", s); - break; - case SVt_PVMG: - PerlIO_printf(Perl_debug_log, "PVMG%s\n", s); - break; - case SVt_PVLV: - PerlIO_printf(Perl_debug_log, "PVLV%s\n", s); - break; - case SVt_PVAV: - PerlIO_printf(Perl_debug_log, "PVAV%s\n", s); - break; - case SVt_PVHV: - PerlIO_printf(Perl_debug_log, "PVHV%s\n", s); - break; - case SVt_PVCV: - PerlIO_printf(Perl_debug_log, "PVCV%s\n", s); - break; - case SVt_PVGV: - PerlIO_printf(Perl_debug_log, "PVGV%s\n", s); - break; - case SVt_PVFM: - PerlIO_printf(Perl_debug_log, "PVFM%s\n", s); - break; - case SVt_PVIO: - PerlIO_printf(Perl_debug_log, "PVIO%s\n", s); - break; - default: - PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s); - return; - } - if (type >= SVt_PVIV || type == SVt_IV) - PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); - if (type >= SVt_PVNV || type == SVt_NV) { - SET_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); - } - if (SvROK(sv)) { - PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); - sv_dump(SvRV(sv)); - return; - } - if (type < SVt_PV) - return; - if (type <= SVt_PVLV) { - if (SvPVX(sv)) - PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", - (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv)); - else - PerlIO_printf(Perl_debug_log, " PV = 0\n"); - } - if (type >= SVt_PVMG) { - if (SvMAGIC(sv)) { - PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); - } - if (SvSTASH(sv)) - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); - } - switch (type) { - case SVt_PVLV: - PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv)); - PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); - PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); - PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv)); - sv_dump(LvTARG(sv)); - break; - case SVt_PVAV: - PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); - PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv)); - PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); - PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); - flags = AvFLAGS(sv); - sv_setpv(d, ""); - if (flags & AVf_REAL) sv_catpv(d, ",REAL"); - if (flags & AVf_REIFY) sv_catpv(d, ",REIFY"); - if (flags & AVf_REUSED) sv_catpv(d, ",REUSED"); - PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", - SvCUR(d) ? SvPVX(d) + 1 : ""); - break; - case SVt_PVHV: - PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); - PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv)); - PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv)); - PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv)); - PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv)); - if (HvPMROOT(sv)) - PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); - if (HvNAME(sv)) - PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); - break; - case SVt_PVCV: - if (SvPOK(sv)) - PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); - /* FALL THROUGH */ - case SVt_PVFM: - PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); - PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv)); - PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); - PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); - PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); - PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv)); - if (CvGV(sv) && GvNAME(CvGV(sv))) { - PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv))); - } else { - PerlIO_printf(Perl_debug_log, "\n"); - } - PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); - PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); - PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); - PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); -#ifdef USE_THREADS - PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv)); - PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv)); -#endif /* USE_THREADS */ - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", - (unsigned long)CvFLAGS(sv)); - if (type == SVt_PVFM) - PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); - break; - case SVt_PVGV: - PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); - PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", - SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)"); - PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); - PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); - PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); - PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv)); - PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv)); - PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv)); - PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv)); - PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv)); - PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); - PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); - PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); - PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv)); - PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); - break; - case SVt_PVIO: - PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv)); - PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv)); - PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); - PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv)); - PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv)); - PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); - PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); - PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); - PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); - PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); - PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); - PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv)); - PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); - break; - } -} -#else -void -sv_dump(SV *sv) -{ -} -#endif - - - -