X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=135126519c52f34812108cc6cf1254996a172efc;hb=971a9dd36d83520d7040365d2791ad56b6d39411;hp=b0d7f973b1e9fb51a5e918b31849cb05a66e9225;hpb=189b2af51bf236b53a02db0b105a3de423d3fff4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index b0d7f97..1351265 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -12,107 +12,73 @@ */ #include "EXTERN.h" +#define PERL_IN_SV_C #include "perl.h" -#ifdef OVR_DBL_DIG -/* Use an overridden DBL_DIG */ -# ifdef DBL_DIG -# undef DBL_DIG -# endif -# define DBL_DIG OVR_DBL_DIG -#else -/* The following is all to get DBL_DIG, in order to pick a nice - default value for printing floating point numbers in Gconvert. - (see config.h) -*/ -#ifdef I_LIMITS -#include -#endif -#ifdef I_FLOAT -#include -#endif -#ifndef HAS_DBL_DIG -#define DBL_DIG 15 /* A guess that works lots of places */ -#endif -#endif +#define FCALL *f +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__) -# define FAST_SV_GETS +static void do_report_used(pTHXo_ SV *sv); +static void do_clean_objs(pTHXo_ SV *sv); +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void do_clean_named_objs(pTHXo_ SV *sv); #endif +static void do_clean_all(pTHXo_ SV *sv); -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)); - -typedef void (*SVFUNC) _((SV*)); #ifdef PURIFY -#define new_SV(p) \ - do { \ - MUTEX_LOCK(&sv_mutex); \ - (p) = (SV*)safemalloc(sizeof(SV)); \ - reg_add(p); \ - MUTEX_UNLOCK(&sv_mutex); \ - } while (0) - -#define del_SV(p) \ - do { \ - MUTEX_LOCK(&sv_mutex); \ - reg_remove(p); \ - free((char*)(p)); \ - MUTEX_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) \ + Perl_die(aTHX_ "SV registry bug"); \ + } \ + registry[i] = (b); \ + } STMT_END #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) -static void -reg_add(sv) -SV* sv; +STATIC void +S_reg_add(pTHX_ SV *sv) { - if (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; - registry = (SV**)safemalloc(regsize * sizeof(SV*)); - memzero(registry, regsize * sizeof(SV*)); + registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; + Newz(707, registry, registry_size, SV*); if (oldreg) { I32 i; @@ -127,38 +93,33 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } -static void -reg_remove(sv) -SV* sv; +STATIC void +S_reg_remove(pTHX_ SV *sv) { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } -static void -visit(f) -SVFUNC f; +STATIC void +S_visit(pTHX_ SVFUNC_t 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; +Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { if (!(flags & SVf_FAKE)) - free(ptr); + Safefree(ptr); } #else /* ! PURIFY */ @@ -167,58 +128,66 @@ 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 { \ - MUTEX_LOCK(&sv_mutex); \ - if (sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv(); \ - MUTEX_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 { \ - MUTEX_LOCK(&sv_mutex); \ - if (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p); \ - MUTEX_UNLOCK(&sv_mutex); \ - } while (0) - -static void -del_sv(SV *p) +#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 +S_del_sv(pTHX_ 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) ok = 1; } if (!ok) { - warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, + "Attempt to free non-arena SV: 0x%"UVxf, + PTR2UV(p)); return; } } @@ -232,7 +201,7 @@ del_sv(SV *p) #endif /* DEBUGGING */ void -sv_add_arena(char *ptr, U32 size, U32 flags) +Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { SV* sva = (SV*)ptr; register SV* sv; @@ -240,12 +209,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; @@ -259,14 +228,14 @@ sv_add_arena(char *ptr, U32 size, U32 flags) } /* sv_mutex must be held while calling more_sv() */ -static SV* -more_sv(void) +STATIC SV* +S_more_sv(pTHX) { 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 */ @@ -277,97 +246,52 @@ more_sv(void) return sv; } -static void -visit(SVFUNC f) +STATIC void +S_visit(pTHX_ SVFUNC_t 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)(aTHXo_ sv); } } } #endif /* PURIFY */ -static void -do_report_used(SV *sv) -{ - if (SvTYPE(sv) != SVTYPEMASK) { - /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ - PerlIO_printf(PerlIO_stderr(), "****\n"); - sv_dump(sv); - } -} - void -sv_report_used(void) +Perl_sv_report_used(pTHX) { visit(do_report_used); } -static void -do_clean_objs(SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -static void -do_clean_named_objs(SV *sv) -{ - if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) - do_clean_objs(GvSV(sv)); -} -#endif - -static bool in_clean_objs = FALSE; - void -sv_clean_objs(void) +Perl_sv_clean_objs(pTHX) { - in_clean_objs = TRUE; + PL_in_clean_objs = TRUE; + visit(do_clean_objs); #ifndef DISABLE_DESTRUCTOR_KLUDGE + /* some barnacles may yet remain, clinging to typeglobs */ visit(do_clean_named_objs); #endif - visit(do_clean_objs); - in_clean_objs = FALSE; -} - -static void -do_clean_all(SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); + PL_in_clean_objs = FALSE; } -static bool in_clean_all = FALSE; - void -sv_clean_all(void) +Perl_sv_clean_all(pTHX) { - in_clean_all = TRUE; + PL_in_clean_all = TRUE; visit(do_clean_all); - in_clean_all = FALSE; + PL_in_clean_all = FALSE; } void -sv_free_arenas(void) +Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; @@ -375,7 +299,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); @@ -384,164 +308,492 @@ 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* -new_xiv(void) +STATIC XPVIV* +S_new_xiv(pTHX) { - 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 -del_xiv(XPVIV *p) +STATIC void +S_del_xiv(pTHX_ 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* -more_xiv(void) +STATIC void +S_more_xiv(pTHX) { - register IV** xiv; - register IV** xivend; - XPV* ptr = (XPV*)safemalloc(1008); - ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ - 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; + register IV* xiv; + register IV* xivend; + XPV* ptr; + New(705, ptr, 1008/sizeof(XPV), XPV); + 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 */ + 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* -new_xnv(void) +STATIC XPVNV* +S_new_xnv(pTHX) { - double* xnv; - if (xnv_root) { - xnv = xnv_root; - xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - sizeof(XPVIV)); - } - return more_xnv(); + NV* xnv; + LOCK_SV_MUTEX; + if (!PL_xnv_root) + more_xnv(); + xnv = PL_xnv_root; + PL_xnv_root = *(NV**)xnv; + UNLOCK_SV_MUTEX; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } -static void -del_xnv(XPVNV *p) +STATIC void +S_del_xnv(pTHX_ XPVNV *p) { - double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); - *(double**)xnv = xnv_root; - xnv_root = xnv; + NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + LOCK_SV_MUTEX; + *(NV**)xnv = PL_xnv_root; + PL_xnv_root = xnv; + UNLOCK_SV_MUTEX; } -static XPVNV* -more_xnv(void) +STATIC void +S_more_xnv(pTHX) { - register double* xnv; - register double* xnvend; - xnv = (double*)safemalloc(1008); - xnvend = &xnv[1008 / sizeof(double) - 1]; - xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ - xnv_root = xnv; + register NV* xnv; + register NV* xnvend; + New(711, xnv, 1008/sizeof(NV), NV); + xnvend = &xnv[1008 / sizeof(NV) - 1]; + xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ + PL_xnv_root = xnv; while (xnv < xnvend) { - *(double**)xnv = (double*)(xnv + 1); + *(NV**)xnv = (NV*)(xnv + 1); xnv++; } - *(double**)xnv = 0; - return new_xnv(); + *(NV**)xnv = 0; } -static XRV* -new_xrv(void) +STATIC XRV* +S_new_xrv(pTHX) { 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 -del_xrv(XRV *p) +STATIC void +S_del_xrv(pTHX_ 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* -more_xrv(void) +STATIC void +S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; - xrv_root = (XRV*)safemalloc(1008); - 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* -new_xpv(void) +STATIC XPV* +S_new_xpv(pTHX) { 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 -del_xpv(XPV *p) +STATIC void +S_del_xpv(pTHX_ 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* -more_xpv(void) +STATIC void +S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; - xpv_root = (XPV*)safemalloc(1008); - 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(); +} + +STATIC XPVIV* +S_new_xpviv(pTHX) +{ + XPVIV* xpviv; + LOCK_SV_MUTEX; + if (!PL_xpviv_root) + more_xpviv(); + xpviv = PL_xpviv_root; + PL_xpviv_root = (XPVIV*)xpviv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpviv; +} + +STATIC void +S_del_xpviv(pTHX_ XPVIV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpviv_root; + PL_xpviv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpviv(pTHX) +{ + register XPVIV* xpviv; + register XPVIV* xpvivend; + New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV); + xpviv = PL_xpviv_root; + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + while (xpviv < xpvivend) { + xpviv->xpv_pv = (char*)(xpviv + 1); + xpviv++; + } + xpviv->xpv_pv = 0; +} + + +STATIC XPVNV* +S_new_xpvnv(pTHX) +{ + XPVNV* xpvnv; + LOCK_SV_MUTEX; + if (!PL_xpvnv_root) + more_xpvnv(); + xpvnv = PL_xpvnv_root; + PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvnv; +} + +STATIC void +S_del_xpvnv(pTHX_ XPVNV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvnv_root; + PL_xpvnv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvnv(pTHX) +{ + register XPVNV* xpvnv; + register XPVNV* xpvnvend; + New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV); + xpvnv = PL_xpvnv_root; + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + while (xpvnv < xpvnvend) { + xpvnv->xpv_pv = (char*)(xpvnv + 1); + xpvnv++; + } + xpvnv->xpv_pv = 0; +} + + + +STATIC XPVCV* +S_new_xpvcv(pTHX) +{ + XPVCV* xpvcv; + LOCK_SV_MUTEX; + if (!PL_xpvcv_root) + more_xpvcv(); + xpvcv = PL_xpvcv_root; + PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvcv; +} + +STATIC void +S_del_xpvcv(pTHX_ XPVCV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvcv_root; + PL_xpvcv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvcv(pTHX) +{ + register XPVCV* xpvcv; + register XPVCV* xpvcvend; + New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV); + xpvcv = PL_xpvcv_root; + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + while (xpvcv < xpvcvend) { + xpvcv->xpv_pv = (char*)(xpvcv + 1); + xpvcv++; + } + xpvcv->xpv_pv = 0; +} + + + +STATIC XPVAV* +S_new_xpvav(pTHX) +{ + XPVAV* xpvav; + LOCK_SV_MUTEX; + if (!PL_xpvav_root) + more_xpvav(); + xpvav = PL_xpvav_root; + PL_xpvav_root = (XPVAV*)xpvav->xav_array; + UNLOCK_SV_MUTEX; + return xpvav; +} + +STATIC void +S_del_xpvav(pTHX_ XPVAV *p) +{ + LOCK_SV_MUTEX; + p->xav_array = (char*)PL_xpvav_root; + PL_xpvav_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvav(pTHX) +{ + register XPVAV* xpvav; + register XPVAV* xpvavend; + New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV); + xpvav = PL_xpvav_root; + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + while (xpvav < xpvavend) { + xpvav->xav_array = (char*)(xpvav + 1); + xpvav++; + } + xpvav->xav_array = 0; +} + + + +STATIC XPVHV* +S_new_xpvhv(pTHX) +{ + XPVHV* xpvhv; + LOCK_SV_MUTEX; + if (!PL_xpvhv_root) + more_xpvhv(); + xpvhv = PL_xpvhv_root; + PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array; + UNLOCK_SV_MUTEX; + return xpvhv; +} + +STATIC void +S_del_xpvhv(pTHX_ XPVHV *p) +{ + LOCK_SV_MUTEX; + p->xhv_array = (char*)PL_xpvhv_root; + PL_xpvhv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvhv(pTHX) +{ + register XPVHV* xpvhv; + register XPVHV* xpvhvend; + New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV); + xpvhv = PL_xpvhv_root; + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + while (xpvhv < xpvhvend) { + xpvhv->xhv_array = (char*)(xpvhv + 1); + xpvhv++; + } + xpvhv->xhv_array = 0; +} + + +STATIC XPVMG* +S_new_xpvmg(pTHX) +{ + XPVMG* xpvmg; + LOCK_SV_MUTEX; + if (!PL_xpvmg_root) + more_xpvmg(); + xpvmg = PL_xpvmg_root; + PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvmg; +} + +STATIC void +S_del_xpvmg(pTHX_ XPVMG *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvmg_root; + PL_xpvmg_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvmg(pTHX) +{ + register XPVMG* xpvmg; + register XPVMG* xpvmgend; + New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG); + xpvmg = PL_xpvmg_root; + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + while (xpvmg < xpvmgend) { + xpvmg->xpv_pv = (char*)(xpvmg + 1); + xpvmg++; + } + xpvmg->xpv_pv = 0; +} + + + +STATIC XPVLV* +S_new_xpvlv(pTHX) +{ + XPVLV* xpvlv; + LOCK_SV_MUTEX; + if (!PL_xpvlv_root) + more_xpvlv(); + xpvlv = PL_xpvlv_root; + PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvlv; +} + +STATIC void +S_del_xpvlv(pTHX_ XPVLV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvlv_root; + PL_xpvlv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvlv(pTHX) +{ + register XPVLV* xpvlv; + register XPVLV* xpvlvend; + New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV); + xpvlv = PL_xpvlv_root; + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + while (xpvlv < xpvlvend) { + xpvlv->xpv_pv = (char*)(xpvlv + 1); + xpvlv++; + } + xpvlv->xpv_pv = 0; +} + + +STATIC XPVBM* +S_new_xpvbm(pTHX) +{ + XPVBM* xpvbm; + LOCK_SV_MUTEX; + if (!PL_xpvbm_root) + more_xpvbm(); + xpvbm = PL_xpvbm_root; + PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvbm; +} + +STATIC void +S_del_xpvbm(pTHX_ XPVBM *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvbm_root; + PL_xpvbm_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvbm(pTHX) +{ + register XPVBM* xpvbm; + register XPVBM* xpvbmend; + New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM); + xpvbm = PL_xpvbm_root; + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + while (xpvbm < xpvbmend) { + xpvbm->xpv_pv = (char*)(xpvbm + 1); + xpvbm++; + } + xpvbm->xpv_pv = 0; } #ifdef PURIFY #define new_XIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XIV(p) free((char*)p) +#define del_XIV(p) Safefree((char*)p) #else #define new_XIV() (void*)new_xiv() #define del_XIV(p) del_xiv((XPVIV*) p) @@ -549,7 +801,7 @@ more_xpv(void) #ifdef PURIFY #define new_XNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XNV(p) free((char*)p) +#define del_XNV(p) Safefree((char*)p) #else #define new_XNV() (void*)new_xnv() #define del_XNV(p) del_xnv((XPVNV*) p) @@ -557,7 +809,7 @@ more_xpv(void) #ifdef PURIFY #define new_XRV() (void*)safemalloc(sizeof(XRV)) -#define del_XRV(p) free((char*)p) +#define del_XRV(p) Safefree((char*)p) #else #define new_XRV() (void*)new_xrv() #define del_XRV(p) del_xrv((XRV*) p) @@ -565,53 +817,108 @@ more_xpv(void) #ifdef PURIFY #define new_XPV() (void*)safemalloc(sizeof(XPV)) -#define del_XPV(p) free((char*)p) +#define del_XPV(p) Safefree((char*)p) #else #define new_XPV() (void*)new_xpv() #define del_XPV(p) del_xpv((XPV *)p) #endif -#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) free((char*)p) +#ifdef PURIFY +# define my_safemalloc(s) safemalloc(s) +# define my_safefree(s) safefree(s) +#else +STATIC void* +S_my_safemalloc(MEM_SIZE size) +{ + char *p; + New(717, p, size, char); + return (void*)p; +} +# define my_safefree(s) Safefree(s) +#endif +#ifdef PURIFY +#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) Safefree((char*)p) +#else +#define new_XPVIV() (void*)new_xpviv() +#define del_XPVIV(p) del_xpviv((XPVIV *)p) +#endif + +#ifdef PURIFY #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) free((char*)p) +#define del_XPVNV(p) Safefree((char*)p) +#else +#define new_XPVNV() (void*)new_xpvnv() +#define del_XPVNV(p) del_xpvnv((XPVNV *)p) +#endif -#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) free((char*)p) -#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) free((char*)p) +#ifdef PURIFY +#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) Safefree((char*)p) +#else +#define new_XPVCV() (void*)new_xpvcv() +#define del_XPVCV(p) del_xpvcv((XPVCV *)p) +#endif +#ifdef PURIFY #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) free((char*)p) +#define del_XPVAV(p) Safefree((char*)p) +#else +#define new_XPVAV() (void*)new_xpvav() +#define del_XPVAV(p) del_xpvav((XPVAV *)p) +#endif +#ifdef PURIFY #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) free((char*)p) - -#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) free((char*)p) - -#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) free((char*)p) - +#define del_XPVHV(p) Safefree((char*)p) +#else +#define new_XPVHV() (void*)new_xpvhv() +#define del_XPVHV(p) del_xpvhv((XPVHV *)p) +#endif + +#ifdef PURIFY +#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) Safefree((char*)p) +#else +#define new_XPVMG() (void*)new_xpvmg() +#define del_XPVMG(p) del_xpvmg((XPVMG *)p) +#endif + +#ifdef PURIFY +#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) Safefree((char*)p) +#else +#define new_XPVLV() (void*)new_xpvlv() +#define del_XPVLV(p) del_xpvlv((XPVLV *)p) +#endif + +#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree((char*)p) + +#ifdef PURIFY #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) free((char*)p) - -#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) free((char*)p) - -#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) free((char*)p) +#define del_XPVBM(p) Safefree((char*)p) +#else +#define new_XPVBM() (void*)new_xpvbm() +#define del_XPVBM(p) del_xpvbm((XPVBM *)p) +#endif + +#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM)) +#define del_XPVFM(p) my_safefree((char*)p) + +#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO)) +#define del_XPVIO(p) my_safefree((char*)p) bool -sv_upgrade(register SV *sv, U32 mt) +Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { char* pv; U32 cur; U32 len; IV iv; - double nv; + NV nv; MAGIC* magic; HV* stash; @@ -636,7 +943,7 @@ sv_upgrade(register SV *sv, U32 mt) cur = 0; len = 0; iv = SvIVX(sv); - nv = (double)SvIVX(sv); + nv = (NV)SvIVX(sv); del_XIV(SvANY(sv)); magic = 0; stash = 0; @@ -650,7 +957,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)); @@ -662,8 +969,8 @@ sv_upgrade(register SV *sv, U32 mt) pv = (char*)SvRV(sv); cur = 0; len = 0; - iv = (IV)pv; - nv = (double)(unsigned long)pv; + iv = PTR2IV(pv); + nv = PTR2NV(pv); del_XRV(SvANY(sv)); magic = 0; stash = 0; @@ -713,12 +1020,12 @@ sv_upgrade(register SV *sv, U32 mt) del_XPVMG(SvANY(sv)); break; default: - croak("Can't upgrade that kind of scalar"); + Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); } switch (mt) { case SVt_NULL: - croak("Can't upgrade to undef"); + Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: SvANY(sv) = new_XIV(); SvIVX(sv) = iv; @@ -785,7 +1092,7 @@ sv_upgrade(register SV *sv, U32 mt) Safefree(pv); SvPVX(sv) = 0; AvMAX(sv) = -1; - AvFILL(sv) = -1; + AvFILLp(sv) = -1; SvIVX(sv) = 0; SvNVX(sv) = 0.0; SvMAGIC(sv) = magic; @@ -878,156 +1185,8 @@ 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) +Perl_sv_backoff(pTHX_ register SV *sv) { assert(SvOOK(sv)); if (SvIVX(sv)) { @@ -1042,17 +1201,14 @@ 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 +Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); + PerlIO_printf(Perl_debug_log, + "Allocation too large: %"UVxf"\n", (UV)newlen); my_exit(1); } #endif /* HAS_64K_LIMIT */ @@ -1067,12 +1223,24 @@ sv_grow(SV* sv, unsigned long newlen) s = SvPVX(sv); if (newlen > SvLEN(sv)) newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ - } +#ifdef HAS_64K_LIMIT + if (newlen >= 0x10000) + newlen = 0xFFFF; +#endif + } 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); @@ -1082,9 +1250,9 @@ sv_grow(SV* sv, unsigned long newlen) } void -sv_setiv(register SV *sv, IV i) +Perl_sv_setiv(pTHX_ register SV *sv, IV i) { - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { case SVt_NULL: sv_upgrade(sv, SVt_IV); @@ -1098,11 +1266,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: @@ -1110,8 +1273,8 @@ sv_setiv(register SV *sv, IV i) case SVt_PVIO: { dTHR; - croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), - op_desc[op->op_type]); + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + PL_op_desc[PL_op->op_type]); } } (void)SvIOK_only(sv); /* validate number */ @@ -1120,42 +1283,43 @@ sv_setiv(register SV *sv, IV i) } void -sv_setuv(register SV *sv, UV u) +Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) { - if (u <= IV_MAX) - sv_setiv(sv, u); - else - sv_setnv(sv, (double)u); + sv_setiv(sv,i); + SvSETMAGIC(sv); +} + +void +Perl_sv_setuv(pTHX_ register SV *sv, UV u) +{ + sv_setiv(sv, 0); + SvIsUV_on(sv); + SvUVX(sv) = u; +} + +void +Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) +{ + sv_setuv(sv,u); + SvSETMAGIC(sv); } void -sv_setnv(register SV *sv, double num) +Perl_sv_setnv(pTHX_ register SV *sv, NV num) { - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: sv_upgrade(sv, SVt_NV); break; - case SVt_NV: case SVt_RV: 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: @@ -1163,8 +1327,8 @@ sv_setnv(register SV *sv, double num) case SVt_PVIO: { dTHR; - croak("Can't coerce %s to number in %s", sv_reftype(sv,0), - op_name[op->op_type]); + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } } SvNVX(sv) = num; @@ -1172,8 +1336,15 @@ sv_setnv(register SV *sv, double num) SvTAINT(sv); } -static void -not_a_number(SV *sv) +void +Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) +{ + sv_setnv(sv,num); + SvSETMAGIC(sv); +} + +STATIC void +S_not_a_number(pTHX_ SV *sv) { dTHR; char tmpbuf[64]; @@ -1220,15 +1391,26 @@ 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) + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric in %s", tmpbuf, + PL_op_desc[PL_op->op_type]); else - warn("Argument \"%s\" isn't numeric", tmpbuf); + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric", tmpbuf); } +/* the number can be converted to integer with atol() or atoll() */ +#define IS_NUMBER_TO_INT_BY_ATOL 0x01 +#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ +#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ +#define IS_NUMBER_NEG 0x08 /* not good to cache UV */ + +/* Actually, ISO C leaves conversion of UV to IV undefined, but + until proven guilty, assume that things are not that bad... */ + IV -sv_2iv(register SV *sv) +Perl_sv_2iv(pTHX_ register SV *sv) { if (!sv) return 0; @@ -1237,80 +1419,138 @@ 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) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } return 0; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvIV(tmpstr); -#endif /* OVERLOAD */ - return (IV)SvRV(sv); + return SvIV(tmpstr); + return PTR2IV(SvRV(sv)); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - if (dowarn) - warn(warn_uninit); + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return (IV)(SvUVX(sv)); + } + else { + return SvIVX(sv); + } } if (SvNOKp(sv)) { + /* We can cache the IV/UV value even if it not good enough + * to reconstruct NV, since the conversion to PV will prefer + * NV over IV/UV. + */ + + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); + (void)SvIOK_on(sv); - if (SvNVX(sv) < 0.0) + if (SvNVX(sv) < (NV)IV_MAX + 0.5) SvIVX(sv) = I_V(SvNVX(sv)); - else + else { SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + ret_iv_max: + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", + PTR2UV(sv), + SvUVX(sv), + SvUVX(sv))); + return (IV)SvUVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvIVX(sv) = asIV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache an IV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such an IV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + if (numtype & IS_NUMBER_NOT_IV) { + /* May be not an integer. Need to cache NV if we cache IV + * - otherwise future conversion to NV will be wrong. */ + NV d; + + d = Atof(SvPVX(sv)); + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif + if (SvNVX(sv) < (NV)IV_MAX + 0.5) + SvIVX(sv) = I_V(SvNVX(sv)); + else { + SvUVX(sv) = U_V(SvNVX(sv)); + 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)); + } + 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)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); return 0; } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", - (unsigned long)sv,(long)SvIVX(sv))); - return SvIVX(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", + PTR2UV(sv),SvIVX(sv))); + return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } UV -sv_2uv(register SV *sv) +Perl_sv_2uv(pTHX_ register SV *sv) { if (!sv) return 0; @@ -1323,68 +1563,153 @@ 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) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } return 0; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvUV(tmpstr); -#endif /* OVERLOAD */ - return (UV)SvRV(sv); + return SvUV(tmpstr); + return PTR2UV(SvRV(sv)); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - if (dowarn) - warn(warn_uninit); + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) { + return SvUVX(sv); + } + else { + return (UV)SvIVX(sv); + } } if (SvNOKp(sv)) { + /* We can cache the IV/UV value even if it not good enough + * to reconstruct NV, since the conversion to PV will prefer + * NV over IV/UV. + */ + 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%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n", + PTR2UV(sv), + SvIVX(sv), + (IV)(UV)SvIVX(sv))); + return (UV)SvIVX(sv); + } } else if (SvPOKp(sv) && SvLEN(sv)) { - (void)SvIOK_on(sv); - SvUVX(sv) = asUV(sv); + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache a UV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + if (numtype & IS_NUMBER_NOT_IV) { + /* May be not an integer. Need to cache NV if we cache IV + * - otherwise future conversion to NV will be wrong. */ + NV d; + + d = Atof(SvPVX(sv)); + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2nv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif + if (SvNVX(sv) < -0.5) { + SvIVX(sv) = I_V(SvNVX(sv)); + goto ret_zero; + } else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + } + } + else if (numtype & IS_NUMBER_NEG) { + /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = (IV)Atol(SvPVX(sv)); + } + 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); +#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)); +#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) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); return 0; } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", - (unsigned long)sv,SvUVX(sv))); - return SvUVX(sv); + + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", + (UV)sv,SvUVX(sv))); + return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } -double -sv_2nv(register SV *sv) +NV +Perl_sv_2nv(pTHX_ register SV *sv) { if (!sv) return 0.0; @@ -1393,42 +1718,37 @@ 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)); + return Atof(SvPVX(sv)); } - if (SvIOKp(sv)) - return (double)SvIVX(sv); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + return (NV)SvIVX(sv); + } if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } return 0; } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { -#ifdef OVERLOAD SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) - return SvNV(tmpstr); -#endif /* OVERLOAD */ - return (double)(unsigned long)SvRV(sv); + return SvNV(tmpstr); + return PTR2NV(SvRV(sv)); } - if (SvREADONLY(sv)) { - if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !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 (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; } } @@ -1437,76 +1757,119 @@ sv_2nv(register SV *sv) sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); - DEBUG_c(SET_NUMERIC_STANDARD()); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, + "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { - SvNVX(sv) = (double)SvIVX(sv); + SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)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)); + 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)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + if (SvTYPE(sv) < SVt_NV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_NV); return 0.0; } SvNOK_on(sv); - DEBUG_c(SET_NUMERIC_STANDARD()); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif return SvNVX(sv); } -static IV -asIV(SV *sv) +STATIC IV +S_asIV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); - double d; - - if (numtype == 1) - return atol(SvPVX(sv)); - if (!numtype && dowarn) - 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); + NV d; + + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return Atol(SvPVX(sv)); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + d = Atof(SvPVX(sv)); + return I_V(d); } -static UV -asUV(SV *sv) +STATIC UV +S_asUV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); #ifdef HAS_STRTOUL - if (numtype == 1) - return strtoul(SvPVX(sv), Null(char**), 10); + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return Strtoul(SvPVX(sv), Null(char**), 10); #endif - if (!numtype && dowarn) - not_a_number(sv); - SET_NUMERIC_STANDARD(); - return U_V(atof(SvPVX(sv))); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return U_V(Atof(SvPVX(sv))); } +/* + * Returns a combination of (advisory only - can get false negatives) + * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, + * IS_NUMBER_NEG + * 0 if does not look like number. + * + * In fact possible values are 0 and + * IS_NUMBER_TO_INT_BY_ATOL 123 + * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 + * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * with a possible addition of IS_NUMBER_NEG. + */ + I32 -looks_like_number(SV *sv) +Perl_looks_like_number(pTHX_ SV *sv) { register char *s; register char *send; register char *sbegin; - I32 numtype; + register char *nbegin; + I32 numtype = 0; STRLEN len; if (SvPOK(sv)) { @@ -1522,23 +1885,50 @@ looks_like_number(SV *sv) s = sbegin; while (isSPACE(*s)) s++; - if (*s == '+' || *s == '-') + if (*s == '-') { s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + nbegin = s; + /* + * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted + * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need + * (int)atof(). + */ - /* next must be digit or '.' */ + /* next must be digit or the radix separator */ if (isDIGIT(*s)) { do { s++; } while (isDIGIT(*s)); - if (*s == '.') { + + if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */ + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; + else + numtype |= IS_NUMBER_TO_INT_BY_ATOL; + + if (*s == '.' +#ifdef USE_LOCALE_NUMERIC + || IS_NUMERIC_RADIX(*s) +#endif + ) { s++; - while (isDIGIT(*s)) /* optional digits after "." */ + numtype |= IS_NUMBER_NOT_IV; + while (isDIGIT(*s)) /* optional digits after the radix */ s++; } } - else if (*s == '.') { + else if (*s == '.' +#ifdef USE_LOCALE_NUMERIC + || IS_NUMERIC_RADIX(*s) +#endif + ) { s++; - /* no digits before '.' means we need digits after it */ + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; + /* no digits before the radix means we need digits after it */ if (isDIGIT(*s)) { do { s++; @@ -1550,15 +1940,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++; @@ -1575,17 +1960,53 @@ looks_like_number(SV *sv) if (s >= send) return numtype; if (len == 10 && memEQ(sbegin, "0 but true", 10)) - return 1; + return IS_NUMBER_TO_INT_BY_ATOL; return 0; } char * -sv_2pv(register SV *sv, STRLEN *lp) +Perl_sv_2pv_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +/* We assume that buf is at least TYPE_CHARS(UV) long. */ +static char * +uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +{ + STRLEN len; + char *ptr = buf + TYPE_CHARS(UV); + char *ebuf = ptr; + int sign; + char *p; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + +char * +Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { register char *s; int olderrno; SV *tsv; - char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char *tmpbuf = tbuf; if (!sv) { *lp = 0; @@ -1598,21 +2019,23 @@ sv_2pv(register SV *sv, STRLEN *lp) return SvPVX(sv); } if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); + if (SvIsUV(sv)) + (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)); + else + (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); tsv = Nullsv; goto tokensave; } if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); + Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } 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) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); } *lp = 0; return ""; @@ -1620,16 +2043,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: @@ -1637,49 +2105,40 @@ 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 = "FORMATLINE"; break; + case SVt_PVFM: s = "FORMAT"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } tsv = NEWSV(0,0); if (SvOBJECT(sv)) - sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); - sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); + Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); goto tokensaveref; } *lp = strlen(s); return s; } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (SvIOKp(sv)) { - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); - tsv = Nullsv; - goto tokensave; - } - if (dowarn) - warn(warn_uninit); + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); *lp = 0; return ""; } } - if (!SvUPGRADE(sv, SVt_PV)) - return 0; - if (SvNOKp(sv)) { + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ + /* I tried changing this for to be 64-bit-aware and + * the t/op/numconvert.t became very, very, angry. + * --jhi Sep 1999 */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvGROW(sv, 28); @@ -1691,8 +2150,7 @@ sv_2pv(register SV *sv, STRLEN *lp) else #endif /*apollo*/ { - SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, s); + Gconvert(SvNVX(sv), NV_DIG, 0, s); } errno = olderrno; #ifdef FIXNEGATIVEZERO @@ -1706,29 +2164,48 @@ sv_2pv(register SV *sv, STRLEN *lp) #endif } else if (SvIOKp(sv)) { - U32 oldIOK = SvIOK(sv); + U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpviv(sv, SvIVX(sv)); - errno = olderrno; + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); - if (oldIOK) + *s = '\0'; + if (isIOK) SvIOK_on(sv); else SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); + SvPOK_on(sv); } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) + && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + { + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + } *lp = 0; + if (SvTYPE(sv) < SVt_PV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_PV); return ""; } *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); return SvPVX(sv); tokensave: @@ -1773,7 +2250,7 @@ sv_2pv(register SV *sv, STRLEN *lp) /* This function is only called on magical items */ bool -sv_2bool(register SV *sv) +Perl_sv_2bool(pTHX_ register SV *sv) { if (SvGMAGICAL(sv)) mg_get(sv); @@ -1781,14 +2258,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)) { @@ -1819,7 +2292,7 @@ sv_2bool(register SV *sv) */ void -sv_setsv(SV *dstr, register SV *sstr) +Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { dTHR; register U32 sflags; @@ -1828,46 +2301,67 @@ sv_setsv(SV *dstr, register SV *sstr) if (sstr == dstr) return; - sv_check_thinkfirst(dstr); + 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); @@ -1875,8 +2369,11 @@ 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 (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_on(dstr); + } GvMULTI_on(dstr); return; } @@ -1896,16 +2393,15 @@ sv_setsv(SV *dstr, register SV *sstr) if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; - case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVIO: - if (op) - croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), - op_name[op->op_type]); + if (PL_op) + Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), + PL_op_name[PL_op->op_type]); else - croak("Bizarre copy of %s", sv_reftype(sstr, 0)); + Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); break; case SVt_PVGV: @@ -1916,23 +2412,26 @@ sv_setsv(SV *dstr, register SV *sstr) STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); sv_magic(dstr, dstr, '*', name, len); - GvSTASH(dstr) = GvSTASH(sstr); + GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } /* ahem, death to those who redefine active sort subs */ - else if (curstack == sortstack - && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) - croak("Can't redefine active sort subroutine %s", + else if (PL_curstackinfo->si_type == PERLSI_SORT + && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) + Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - if (curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_on(dstr); + } GvMULTI_on(dstr); return; } @@ -1947,8 +2446,10 @@ sv_setsv(SV *dstr, register SV *sstr) goto glob_assign; } } - if (dtype < stype) - sv_upgrade(dstr, stype); + if (stype == SVt_PVLV) + (void)SvUPGRADE(dstr, SVt_PVNV); + else + (void)SvUPGRADE(dstr, stype); } sflags = SvFLAGS(sstr); @@ -1956,7 +2457,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); @@ -1968,7 +2468,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) = CopLINE(PL_curcop); GvEGV(dstr) = (GV*)dstr; } GvMULTI_on(dstr); @@ -1979,8 +2479,11 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED_AV_off(dstr) + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_AV_on(dstr); + } break; case SVt_PVHV: if (intro) @@ -1988,8 +2491,11 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED_HV_off(dstr) + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_HV_on(dstr); + } break; case SVt_PVCV: if (intro) { @@ -1997,7 +2503,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)); } @@ -2009,19 +2515,29 @@ 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 (curstack == sortstack && - sortcop == CvSTART(cv)) - croak( + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) + Perl_croak(aTHX_ "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) - warn("Subroutine %s redefined", - GvENAME((GV*)dstr)); + if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) { + if (!(CvGV(cv) && GvSTASH(CvGV(cv)) + && HvNAME(GvSTASH(CvGV(cv))) + && strEQ(HvNAME(GvSTASH(CvGV(cv))), + "autouse"))) + Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2029,10 +2545,13 @@ 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 (GvIMPORTED_CV_off(dstr) + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_CV_on(dstr); + } break; case SVt_PVIO: if (intro) @@ -2047,8 +2566,11 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED_SV_off(dstr) + && CopSTASH(PL_curcop) != GvSTASH(dstr)) + { GvIMPORTED_SV_on(dstr); + } break; } if (dref) @@ -2060,7 +2582,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; } } @@ -2074,12 +2597,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) { @@ -2099,7 +2622,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); @@ -2130,6 +2653,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) { @@ -2138,59 +2663,77 @@ 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)) + Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } void -sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) +{ + sv_setsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void +Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { + register char *dptr; assert(len >= 0); /* STRLEN is probably unsigned, so this may elicit a warning, but it won't hurt. */ - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; } - if (SvTYPE(sv) >= SVt_PV) { - if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) - sv_unglob(sv); - } - else if (!sv_upgrade(sv, SVt_PV)) - return; + (void)SvUPGRADE(sv, SVt_PV); + SvGROW(sv, len + 1); - Move(ptr,SvPVX(sv),len,char); + dptr = SvPVX(sv); + Move(ptr,dptr,len,char); + dptr[len] = '\0'; SvCUR_set(sv, len); - *SvEND(sv) = '\0'; (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } void -sv_setpv(register SV *sv, register const char *ptr) +Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +{ + sv_setpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void +Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; } len = strlen(ptr); - if (SvTYPE(sv) >= SVt_PV) { - if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) - sv_unglob(sv); - } - else if (!sv_upgrade(sv, SVt_PV)) - return; + (void)SvUPGRADE(sv, SVt_PV); + SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); SvCUR_set(sv, len); @@ -2199,16 +2742,23 @@ sv_setpv(register SV *sv, register const char *ptr) } void -sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) { - sv_check_thinkfirst(sv); - if (!SvUPGRADE(sv, SVt_PV)) - return; + sv_setpv(sv,ptr); + SvSETMAGIC(sv); +} + +void +Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) +{ + SV_CHECK_THINKFIRST(sv); + (void)SvUPGRADE(sv, SVt_PV); if (!ptr) { (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; @@ -2219,22 +2769,29 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) SvTAINT(sv); } -static void -sv_check_thinkfirst(register SV *sv) +void +Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - dTHR; - if (curcop != &compiling) - croak(no_modify); - } - if (SvROK(sv)) - sv_unref(sv); + sv_usepvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void +Perl_sv_force_normal(pTHX_ register SV *sv) +{ + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + Perl_croak(aTHX_ PL_no_modify); } + if (SvROK(sv)) + sv_unref(sv); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + sv_unglob(sv); } void -sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ +Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ { @@ -2242,15 +2799,22 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in if (!ptr || !SvPOKp(sv)) return; - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) 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; @@ -2259,7 +2823,7 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in } void -sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { STRLEN tlen; char *junk; @@ -2276,7 +2840,14 @@ sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) } void -sv_catsv(SV *dstr, register SV *sstr) +Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +{ + sv_catpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void +Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { char *s; STRLEN len; @@ -2287,7 +2858,14 @@ sv_catsv(SV *dstr, register SV *sstr) } void -sv_catpv(register SV *sv, register char *ptr) +Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) +{ + sv_catsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void +Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; STRLEN tlen; @@ -2306,21 +2884,19 @@ sv_catpv(register SV *sv, register char *ptr) SvTAINT(sv); } +void +Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) +{ + sv_catpv(sv,ptr); + SvSETMAGIC(sv); +} + SV * -#ifdef LEAKTEST -newSV(x,len) -I32 x; -#else -newSV(STRLEN len) -#endif - +Perl_newSV(pTHX_ STRLEN len) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (len) { sv_upgrade(sv, SVt_PV); SvGROW(sv, len + 1); @@ -2331,14 +2907,14 @@ newSV(STRLEN len) /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ void -sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) +Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { MAGIC* mg; if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling && !strchr("gBf", how)) - croak(no_modify); + if (PL_curcop != &PL_compiling && !strchr("gBf", how)) + Perl_croak(aTHX_ PL_no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2348,8 +2924,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) } } else { - if (!SvUPGRADE(sv, SVt_PVMG)) - return; + (void)SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -2372,100 +2947,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. */ @@ -2474,7 +3056,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) SvRMAGICAL_on(sv); break; default: - croak("Don't know how to handle magic of type '%c'", how); + Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how); } mg_magical(sv); if (SvGMAGICAL(sv)) @@ -2482,7 +3064,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) } int -sv_unmagic(SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *sv, int type) { MAGIC* mg; MAGIC** mgp; @@ -2494,7 +3076,7 @@ sv_unmagic(SV *sv, int type) MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; if (vtbl && vtbl->svt_free) - (*vtbl->svt_free)(sv, mg); + CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2515,18 +3097,82 @@ sv_unmagic(SV *sv, int type) return 0; } +SV * +Perl_sv_rvweaken(pTHX_ SV *sv) +{ + SV *tsv; + if (!SvOK(sv)) /* let undefs pass */ + return sv; + if (!SvROK(sv)) + Perl_croak(aTHX_ "Can't weaken a nonreference"); + else if (SvWEAKREF(sv)) { + dTHR; + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Reference is already weak"); + return sv; + } + tsv = SvRV(sv); + sv_add_backref(tsv, sv); + SvWEAKREF_on(sv); + SvREFCNT_dec(tsv); + return sv; +} + +STATIC void +S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +{ + AV *av; + MAGIC *mg; + if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<'))) + av = (AV*)mg->mg_obj; + else { + av = newAV(); + sv_magic(tsv, (SV*)av, '<', NULL, 0); + SvREFCNT_dec(av); /* for sv_magic */ + } + av_push(av,sv); +} + +STATIC void +S_sv_del_backref(pTHX_ SV *sv) +{ + AV *av; + SV **svp; + I32 i; + SV *tsv = SvRV(sv); + MAGIC *mg; + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<'))) + Perl_croak(aTHX_ "panic: del_backref"); + av = (AV *)mg->mg_obj; + svp = AvARRAY(av); + i = AvFILLp(av); + while (i >= 0) { + if (svp[i] == sv) { + svp[i] = &PL_sv_undef; /* XXX */ + } + i--; + } +} + void -sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) +Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) { register char *big; register char *mid; register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) - croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + Perl_croak(aTHX_ "Can't modify non-existent substring"); + 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 */ @@ -2554,7 +3200,7 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) bigend = big + SvCUR(bigstr); if (midend > bigend) - croak("panic: sv_insert"); + Perl_croak(aTHX_ "panic: sv_insert"); if (mid - big > bigend - midend) { /* faster to shorten from end */ if (littlelen) { @@ -2594,12 +3240,13 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) /* make sv point to what nstr did */ void -sv_replace(register SV *sv, register SV *nsv) +Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { + dTHR; U32 refcnt = SvREFCNT(sv); - sv_check_thinkfirst(sv); - if (SvREFCNT(nsv) != 1) - warn("Reference miscount in sv_replace()"); + SV_CHECK_THINKFIRST(sv); + if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -2620,66 +3267,78 @@ sv_replace(register SV *sv, register SV *nsv) } void -sv_clear(register SV *sv) +Perl_sv_clear(pTHX_ register SV *sv) { + HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { dTHR; - if (defstash) { /* Still have a symbol table? */ + if (PL_defstash) { /* Still have a symbol table? */ djSP; GV* destructor; + SV tmpref; - ENTER; - SAVEFREESV(SvSTASH(sv)); - - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); - if (destructor) { - SV ref; - - Zero(&ref, 1, SV); - sv_upgrade(&ref, SVt_RV); - SvRV(&ref) = SvREFCNT_inc(sv); - SvROK_on(&ref); - SvREFCNT(&ref) = 1; /* Fake, but otherwise - creating+destructing a ref - leads to disaster. */ - - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(&ref); - PUTBACK; - perl_call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); - del_XRV(SvANY(&ref)); - SvREFCNT(sv)--; - } + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; - LEAVE; + do { + stash = SvSTASH(sv); + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + SvRV(&tmpref) = SvREFCNT_inc(sv); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(&tmpref); + PUTBACK; + call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); + SvREFCNT(sv)--; + POPSTACK; + SPAGAIN; + LEAVE; + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + del_XRV(SvANY(&tmpref)); + + if (SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", + HvNAME(stash)); + /* DESTROY gave object new lease on life */ + return; + } } - else - SvREFCNT_dec(SvSTASH(sv)); + 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)) mg_free(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); + { + io_close((IO*)sv, FALSE); + } + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = (DIR*)NULL; Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2696,11 +3355,18 @@ 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)); + /* cannot decrease stash refcount yet, as we might recursively delete + ourselves when the refcnt drops to zero. Delay SvREFCNT_dec + of stash until current sv is completely gone. + -- JohnPC, 27 Mar 1998 */ + stash = GvSTASH(sv); /* FALL THROUGH */ - case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -2709,8 +3375,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; @@ -2760,7 +3430,13 @@ sv_clear(register SV *sv) break; case SVt_PVGV: del_XPVGV(SvANY(sv)); - break; + /* code duplication for increased performance. */ + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + /* decrease refcount of the stash that owns this GV, if any */ + if (stash) + SvREFCNT_dec(stash); + return; /* not break, SvFLAGS reset already happened */ case SVt_PVBM: del_XPVBM(SvANY(sv)); break; @@ -2776,45 +3452,59 @@ sv_clear(register SV *sv) } SV * -sv_newref(SV *sv) +Perl_sv_newref(pTHX_ SV *sv) { if (sv) - SvREFCNT(sv)++; + ATOMIC_INC(SvREFCNT(sv)); return sv; } void -sv_free(SV *sv) +Perl_sv_free(pTHX_ SV *sv) { + dTHR; + int refcount_is_zero; + 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; - warn("Attempt to free unreferenced scalar"); + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); return; } - if (--SvREFCNT(sv) > 0) + ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); + if (!refcount_is_zero) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%"UVxf, + PTR2UV(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) +Perl_sv_len(pTHX_ register SV *sv) { char *junk; STRLEN len; @@ -2823,14 +3513,99 @@ sv_len(register SV *sv) return 0; if (SvGMAGICAL(sv)) - len = mg_len(sv); + len = mg_length(sv); else junk = SvPV(sv, len); return len; } +STRLEN +Perl_sv_len_utf8(pTHX_ 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 +Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) +{ + U8 *start; + U8 *s; + U8 *send; + I32 uoffset = *offsetp; + STRLEN len; + + if (!sv) + return; + + 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; +} + +void +Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) +{ + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return; + + s = (U8*)SvPV(sv, len); + if (len < *offsetp) + Perl_croak(aTHX_ "panic: bad byte offset"); + send = s + *offsetp; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + ++len; + } + if (s != send) { + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); + --len; + } + *offsetp = len; + return; +} + I32 -sv_eq(register SV *str1, register SV *str2) +Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) { char *pv1; STRLEN cur1; @@ -2856,7 +3631,7 @@ sv_eq(register SV *str1, register SV *str2) } I32 -sv_cmp(register SV *str1, register SV *str2) +Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) { STRLEN cur1 = 0; char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL; @@ -2882,7 +3657,7 @@ sv_cmp(register SV *str1, register SV *str2) } I32 -sv_cmp_locale(register SV *sv1, register SV *sv2) +Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) { #ifdef USE_LOCALE_COLLATE @@ -2890,7 +3665,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; @@ -2937,12 +3712,12 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) * according to the locale settings. */ char * -sv_collxfrm(SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { MAGIC *mg; 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; @@ -2953,7 +3728,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); @@ -2972,7 +3747,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; @@ -2983,7 +3758,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) #endif /* USE_LOCALE_COLLATE */ char * -sv_gets(register SV *sv, register FILE *fp, I32 append) +Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { dTHR; char *rsptr; @@ -2993,24 +3768,45 @@ sv_gets(register SV *sv, register FILE *fp, I32 append) register I32 cnt; I32 i; - sv_check_thinkfirst(sv); - if (!SvUPGRADE(sv, SVt_PV)) - return 0; + 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; @@ -3072,11 +3868,11 @@ sv_gets(register SV *sv, register FILE *fp, I32 append) bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: if (cnt > 0) { @@ -3106,24 +3902,25 @@ sv_gets(register SV *sv, register FILE *fp, I32 append) } DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", + PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; @@ -3147,12 +3944,12 @@ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -3161,8 +3958,16 @@ thats_really_all_folks: } else { +#ifndef EPOC /*The big, slow, and stupid way */ STDCHAR buf[8192]; +#else + /* Need to work around EPOC SDK features */ + /* On WINS: MS VC5 generates calls to _chkstk, */ + /* if a `large' stack frame is allocated */ + /* gcc on MARM does not generate calls like these */ + STDCHAR buf[1024]; +#endif screamer2: if (rslen) { @@ -3207,7 +4012,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') { @@ -3226,28 +4031,30 @@ screamer2: void -sv_inc(register SV *sv) +Perl_sv_inc(pTHX_ register SV *sv) { register char *d; int flags; 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) + Perl_croak(aTHX_ 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 = PTR2IV(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); @@ -3255,11 +4062,19 @@ sv_inc(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MAX) - sv_setnv(sv, (double)IV_MAX + 1.0); - else { - (void)SvIOK_only(sv); - ++SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == UV_MAX) + sv_setnv(sv, (NV)UV_MAX + 1.0); + else + (void)SvIOK_only_UV(sv); + ++SvUVX(sv); + } else { + if (SvIVX(sv) == IV_MAX) + sv_setnv(sv, (NV)IV_MAX + 1.0); + else { + (void)SvIOK_only(sv); + ++SvIVX(sv); + } } return; } @@ -3274,8 +4089,7 @@ sv_inc(register SV *sv) while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (*d) { - SET_NUMERIC_STANDARD(); - sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */ + sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */ return; } d--; @@ -3286,10 +4100,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 */ @@ -3304,27 +4132,29 @@ sv_inc(register SV *sv) } void -sv_dec(register SV *sv) +Perl_sv_dec(pTHX_ register SV *sv) { int flags; 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) + Perl_croak(aTHX_ 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 = PTR2IV(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; @@ -3332,11 +4162,22 @@ sv_dec(register SV *sv) return; } if (flags & SVp_IOK) { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (double)IV_MIN - 1.0); - else { - (void)SvIOK_only(sv); - --SvIVX(sv); + if (SvIsUV(sv)) { + if (SvUVX(sv) == 0) { + (void)SvIOK_only(sv); + SvIVX(sv) = -1; + } + else { + (void)SvIOK_only_UV(sv); + --SvUVX(sv); + } + } else { + if (SvIVX(sv) == IV_MIN) + sv_setnv(sv, (NV)IV_MIN - 1.0); + else { + (void)SvIOK_only(sv); + --SvIVX(sv); + } } return; } @@ -3347,8 +4188,7 @@ sv_dec(register SV *sv) (void)SvNOK_only(sv); return; } - SET_NUMERIC_STANDARD(); - sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */ + sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ } /* Make a string that will exist for the duration of the expression @@ -3356,181 +4196,161 @@ 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) +Perl_sv_mortalcopy(pTHX_ SV *oldstr) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setsv(sv,oldstr); - if (++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; } SV * -sv_newmortal(void) +Perl_sv_newmortal(pTHX) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; - if (++tmps_ix >= tmps_max) - sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; return sv; } /* same thing without the copying */ SV * -sv_2mortal(register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *sv) { dTHR; if (!sv) return sv; - if (SvREADONLY(sv) && 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) +Perl_newSVpv(pTHX_ const char *s, STRLEN len) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (!len) len = strlen(s); sv_setpvn(sv,s,len); return sv; } -#ifdef I_STDARG -SV * -newSVpvf(const char* pat, ...) -#else -/*VARARGS0*/ SV * -newSVpvf(pat, va_alist) -const char *pat; -va_dcl -#endif +Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { register SV *sv; - va_list args; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; -#ifdef I_STDARG + sv_setpvn(sv,s,len); + return sv; +} + +#if defined(PERL_IMPLICIT_CONTEXT) +SV * +Perl_newSVpvf_nocontext(const char* pat, ...) +{ + dTHX; + register SV *sv; + va_list args; va_start(args, pat); -#else - va_start(args); + sv = vnewSVpvf(pat, &args); + va_end(args); + return sv; +} #endif - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + +SV * +Perl_newSVpvf(pTHX_ const char* pat, ...) +{ + register SV *sv; + va_list args; + va_start(args, pat); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } +SV * +Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +{ + register SV *sv; + new_SV(sv); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} SV * -newSVnv(double n) +Perl_newSVnv(pTHX_ NV n) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setnv(sv,n); return sv; } SV * -newSViv(IV i) +Perl_newSViv(pTHX_ IV i) { register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_setiv(sv,i); return sv; } SV * -newRV(SV *ref) +Perl_newRV_noinc(pTHX_ SV *tmpRef) { dTHR; register SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); - SvTEMP_off(ref); - SvRV(sv) = SvREFCNT_inc(ref); + SvTEMP_off(tmpRef); + SvRV(sv) = tmpRef; SvROK_on(sv); return sv; } - - SV * -Perl_newRV_noinc(SV *ref) +Perl_newRV(pTHX_ 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 */ SV * -newSVsv(register SV *old) +Perl_newSVsv(pTHX_ register SV *old) { + dTHR; register SV *sv; if (!old) return Nullsv; if (SvTYPE(old) == SVTYPEMASK) { - warn("semi-panic: attempt to dup freed string"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); return Nullsv; } new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; if (SvTEMP(old)) { SvTEMP_off(old); sv_setsv(sv,old); @@ -3542,7 +4362,7 @@ newSVsv(register SV *old) } void -sv_reset(register char *s, HV *stash) +Perl_sv_reset(pTHX_ register char *s, HV *stash) { register HE *entry; register GV *gv; @@ -3550,11 +4370,14 @@ sv_reset(register char *s, HV *stash) register I32 i; register PMOP *pm; register I32 max; - char todo[256]; + char todo[PERL_UCHAR_MAX+1]; + + if (!stash) + return; if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -3566,22 +4389,28 @@ sv_reset(register char *s, HV *stash) Zero(todo, 256, char); while (*s) { - i = *s; + i = (unsigned char)*s; if (s[1] == '-') { s += 2; } - max = *s++; + max = (unsigned char)*s++; for ( ; i <= max; i++) { todo[i] = 1; } 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); @@ -3595,7 +4424,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 } @@ -3605,10 +4434,11 @@ sv_reset(register char *s, HV *stash) } IO* -sv_2io(SV *sv) +Perl_sv_2io(pTHX_ SV *sv) { IO* io; GV* gv; + STRLEN n_a; switch (SvTYPE(sv)) { case SVt_PVIO: @@ -3618,30 +4448,31 @@ sv_2io(SV *sv) gv = (GV*)sv; io = GvIO(gv); if (!io) - croak("Bad filehandle: %s", GvNAME(gv)); + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); break; default: if (!SvOK(sv)) - croak(no_usym, "filehandle"); + Perl_croak(aTHX_ 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)); + Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); break; } return io; } CV * -sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) +Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; + STRLEN n_a; if (!sv) return *gvp = Nullgv, Nullcv; @@ -3664,17 +4495,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) - croak("Not a subroutine reference"); - *gvp = Nullgv; - *st = CvSTASH(cv); - return cv; - } - if (isGV(sv)) + 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 + Perl_croak(aTHX_ "Not a subroutine reference"); + } + 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; @@ -3685,26 +4525,27 @@ 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)); + Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); } return GvCVu(gv); } } I32 -sv_true(register SV *sv) +Perl_sv_true(pTHX_ register SV *sv) { dTHR; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && @@ -3728,23 +4569,29 @@ sv_true(register SV *sv) } IV -sv_iv(register SV *sv) +Perl_sv_iv(pTHX_ register SV *sv) { - if (SvIOK(sv)) + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return (IV)SvUVX(sv); return SvIVX(sv); + } return sv_2iv(sv); } UV -sv_uv(register SV *sv) +Perl_sv_uv(pTHX_ register SV *sv) { - if (SvIOK(sv)) - return SvUVX(sv); + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); + } return sv_2uv(sv); } -double -sv_nv(register SV *sv) +NV +Perl_sv_nv(pTHX_ register SV *sv) { if (SvNOK(sv)) return SvNVX(sv); @@ -3752,7 +4599,18 @@ sv_nv(register SV *sv) } char * -sv_pvn(SV *sv, STRLEN *lp) +Perl_sv_pv(pTHX_ SV *sv) +{ + STRLEN n_a; + + if (SvPOK(sv)) + return SvPVX(sv); + + return sv_2pv(sv, &n_a); +} + +char * +Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) { if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -3762,31 +4620,21 @@ sv_pvn(SV *sv, STRLEN *lp) } char * -sv_pvn_force(SV *sv, STRLEN *lp) +Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { char *s; - if (SvREADONLY(sv)) { - dTHR; - if (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; + Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } else s = sv_2pv(sv, lp); @@ -3804,15 +4652,15 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", - (unsigned long)sv,SvPVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); } } return SvPVX(sv); } char * -sv_reftype(SV *sv, int ob) +Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) return HvNAME(SvSTASH(sv)); @@ -3836,14 +4684,14 @@ 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"; } } } int -sv_isobject(SV *sv) +Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; @@ -3858,7 +4706,7 @@ sv_isobject(SV *sv) } int -sv_isa(SV *sv, char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *name) { if (!sv) return 0; @@ -3874,26 +4722,21 @@ sv_isa(SV *sv, char *name) } SV* -newSVrv(SV *rv, char *classname) +Perl_newSVrv(pTHX_ SV *rv, const char *classname) { dTHR; SV *sv; new_SV(sv); - SvANY(sv) = 0; - SvREFCNT(sv) = 0; - SvFLAGS(sv) = 0; - sv_check_thinkfirst(rv); -#ifdef OVERLOAD + SV_CHECK_THINKFIRST(rv); 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) { @@ -3904,78 +4747,80 @@ newSVrv(SV *rv, char *classname) } SV* -sv_setref_pv(SV *rv, char *classname, void *pv) +Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) { if (!pv) { - sv_setsv(rv, &sv_undef); + sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), (IV)pv); + sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); return rv; } SV* -sv_setref_iv(SV *rv, char *classname, IV iv) +Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) { sv_setiv(newSVrv(rv,classname), iv); return rv; } SV* -sv_setref_nv(SV *rv, char *classname, double nv) +Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) { sv_setnv(newSVrv(rv,classname), nv); return rv; } SV* -sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n) +Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) { sv_setpvn(newSVrv(rv,classname), pv, n); return rv; } SV* -sv_bless(SV *sv, HV *stash) +Perl_sv_bless(pTHX_ SV *sv, HV *stash) { dTHR; - SV *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)); - } - } - SvOBJECT_on(ref); - if (SvTYPE(ref) != SVt_PVIO) - ++sv_objcount; - (void)SvUPGRADE(ref, SVt_PVMG); - SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); - -#ifdef OVERLOAD + Perl_croak(aTHX_ "Can't bless non-reference value"); + tmpRef = SvRV(sv); + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(tmpRef)) + Perl_croak(aTHX_ PL_no_modify); + if (SvOBJECT(tmpRef)) { + if (SvTYPE(tmpRef) != SVt_PVIO) + --PL_sv_objcount; + SvREFCNT_dec(SvSTASH(tmpRef)); + } + } + SvOBJECT_on(tmpRef); + if (SvTYPE(tmpRef) != SVt_PVIO) + ++PL_sv_objcount; + (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); + if (Gv_AMG(stash)) SvAMAGIC_on(sv); else SvAMAGIC_off(sv); -#endif /* OVERLOAD */ return sv; } -static void -sv_unglob(SV *sv) +STATIC void +S_sv_unglob(pTHX_ 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); @@ -3984,10 +4829,16 @@ sv_unglob(SV *sv) } void -sv_unref(SV *sv) +Perl_sv_unref(pTHX_ SV *sv) { SV* rv = SvRV(sv); - + + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + return; + } SvRV(sv) = 0; SvROK_off(sv); if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) @@ -3997,13 +4848,13 @@ sv_unref(SV *sv) } void -sv_taint(SV *sv) +Perl_sv_taint(pTHX_ SV *sv) { sv_magic((sv), Nullsv, 't', Nullch, 0); } void -sv_untaint(SV *sv) +Perl_sv_untaint(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); @@ -4013,7 +4864,7 @@ sv_untaint(SV *sv) } bool -sv_tainted(SV *sv) +Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); @@ -4024,91 +4875,143 @@ sv_tainted(SV *sv) } void -sv_setpviv(SV *sv, IV iv) +Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { - STRLEN len; - char buf[TYPE_DIGITS(UV)]; - char *ptr = buf + sizeof(buf); - int sign; - UV uv; - char *p; + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - sv_setpvn(sv, "", 0); - if (iv >= 0) { - uv = iv; - sign = 0; - } else { - uv = -iv; - sign = 1; - } - do { - *--ptr = '0' + (uv % 10); - } while (uv /= 10); - len = (buf + sizeof(buf)) - ptr; - /* taking advantage of SvCUR(sv) == 0 */ - SvGROW(sv, sign + len + 1); - p = SvPVX(sv); - if (sign) - *p++ = '-'; - memcpy(p, ptr, len); - p += len; - *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + sv_setpvn(sv, ptr, ebuf - ptr); } -#ifdef I_STDARG + void -sv_setpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ +Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) +{ + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + + sv_setpvn(sv, ptr, ebuf - ptr); + SvSETMAGIC(sv); +} + +#if defined(PERL_IMPLICIT_CONTEXT) void -sv_setpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif +Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) { + dTHX; va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); + sv_vsetpvf(sv, pat, &args); + va_end(args); +} + + +void +Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvf_mg(sv, pat, &args); + va_end(args); +} #endif - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + +void +Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvf(sv, pat, &args); va_end(args); } -#ifdef I_STDARG void -sv_catpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ +Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + void -sv_catpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif +Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); + sv_vsetpvf_mg(sv, pat, &args); + va_end(args); +} + +void +Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); +} + +#if defined(PERL_IMPLICIT_CONTEXT) +void +Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf(sv, pat, &args); + va_end(args); +} + +void +Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf_mg(sv, pat, &args); + va_end(args); +} #endif - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + +void +Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvf(sv, pat, &args); va_end(args); } void -sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + +void +Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvf_mg(sv, pat, &args); + va_end(args); +} + +void +Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); +} + +void +Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { sv_setpvn(sv, "", 0); - sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); + sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } void -sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { dTHR; char *p; @@ -4157,21 +5060,23 @@ 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; - + /* Times 4: a decimal digit takes more than 3 binary digits. + * NV_DIG: mantissa takes than many decimal digits. + * Plus 32: Playing safe. */ + char ebuf[IV_DIG * 4 + NV_DIG + 32]; + /* large enough for "%#.#f" --chip */ + /* what about long double NVs? --jhi */ char c; int i; unsigned base; IV iv; UV uv; - double nv; + NV nv; STRLEN have; STRLEN need; STRLEN gap; @@ -4258,16 +5163,24 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* SIZE */ switch (*q) { +#ifdef Quad_t + case 'L': /* Ld */ + case 'q': /* qd */ + intsize = 'q'; + q++; + break; +#endif case 'l': -#if 0 /* when quads have better support within Perl */ - if (*(q + 1) == 'l') { +#ifdef Quad_t + if (*(q + 1) == 'l') { /* lld */ intsize = 'q'; q += 2; break; - } + } #endif /* FALL THROUGH */ case 'h': + /* FALL THROUGH */ case 'V': intsize = *q++; break; @@ -4285,6 +5198,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 @@ -4303,8 +5226,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 '_': @@ -4326,14 +5260,18 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, case 'p': if (args) - uv = (UV)va_arg(*args, void*); + uv = PTR2UV(va_arg(*args, void*)); else - uv = (svix < svmax) ? (UV)svargs[svix++] : 0; + uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0; base = 16; goto integer; case 'D': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'd': case 'i': @@ -4343,6 +5281,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: iv = va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; +#ifdef Quad_t + case 'q': iv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4352,6 +5293,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: iv = (int)iv; break; case 'l': iv = (long)iv; break; case 'V': break; +#ifdef Quad_t + case 'q': iv = (Quad_t)iv; break; +#endif } } if (iv >= 0) { @@ -4367,14 +5311,26 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto integer; case 'U': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'u': base = 10; goto uns_integer; + case 'b': + base = 2; + goto uns_integer; + case 'O': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'o': base = 8; @@ -4391,6 +5347,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: uv = va_arg(*args, unsigned); break; case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; +#ifdef Quad_t + case 'q': uv = va_arg(*args, Quad_t); break; +#endif } } else { @@ -4400,6 +5359,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: uv = (unsigned)uv; break; case 'l': uv = (unsigned long)uv; break; case 'V': break; +#ifdef Quad_t + case 'q': uv = (Quad_t)uv; break; +#endif } } @@ -4408,7 +5370,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, switch (base) { unsigned dig; case 16: - p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; + if (!uv) + alt = FALSE; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); do { dig = uv & 15; *--eptr = p[dig]; @@ -4426,7 +5391,30 @@ 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) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = 'b'; + } + break; default: /* it had better be ten or less */ +#if defined(PERL_Y2KWARN) + if (ckWARN(WARN_MISC)) { + STRLEN n; + char *s = SvPV(sv,n); + if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' + && (n == 2 || !isDIGIT(s[n-3]))) + { + Perl_warner(aTHX_ WARN_MISC, + "Possible Y2K bug: %%%c %s", + c, "format string following '19'"); + } + } +#endif do { dig = uv % base; *--eptr = '0' + dig; @@ -4434,8 +5422,12 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, break; } elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis && precis > elen) - zeros = precis - elen; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; + } break; /* FLOATING POINT */ @@ -4450,7 +5442,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* This is evil, but floating point is even more evil */ if (args) - nv = va_arg(*args, double); + nv = va_arg(*args, NV); else nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0; @@ -4459,7 +5451,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, i = PERL_INT_MIN; (void)frexp(nv, &i); if (i == PERL_INT_MIN) - die("panic: frexp"); + Perl_die(aTHX_ "panic: frexp"); if (i > 0) need = BIT_DIGITS(i); } @@ -4468,15 +5460,22 @@ 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); + PL_efloatbuf[0] = '\0'; } eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; +#ifdef USE_LONG_DOUBLE + { + char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3; + while (p >= PERL_PRIfldbl) { *--eptr = *p--; } + } +#endif if (has_precis) { base = precis; do { *--eptr = '0' + (base % 10); } while (base /= 10); @@ -4496,21 +5495,14 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, *--eptr = '#'; *--eptr = '%'; - (void)sprintf(efloatbuf, eptr, nv); - - eptr = efloatbuf; - elen = strlen(efloatbuf); - -#ifdef LC_NUMERIC - /* - * User-defined locales may include arbitrary characters. - * And, unfortunately, some system may alloc the "C" locale - * to be overridden by a malicious user. - */ - if (used_locale) - *used_locale = TRUE; -#endif /* LC_NUMERIC */ + { + RESTORE_NUMERIC_STANDARD(); + (void)sprintf(PL_efloatbuf, eptr, nv); + RESTORE_NUMERIC_LOCAL(); + } + eptr = PL_efloatbuf; + elen = strlen(PL_efloatbuf); break; /* SPECIAL */ @@ -4523,6 +5515,9 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; +#ifdef Quad_t + case 'q': *(va_arg(*args, Quad_t*)) = i; break; +#endif } } else if (svix < svmax) @@ -4533,17 +5528,22 @@ 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"); - if (c) - sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", - c & 0xFF); - else + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", + (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); + if (c) { + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03"UVof"\"", + (UV)c & 0xFF); + } else sv_catpv(msg, "end of string"); - warn("%_", msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -4597,280 +5597,1105 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, } } -#ifdef DEBUGGING -void -sv_dump(SV *sv) +#if defined(USE_ITHREADS) + +#if defined(USE_THREADS) +# include "error: USE_THREADS and USE_ITHREADS are incompatible" +#endif + +#ifndef OpREFCNT_inc +# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) +#endif + +#ifndef GpREFCNT_inc +# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) +#endif + + +#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s)) +#define av_dup(s) (AV*)sv_dup((SV*)s) +#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define hv_dup(s) (HV*)sv_dup((SV*)s) +#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define cv_dup(s) (CV*)sv_dup((SV*)s) +#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define io_dup(s) (IO*)sv_dup((SV*)s) +#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s)) +#define gv_dup(s) (GV*)sv_dup((SV*)s) +#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define SAVEPV(p) (p ? savepv(p) : Nullch) +#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch) + +REGEXP * +Perl_re_dup(pTHX_ REGEXP *r) { - SV *d = sv_newmortal(); - char *s; - U32 flags; - U32 type; + /* XXX fix when pmop->op_pmregexp becomes shared */ + return ReREFCNT_inc(r); +} - if (!sv) { - PerlIO_printf(Perl_debug_log, "SV = 0\n"); - return; +PerlIO * +Perl_fp_dup(pTHX_ PerlIO *fp, char type) +{ + if (!fp) + return (PerlIO*)NULL; + return fp; /* XXX */ + /* return PerlIO_fdopen(PerlIO_fileno(fp), + type == '<' ? "r" : type == '>' ? "w" : "rw"); */ +} + +DIR * +Perl_dirp_dup(pTHX_ DIR *dp) +{ + if (!dp) + return (DIR*)NULL; + /* XXX TODO */ + return dp; +} + +GP * +Perl_gp_dup(pTHX_ GP *gp) +{ + GP *ret; + if (!gp) + return (GP*)NULL; + /* look for it in the table first */ + ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp); + if (ret) + return ret; + + /* create anew and remember what it is */ + Newz(0, ret, 1, GP); + sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret); + + /* clone */ + ret->gp_sv = sv_dup_inc(gp->gp_sv); + ret->gp_io = io_dup_inc(gp->gp_io); + ret->gp_form = cv_dup_inc(gp->gp_form); + ret->gp_av = av_dup_inc(gp->gp_av); + ret->gp_hv = hv_dup_inc(gp->gp_hv); + ret->gp_egv = 0; + ret->gp_cv = cv_dup_inc(gp->gp_cv); + ret->gp_cvgen = gp->gp_cvgen; + ret->gp_flags = gp->gp_flags; + ret->gp_line = gp->gp_line; + ret->gp_file = gp->gp_file; /* points to COP.cop_file */ + ret->gp_refcnt = 0; + return ret; +} + +MAGIC * +Perl_mg_dup(pTHX_ MAGIC *mg) +{ + MAGIC *mgret = (MAGIC*)NULL; + MAGIC *mgprev; + if (!mg) + return (MAGIC*)NULL; + /* XXX need to handle aliases here? */ + + for (; mg; mg = mg->mg_moremagic) { + MAGIC *nmg; + Newz(0, nmg, 1, MAGIC); + if (!mgret) + mgret = nmg; + else + mgprev->mg_moremagic = nmg; + nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ + nmg->mg_private = mg->mg_private; + nmg->mg_type = mg->mg_type; + nmg->mg_flags = mg->mg_flags; + if (mg->mg_type == 'r') { + nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); + } + else { + nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) + ? sv_dup_inc(mg->mg_obj) + : sv_dup(mg->mg_obj); + } + nmg->mg_len = mg->mg_len; + nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ + if (mg->mg_ptr && mg->mg_type != 'g') { + if (mg->mg_len >= 0) { + nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); + if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) { + AMT *amtp = (AMT*)mg->mg_ptr; + AMT *namtp = (AMT*)nmg->mg_ptr; + I32 i; + for (i = 1; i < NofAMmeth; i++) { + namtp->table[i] = cv_dup_inc(amtp->table[i]); + } + } + } + else if (mg->mg_len == HEf_SVKEY) + nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr); + } + mgprev = nmg; } - - 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, " ),"); + return mgret; +} + +SVTBL * +Perl_sv_table_new(pTHX) +{ + SVTBL *tbl; + Newz(0, tbl, 1, SVTBL); + tbl->tbl_max = 511; + tbl->tbl_items = 0; + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*); + return tbl; +} + +SV * +Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) +{ + SVTBLENT *tblent; + UV hash = (UV)sv; + assert(tbl); + tblent = tbl->tbl_ary[hash & tbl->tbl_max]; + for (; tblent; tblent = tblent->next) { + if (tblent->oldval == sv) + return tblent->newval; + } + return Nullsv; +} + +void +Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) +{ + SVTBLENT *tblent, **otblent; + UV hash = (UV)old; + bool i = 1; + assert(tbl); + otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; + for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { + if (tblent->oldval == old) { + tblent->newval = new; + tbl->tbl_items++; + return; + } + } + Newz(0, tblent, 1, SVTBLENT); + tblent->oldval = old; + tblent->newval = new; + tblent->next = *otblent; + *otblent = tblent; + tbl->tbl_items++; + if (i && tbl->tbl_items > tbl->tbl_max) + sv_table_split(tbl); +} + +void +Perl_sv_table_split(pTHX_ SVTBL *tbl) +{ + SVTBLENT **ary = tbl->tbl_ary; + UV oldsize = tbl->tbl_max + 1; + UV newsize = oldsize * 2; + UV i; + + Renew(ary, newsize, SVTBLENT*); + Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*); + tbl->tbl_max = --newsize; + tbl->tbl_ary = ary; + for (i=0; i < oldsize; i++, ary++) { + SVTBLENT **curentp, **entp, *ent; + if (!*ary) + continue; + curentp = ary + oldsize; + for (entp = ary, ent = *ary; ent; ent = *entp) { + if ((newsize & (UV)ent->oldval) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + continue; } + else + entp = &ent->next; } - case SVt_PVBM: - if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); - break; } +} + +#ifdef DEBUGGING +DllExport char *PL_watch_pvx; +#endif - if (*(SvEND(d) - 1) == ',') - SvPVX(d)[--SvCUR(d)] = '\0'; - sv_catpv(d, ")"); - s = SvPVX(d); +SV * +Perl_sv_dup(pTHX_ SV *sstr) +{ + U32 sflags; + int dtype; + int stype; + SV *dstr; + + if (!sstr || SvTYPE(sstr) == SVTYPEMASK) + return Nullsv; + /* look for it in the table first */ + dstr = sv_table_fetch(PL_sv_table, sstr); + if (dstr) + return dstr; + + /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */ + + /* create anew and remember what it is */ + new_SV(dstr); + sv_table_store(PL_sv_table, sstr, dstr); + + /* clone */ + SvFLAGS(dstr) = SvFLAGS(sstr); + SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ + SvREFCNT(dstr) = 0; + +#ifdef DEBUGGING + if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx) + PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", + PL_watch_pvx, SvPVX(sstr)); +#endif - PerlIO_printf(Perl_debug_log, "SV = "); - switch (type) { + switch (SvTYPE(sstr)) { case SVt_NULL: - PerlIO_printf(Perl_debug_log, "NULL%s\n", s); - return; + SvANY(dstr) = NULL; + break; case SVt_IV: - PerlIO_printf(Perl_debug_log, "IV%s\n", s); + SvANY(dstr) = new_XIV(); + SvIVX(dstr) = SvIVX(sstr); break; case SVt_NV: - PerlIO_printf(Perl_debug_log, "NV%s\n", s); + SvANY(dstr) = new_XNV(); + SvNVX(dstr) = SvNVX(sstr); break; case SVt_RV: - PerlIO_printf(Perl_debug_log, "RV%s\n", s); + SvANY(dstr) = new_XRV(); + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); break; case SVt_PV: - PerlIO_printf(Perl_debug_log, "PV%s\n", s); + SvANY(dstr) = new_XPV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; case SVt_PVIV: - PerlIO_printf(Perl_debug_log, "PVIV%s\n", s); + SvANY(dstr) = new_XPVIV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ 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); + SvANY(dstr) = new_XPVNV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ 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); + SvANY(dstr) = new_XPVMG(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; - case SVt_PVHV: - PerlIO_printf(Perl_debug_log, "PVHV%s\n", s); + case SVt_PVBM: + SvANY(dstr) = new_XPVBM(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + BmRARE(dstr) = BmRARE(sstr); + BmUSEFUL(dstr) = BmUSEFUL(sstr); + BmPREVIOUS(dstr)= BmPREVIOUS(sstr); break; - case SVt_PVCV: - PerlIO_printf(Perl_debug_log, "PVCV%s\n", s); + case SVt_PVLV: + SvANY(dstr) = new_XPVLV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ + LvTARGLEN(dstr) = LvTARGLEN(sstr); + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr)); + LvTYPE(dstr) = LvTYPE(sstr); 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); + SvANY(dstr) = new_XPVGV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + GvNAMELEN(dstr) = GvNAMELEN(sstr); + GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); + GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr)); + GvFLAGS(dstr) = GvFLAGS(sstr); + GvGP(dstr) = gp_dup(GvGP(sstr)); + (void)GpREFCNT_inc(GvGP(dstr)); + if (GvEGV(sstr) == (GV*)sstr) + GvEGV(dstr) = (GV*)dstr; + else + GvEGV(dstr) = gv_dup_inc(GvEGV(sstr)); 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)); + SvANY(dstr) = new_XPVIO(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); 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)); + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + if (IoOFP(sstr) == IoIFP(sstr)) + IoOFP(dstr) = IoIFP(dstr); + else + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + /* PL_rsfp_filters entries have fake IoDIRP() */ + if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) + IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); + else + IoDIRP(dstr) = IoDIRP(sstr); + IoLINES(dstr) = IoLINES(sstr); + IoPAGE(dstr) = IoPAGE(sstr); + IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); + IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); + IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr)); + IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr)); + IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr)); + IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); + IoTYPE(dstr) = IoTYPE(sstr); + IoFLAGS(dstr) = IoFLAGS(sstr); 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)AvFILL(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 : ""); + SvANY(dstr) = new_XPVAV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr)); + AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); + if (AvALLOC((AV*)sstr)) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((AV*)sstr) + 1; + + src_ary = AvALLOC((AV*)sstr); + Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + SvPVX(dstr) = (char*)dst_ary; + AvALLOC((AV*)dstr) = dst_ary; + if (AvREAL((AV*)sstr)) { + while (items-- > 0) + *dst_ary++ = sv_dup_inc(*src_ary++); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++); + } + items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + while (items-- > 0) { + *dst_ary++ = &PL_sv_undef; + } + } + else { + SvPVX(dstr) = Nullch; + AvALLOC((AV*)dstr) = (SV**)NULL; + } 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)); + SvANY(dstr) = new_XPVHV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + HvRITER((HV*)dstr) = HvRITER((HV*)sstr); + if (HvARRAY((HV*)sstr)) { + HE *entry; + STRLEN i = 0; + XPVHV *dxhv = (XPVHV*)SvANY(dstr); + XPVHV *sxhv = (XPVHV*)SvANY(sstr); + Newz(0, dxhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); + while (i <= sxhv->xhv_max) { + HE *dentry, *oentry; + entry = ((HE**)sxhv->xhv_array)[i]; + dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); + ((HE**)dxhv->xhv_array)[i] = dentry; + while (entry) { + entry = HeNEXT(entry); + oentry = dentry; + dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); + HeNEXT(oentry) = dentry; + } + ++i; + } + if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) { + entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter]; + while (entry && entry != sxhv->xhv_eiter) + entry = HeNEXT(entry); + dxhv->xhv_eiter = entry; + } + else + dxhv->xhv_eiter = (HE*)NULL; + } + else { + SvPVX(dstr) = Nullch; + HvEITER((HV*)dstr) = (HE*)NULL; + } + HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ + HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); 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"); + SvANY(dstr) = new_XPVFM(); + goto dup_pvcv; + /* NOTREACHED */ + case SVt_PVCV: + SvANY(dstr) = new_XPVCV(); +dup_pvcv: + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */ + CvSTART(dstr) = CvSTART(sstr); + CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); + CvXSUB(dstr) = CvXSUB(sstr); + CvXSUBANY(dstr) = CvXSUBANY(sstr); + CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvDEPTH(dstr) = CvDEPTH(sstr); + if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { + /* XXX padlists are real, but pretend to be not */ + AvREAL_on(CvPADLIST(sstr)); + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + AvREAL_off(CvPADLIST(sstr)); + AvREAL_off(CvPADLIST(dstr)); } - 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", HvNAME(GvSTASH(sv))); - 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)); + else + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + CvFLAGS(dstr) = CvFLAGS(sstr); 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)); + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); break; } + + if (SvOBJECT(dstr)) + ++PL_sv_objcount; + + return dstr; } + +PerlInterpreter * +perl_clone_using(PerlInterpreter *proto_perl, IV flags, + struct IPerlMem* ipM, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) +{ + IV i; + SV *sv; + SV **svp; + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); + +#ifdef DEBUGGING + memset(my_perl, 0x0, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; #else -void -sv_dump(SV *sv) +# if 0 + Copy(proto_perl, my_perl, 1, PerlInterpreter); +# endif +#endif + + /* XXX many of the string copies here can be optimized if they're + * constants; they need to be allocated as common memory and just + * their pointers copied. */ + + /* host pointers */ + PL_Mem = ipM; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; + + /* arena roots */ + PL_xiv_arenaroot = NULL; + PL_xiv_root = NULL; + PL_xnv_root = NULL; + PL_xrv_root = NULL; + PL_xpv_root = NULL; + PL_xpviv_root = NULL; + PL_xpvnv_root = NULL; + PL_xpvcv_root = NULL; + PL_xpvav_root = NULL; + PL_xpvhv_root = NULL; + PL_xpvmg_root = NULL; + PL_xpvlv_root = NULL; + PL_xpvbm_root = NULL; + PL_he_root = NULL; + PL_nice_chunk = NULL; + PL_nice_chunk_size = 0; + PL_sv_count = 0; + PL_sv_objcount = 0; + PL_sv_root = Nullsv; + PL_sv_arenaroot = Nullsv; + + PL_debug = proto_perl->Idebug; + + /* create SV map for pointer relocation */ + PL_sv_table = sv_table_new(); + + /* initialize these special pointers as early as possible */ + SvANY(&PL_sv_undef) = NULL; + SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; + SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; + sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef); + + SvANY(&PL_sv_no) = new_XPVNV(); + SvREFCNT(&PL_sv_no) = (~(U32)0)/2; + SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); + SvCUR(&PL_sv_no) = 0; + SvLEN(&PL_sv_no) = 1; + SvNVX(&PL_sv_no) = 0; + sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no); + + SvANY(&PL_sv_yes) = new_XPVNV(); + SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; + SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); + SvCUR(&PL_sv_yes) = 1; + SvLEN(&PL_sv_yes) = 2; + SvNVX(&PL_sv_yes) = 1; + sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes); + + /* create shared string table */ + PL_strtab = newHV(); + HvSHAREKEYS_off(PL_strtab); + hv_ksplit(PL_strtab, 512); + sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab); + + PL_compiling = proto_perl->Icompiling; + PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); + PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); + if (!specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + if (proto_perl->Tcurcop == &proto_perl->Icompiling) + PL_curcop = &PL_compiling; + else + PL_curcop = proto_perl->Tcurcop; + + /* pseudo environmental stuff */ + PL_origargc = proto_perl->Iorigargc; + i = PL_origargc; + New(0, PL_origargv, i+1, char*); + PL_origargv[i] = '\0'; + while (i-- > 0) { + PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); + } + PL_envgv = gv_dup(proto_perl->Ienvgv); + PL_incgv = gv_dup(proto_perl->Iincgv); + PL_hintgv = gv_dup(proto_perl->Ihintgv); + PL_origfilename = SAVEPV(proto_perl->Iorigfilename); + PL_diehook = sv_dup_inc(proto_perl->Idiehook); + PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook); + + /* switches */ + PL_minus_c = proto_perl->Iminus_c; + Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_localpatches = proto_perl->Ilocalpatches; + PL_splitstr = proto_perl->Isplitstr; + PL_preprocess = proto_perl->Ipreprocess; + PL_minus_n = proto_perl->Iminus_n; + PL_minus_p = proto_perl->Iminus_p; + PL_minus_l = proto_perl->Iminus_l; + PL_minus_a = proto_perl->Iminus_a; + PL_minus_F = proto_perl->Iminus_F; + PL_doswitches = proto_perl->Idoswitches; + PL_dowarn = proto_perl->Idowarn; + PL_doextract = proto_perl->Idoextract; + PL_sawampersand = proto_perl->Isawampersand; + PL_unsafe = proto_perl->Iunsafe; + PL_inplace = SAVEPV(proto_perl->Iinplace); + PL_e_script = sv_dup_inc(proto_perl->Ie_script); + PL_perldb = proto_perl->Iperldb; + PL_perl_destruct_level = proto_perl->Iperl_destruct_level; + + /* magical thingies */ + /* XXX time(&PL_basetime) instead? */ + PL_basetime = proto_perl->Ibasetime; + PL_formfeed = sv_dup(proto_perl->Iformfeed); + + PL_maxsysfd = proto_perl->Imaxsysfd; + PL_multiline = proto_perl->Imultiline; + PL_statusvalue = proto_perl->Istatusvalue; +#ifdef VMS + PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#endif + + /* shortcuts to various I/O objects */ + PL_stdingv = gv_dup(proto_perl->Istdingv); + PL_stderrgv = gv_dup(proto_perl->Istderrgv); + PL_defgv = gv_dup(proto_perl->Idefgv); + PL_argvgv = gv_dup(proto_perl->Iargvgv); + PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); + PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + + /* shortcuts to regexp stuff */ + PL_replgv = gv_dup(proto_perl->Ireplgv); + + /* shortcuts to misc objects */ + PL_errgv = gv_dup(proto_perl->Ierrgv); + + /* shortcuts to debugging objects */ + PL_DBgv = gv_dup(proto_perl->IDBgv); + PL_DBline = gv_dup(proto_perl->IDBline); + PL_DBsub = gv_dup(proto_perl->IDBsub); + PL_DBsingle = sv_dup(proto_perl->IDBsingle); + PL_DBtrace = sv_dup(proto_perl->IDBtrace); + PL_DBsignal = sv_dup(proto_perl->IDBsignal); + PL_lineary = av_dup(proto_perl->Ilineary); + PL_dbargs = av_dup(proto_perl->Idbargs); + + /* symbol tables */ + PL_defstash = hv_dup_inc(proto_perl->Tdefstash); + PL_curstash = hv_dup(proto_perl->Tcurstash); + PL_debstash = hv_dup(proto_perl->Idebstash); + PL_globalstash = hv_dup(proto_perl->Iglobalstash); + PL_curstname = sv_dup_inc(proto_perl->Icurstname); + + PL_beginav = av_dup_inc(proto_perl->Ibeginav); + PL_endav = av_dup_inc(proto_perl->Iendav); + PL_stopav = av_dup_inc(proto_perl->Istopav); + PL_initav = av_dup_inc(proto_perl->Iinitav); + + PL_sub_generation = proto_perl->Isub_generation; + + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; + + /* subprocess state */ + PL_fdpid = av_dup_inc(proto_perl->Ifdpid); + + /* internal state */ + PL_tainting = proto_perl->Itainting; + PL_maxo = proto_perl->Imaxo; + if (proto_perl->Iop_mask) + PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); + else + PL_op_mask = Nullch; + + /* current interpreter roots */ + PL_main_cv = cv_dup_inc(proto_perl->Imain_cv); + PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + PL_main_start = proto_perl->Imain_start; + PL_eval_root = proto_perl->Ieval_root; + PL_eval_start = proto_perl->Ieval_start; + + /* runtime control stuff */ + PL_curcopdb = proto_perl->Icurcopdb; + PL_copline = proto_perl->Icopline; + + PL_filemode = proto_perl->Ifilemode; + PL_lastfd = proto_perl->Ilastfd; + PL_oldname = proto_perl->Ioldname; /* XXX */ + PL_Argv = NULL; + PL_Cmd = Nullch; + PL_gensym = proto_perl->Igensym; + PL_preambled = proto_perl->Ipreambled; + PL_preambleav = av_dup_inc(proto_perl->Ipreambleav); + PL_laststatval = proto_perl->Ilaststatval; + PL_laststype = proto_perl->Ilaststype; + PL_mess_sv = Nullsv; + + PL_orslen = proto_perl->Iorslen; + PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen); + PL_ofmt = SAVEPV(proto_perl->Iofmt); + + /* interpreter atexit processing */ + PL_exitlistlen = proto_perl->Iexitlistlen; + if (PL_exitlistlen) { + New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + } + else + PL_exitlist = (PerlExitListEntry*)NULL; + PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); + + PL_profiledata = NULL; /* XXX */ + PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); + /* XXX PL_rsfp_filters entries have fake IoDIRP() */ + PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); + + PL_compcv = cv_dup(proto_perl->Icompcv); + PL_comppad = av_dup(proto_perl->Icomppad); + PL_comppad_name = av_dup(proto_perl->Icomppad_name); + PL_comppad_name_fill = proto_perl->Icomppad_name_fill; + PL_comppad_name_floor = proto_perl->Icomppad_name_floor; + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL; + +#ifdef HAVE_INTERP_INTERN + sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); +#endif + + /* more statics moved here */ + PL_generation = proto_perl->Igeneration; + PL_DBcv = cv_dup(proto_perl->IDBcv); + PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto); + + PL_in_clean_objs = proto_perl->Iin_clean_objs; + PL_in_clean_all = proto_perl->Iin_clean_all; + + PL_uid = proto_perl->Iuid; + PL_euid = proto_perl->Ieuid; + PL_gid = proto_perl->Igid; + PL_egid = proto_perl->Iegid; + PL_nomemok = proto_perl->Inomemok; + PL_an = proto_perl->Ian; + PL_cop_seqmax = proto_perl->Icop_seqmax; + PL_op_seqmax = proto_perl->Iop_seqmax; + PL_evalseq = proto_perl->Ievalseq; + PL_origenviron = proto_perl->Iorigenviron; /* XXX */ + PL_origalen = proto_perl->Iorigalen; + PL_pidstatus = newHV(); + PL_osname = SAVEPV(proto_perl->Iosname); + PL_sh_path = SAVEPV(proto_perl->Ish_path); + PL_sighandlerp = proto_perl->Isighandlerp; + + + PL_runops = proto_perl->Irunops; + + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */ + +#ifdef CSH + PL_cshlen = proto_perl->Icshlen; + PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen); +#endif + + PL_lex_state = proto_perl->Ilex_state; + PL_lex_defer = proto_perl->Ilex_defer; + PL_lex_expect = proto_perl->Ilex_expect; + PL_lex_formbrack = proto_perl->Ilex_formbrack; + PL_lex_fakebrack = proto_perl->Ilex_fakebrack; + PL_lex_dojoin = proto_perl->Ilex_dojoin; + PL_lex_starts = proto_perl->Ilex_starts; + PL_lex_stuff = Nullsv; /* XXX */ + PL_lex_repl = Nullsv; /* XXX */ + PL_lex_op = proto_perl->Ilex_op; + PL_lex_inpat = proto_perl->Ilex_inpat; + PL_lex_inwhat = proto_perl->Ilex_inwhat; + PL_lex_brackets = proto_perl->Ilex_brackets; + i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets); + PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i); + PL_lex_casemods = proto_perl->Ilex_casemods; + i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); + PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); + + Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); + Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); + PL_nexttoke = proto_perl->Inexttoke; + + PL_linestr = sv_dup_inc(proto_perl->Ilinestr); + i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_pending_ident = proto_perl->Ipending_ident; + PL_sublex_info = proto_perl->Isublex_info; /* XXX */ + + PL_expect = proto_perl->Iexpect; + + PL_multi_start = proto_perl->Imulti_start; + PL_multi_end = proto_perl->Imulti_end; + PL_multi_open = proto_perl->Imulti_open; + PL_multi_close = proto_perl->Imulti_close; + + PL_error_count = proto_perl->Ierror_count; + PL_subline = proto_perl->Isubline; + PL_subname = sv_dup_inc(proto_perl->Isubname); + + PL_min_intro_pending = proto_perl->Imin_intro_pending; + PL_max_intro_pending = proto_perl->Imax_intro_pending; + PL_padix = proto_perl->Ipadix; + PL_padix_floor = proto_perl->Ipadix_floor; + PL_pad_reset_pending = proto_perl->Ipad_reset_pending; + + i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; + PL_in_my = proto_perl->Iin_my; + PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash); +#ifdef FCRYPT + PL_cryptseen = proto_perl->Icryptseen; +#endif + + PL_hints = proto_perl->Ihints; + + PL_amagic_generation = proto_perl->Iamagic_generation; + +#ifdef USE_LOCALE_COLLATE + PL_collation_ix = proto_perl->Icollation_ix; + PL_collation_name = SAVEPV(proto_perl->Icollation_name); + PL_collation_standard = proto_perl->Icollation_standard; + PL_collxfrm_base = proto_perl->Icollxfrm_base; + PL_collxfrm_mult = proto_perl->Icollxfrm_mult; +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); + PL_numeric_standard = proto_perl->Inumeric_standard; + PL_numeric_local = proto_perl->Inumeric_local; + PL_numeric_radix = proto_perl->Inumeric_radix; +#endif /* !USE_LOCALE_NUMERIC */ + + /* utf8 character classes */ + PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum); + PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc); + PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii); + PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha); + PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space); + PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl); + PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph); + PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit); + PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper); + PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower); + PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print); + PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct); + PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark); + PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper); + PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle); + PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); + + /* swatch cache */ + PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */ + PL_last_swash_klen = 0; + PL_last_swash_key[0]= '\0'; + PL_last_swash_tmps = Nullch; + PL_last_swash_slen = 0; + + /* perly.c globals */ + PL_yydebug = proto_perl->Iyydebug; + PL_yynerrs = proto_perl->Iyynerrs; + PL_yyerrflag = proto_perl->Iyyerrflag; + PL_yychar = proto_perl->Iyychar; + PL_yyval = proto_perl->Iyyval; + PL_yylval = proto_perl->Iyylval; + + PL_glob_index = proto_perl->Iglob_index; + PL_srand_called = proto_perl->Isrand_called; + PL_uudmap['M'] = 0; /* reinit on demand */ + PL_bitcount = Nullch; /* reinit on demand */ + + + /* thrdvar.h stuff */ + +/* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo); + clone_stacks(); + PL_mainstack = av_dup(proto_perl->Tmainstack); + PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */ + init_stacks(); + + PL_op = proto_perl->Top; + PL_statbuf = proto_perl->Tstatbuf; + PL_statcache = proto_perl->Tstatcache; + PL_statgv = gv_dup(proto_perl->Tstatgv); + PL_statname = sv_dup_inc(proto_perl->Tstatname); +#ifdef HAS_TIMES + PL_timesbuf = proto_perl->Ttimesbuf; +#endif + + PL_tainted = proto_perl->Ttainted; + PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ + PL_nrs = sv_dup_inc(proto_perl->Tnrs); + PL_rs = sv_dup_inc(proto_perl->Trs); + PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv); + PL_ofslen = proto_perl->Tofslen; + PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen); + PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); + PL_chopset = proto_perl->Tchopset; /* XXX */ + PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); + PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); + PL_formtarget = sv_dup(proto_perl->Tformtarget); + + PL_restartop = proto_perl->Trestartop; + PL_in_eval = proto_perl->Tin_eval; + PL_delaymagic = proto_perl->Tdelaymagic; + PL_dirty = proto_perl->Tdirty; + PL_localizing = proto_perl->Tlocalizing; + + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; + PL_protect = proto_perl->Tprotect; + PL_errors = sv_dup_inc(proto_perl->Terrors); + PL_av_fetch_sv = Nullsv; + PL_hv_fetch_sv = Nullsv; + Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ + PL_modcount = proto_perl->Tmodcount; + PL_lastgotoprobe = Nullop; + PL_dumpindent = proto_perl->Tdumpindent; + PL_sortstash = hv_dup(proto_perl->Tsortstash); + PL_firstgv = gv_dup(proto_perl->Tfirstgv); + PL_secondgv = gv_dup(proto_perl->Tsecondgv); + PL_sortcxix = proto_perl->Tsortcxix; + PL_efloatbuf = Nullch; + PL_efloatsize = 0; + + PL_screamfirst = NULL; + PL_screamnext = NULL; + PL_maxscream = -1; + PL_lastscream = Nullsv; + + /* RE engine - function pointers */ + PL_regcompp = proto_perl->Tregcompp; + PL_regexecp = proto_perl->Tregexecp; + PL_regint_start = proto_perl->Tregint_start; + PL_regint_string = proto_perl->Tregint_string; + PL_regfree = proto_perl->Tregfree; + + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; + PL_reg_poscache = Nullch; + + PL_watchaddr = NULL; + PL_watchok = Nullch; + + return my_perl; +} + +PerlInterpreter * +perl_clone(pTHXx_ IV flags) { + return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO, + PL_Dir, PL_Sock, PL_Proc); } + +#endif /* USE_ITHREADS */ + +#ifdef PERL_OBJECT +#include "XSUB.h" #endif +static void +do_report_used(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) != SVTYPEMASK) { + PerlIO_printf(Perl_debug_log, "****\n"); + sv_dump(sv); + } +} +static void +do_clean_objs(pTHXo_ SV *sv) +{ + SV* rv; + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } + + /* XXX Might want to check arrays, etc. */ +} + +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void +do_clean_named_objs(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) == SVt_PVGV) { + if ( SvOBJECT(GvSV(sv)) || + GvAV(sv) && SvOBJECT(GvAV(sv)) || + GvHV(sv) && SvOBJECT(GvHV(sv)) || + GvIO(sv) && SvOBJECT(GvIO(sv)) || + GvCV(sv) && SvOBJECT(GvCV(sv)) ) + { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) + SvREFCNT_dec(sv); + } + } +} +#endif + +static void +do_clean_all(pTHXo_ SV *sv) +{ + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );) + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); +}