X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2790cfd85906b2d3be139c351af8625c38e3327c;hb=fcc8fcf67e5ea5f08178c9ac86509bc972ef38ff;hp=5772954c6856b16da2f2179d2f617ca44b38dd5b;hpb=1236053a2c722e2b9e93af4bb14c92036416d727;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 5772954..2790cfd 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, 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,168 +12,18 @@ */ #include "EXTERN.h" +#define PERL_IN_SV_C #include "perl.h" -#ifdef OVR_DBL_DIG -/* Use an overridden DBL_DIG */ -# ifdef DBL_DIG -# undef DBL_DIG -# endif -# define DBL_DIG OVR_DBL_DIG -#else -/* The following is all to get DBL_DIG, in order to pick a nice - default value for printing floating point numbers in Gconvert. - (see config.h) -*/ -#ifdef I_LIMITS -#include -#endif -#ifdef I_FLOAT -#include -#endif -#ifndef HAS_DBL_DIG -#define DBL_DIG 15 /* A guess that works lots of places */ -#endif -#endif - -#ifdef PERL_OBJECT -#define FCALL this->*f -#define VTBL this->*vtbl - -#else /* !PERL_OBJECT */ - -static IV asIV _((SV* sv)); -static UV asUV _((SV* sv)); -static SV *more_sv _((void)); -static void more_xiv _((void)); -static void more_xnv _((void)); -static void more_xpv _((void)); -static void more_xrv _((void)); -static XPVIV *new_xiv _((void)); -static XPVNV *new_xnv _((void)); -static XPV *new_xpv _((void)); -static XRV *new_xrv _((void)); -static void del_xiv _((XPVIV* p)); -static void del_xnv _((XPVNV* p)); -static void del_xpv _((XPV* p)); -static void del_xrv _((XRV* p)); -static void sv_unglob _((SV* sv)); - -#ifndef PURIFY -static void *my_safemalloc(MEM_SIZE size); -#endif - -typedef void (*SVFUNC) _((SV*)); -#define VTBL *vtbl #define FCALL *f - -#endif /* PERL_OBJECT */ - #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) -#ifdef PURIFY - -#define new_SV(p) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - (p) = (SV*)safemalloc(sizeof(SV)); \ - reg_add(p); \ - UNLOCK_SV_MUTEX; \ - SvANY(p) = 0; \ - SvREFCNT(p) = 1; \ - SvFLAGS(p) = 0; \ - } STMT_END - -#define del_SV(p) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - reg_remove(p); \ - Safefree((char*)(p)); \ - UNLOCK_SV_MUTEX; \ - } STMT_END - -static SV **registry; -static I32 registry_size; - -#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) - -#define REG_REPLACE(sv,a,b) \ - STMT_START { \ - void* p = sv->sv_any; \ - I32 h = REGHASH(sv, registry_size); \ - I32 i = h; \ - while (registry[i] != (a)) { \ - if (++i >= registry_size) \ - i = 0; \ - if (i == h) \ - die("SV registry bug"); \ - } \ - registry[i] = (b); \ - } STMT_END - -#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) -#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) - -static void -reg_add(sv) -SV* sv; -{ - if (PL_sv_count >= (registry_size >> 1)) - { - SV **oldreg = registry; - I32 oldsize = registry_size; - - registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; - Newz(707, registry, registry_size, SV*); - - if (oldreg) { - I32 i; - - for (i = 0; i < oldsize; ++i) { - SV* oldsv = oldreg[i]; - if (oldsv) - REG_ADD(oldsv); - } - Safefree(oldreg); - } - } - - REG_ADD(sv); - ++PL_sv_count; -} - -static void -reg_remove(sv) -SV* sv; -{ - REG_REMOVE(sv); - --PL_sv_count; -} - -static void -visit(f) -SVFUNC f; -{ - I32 i; - - for (i = 0; i < registry_size; ++i) { - SV* sv = registry[i]; - if (sv && SvTYPE(sv) != SVTYPEMASK) - (*f)(sv); - } -} - -void -sv_add_arena(ptr, size, flags) -char* ptr; -U32 size; -U32 flags; -{ - if (!(flags & SVf_FAKE)) - Safefree(ptr); -} - -#else /* ! PURIFY */ +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); /* * "A time to plant, and a time to uproot what was planted..." @@ -221,7 +71,7 @@ U32 flags; } STMT_END STATIC void -del_sv(SV *p) +S_del_sv(pTHX_ SV *p) { if (PL_debug & 32768) { SV* sva; @@ -235,7 +85,10 @@ del_sv(SV *p) ok = 1; } if (!ok) { - warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, + "Attempt to free non-arena SV: 0x%"UVxf, + PTR2UV(p)); return; } } @@ -249,12 +102,12 @@ 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; register SV* svend; - Zero(sva, size, char); + Zero(ptr, size, char); /* The first SV in an arena isn't an SV. */ SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ @@ -277,7 +130,7 @@ sv_add_arena(char *ptr, U32 size, U32 flags) /* sv_mutex must be held while calling more_sv() */ STATIC SV* -more_sv(void) +S_more_sv(pTHX) { register SV* sv; @@ -295,7 +148,7 @@ more_sv(void) } STATIC void -visit(SVFUNC f) +S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; @@ -305,95 +158,43 @@ visit(SVFUNC f) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) - (FCALL)(sv); + (FCALL)(aTHXo_ sv); } } } -#endif /* PURIFY */ - -STATIC void -do_report_used(SV *sv) -{ - if (SvTYPE(sv) != SVTYPEMASK) { - /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ - PerlIO_printf(PerlIO_stderr(), "****\n"); - sv_dump(sv); - } -} - void -sv_report_used(void) -{ - visit(FUNC_NAME_TO_PTR(do_report_used)); -} - -STATIC void -do_clean_objs(SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -STATIC void -do_clean_named_objs(SV *sv) +Perl_sv_report_used(pTHX) { - if (SvTYPE(sv) == SVt_PVGV) { - if ( SvOBJECT(GvSV(sv)) || - GvAV(sv) && SvOBJECT(GvAV(sv)) || - GvHV(sv) && SvOBJECT(GvHV(sv)) || - GvIO(sv) && SvOBJECT(GvIO(sv)) || - GvCV(sv) && SvOBJECT(GvCV(sv)) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) - SvREFCNT_dec(sv); - } - } + visit(do_report_used); } -#endif void -sv_clean_objs(void) +Perl_sv_clean_objs(pTHX) { PL_in_clean_objs = TRUE; - visit(FUNC_NAME_TO_PTR(do_clean_objs)); + visit(do_clean_objs); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); + visit(do_clean_named_objs); #endif PL_in_clean_objs = FALSE; } -STATIC void -do_clean_all(SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); -} - void -sv_clean_all(void) +Perl_sv_clean_all(pTHX) { PL_in_clean_all = TRUE; - visit(FUNC_NAME_TO_PTR(do_clean_all)); + visit(do_clean_all); PL_in_clean_all = FALSE; } void -sv_free_arenas(void) +Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; + XPV *arena, *arenanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -407,6 +208,84 @@ sv_free_arenas(void) Safefree((void *)sva); } + for (arena = PL_xiv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xiv_arenaroot = 0; + + for (arena = PL_xnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xnv_arenaroot = 0; + + for (arena = PL_xrv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xrv_arenaroot = 0; + + for (arena = PL_xpv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpv_arenaroot = 0; + + for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpviv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvnv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvcv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvav_arenaroot = 0; + + for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvhv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvmg_arenaroot = 0; + + for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvlv_arenaroot = 0; + + for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_xpvbm_arenaroot = 0; + + for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) { + arenanext = (XPV*)arena->xpv_pv; + Safefree(arena); + } + PL_he_arenaroot = 0; + if (PL_nice_chunk) Safefree(PL_nice_chunk); PL_nice_chunk = Nullch; @@ -415,8 +294,18 @@ sv_free_arenas(void) PL_sv_root = 0; } +void +Perl_report_uninit(pTHX) +{ + if (PL_op) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, + " in ", PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); +} + STATIC XPVIV* -new_xiv(void) +S_new_xiv(pTHX) { IV* xiv; LOCK_SV_MUTEX; @@ -432,7 +321,7 @@ new_xiv(void) } STATIC void -del_xiv(XPVIV *p) +S_del_xiv(pTHX_ XPVIV *p) { IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); LOCK_SV_MUTEX; @@ -442,7 +331,7 @@ del_xiv(XPVIV *p) } STATIC void -more_xiv(void) +S_more_xiv(pTHX) { register IV* xiv; register IV* xivend; @@ -463,46 +352,51 @@ more_xiv(void) } STATIC XPVNV* -new_xnv(void) +S_new_xnv(pTHX) { - double* xnv; + NV* xnv; LOCK_SV_MUTEX; if (!PL_xnv_root) more_xnv(); xnv = PL_xnv_root; - PL_xnv_root = *(double**)xnv; + PL_xnv_root = *(NV**)xnv; UNLOCK_SV_MUTEX; return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } STATIC void -del_xnv(XPVNV *p) +S_del_xnv(pTHX_ XPVNV *p) { - double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); LOCK_SV_MUTEX; - *(double**)xnv = PL_xnv_root; + *(NV**)xnv = PL_xnv_root; PL_xnv_root = xnv; UNLOCK_SV_MUTEX; } STATIC void -more_xnv(void) +S_more_xnv(pTHX) { - register double* xnv; - register double* xnvend; - New(711, xnv, 1008/sizeof(double), double); - xnvend = &xnv[1008 / sizeof(double) - 1]; - xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ + register NV* xnv; + register NV* xnvend; + XPV *ptr; + New(711, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xnv_arenaroot; + PL_xnv_arenaroot = ptr; + + xnv = (NV*) ptr; + xnvend = &xnv[1008 / sizeof(NV) - 1]; + xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */ PL_xnv_root = xnv; while (xnv < xnvend) { - *(double**)xnv = (double*)(xnv + 1); + *(NV**)xnv = (NV*)(xnv + 1); xnv++; } - *(double**)xnv = 0; + *(NV**)xnv = 0; } STATIC XRV* -new_xrv(void) +S_new_xrv(pTHX) { XRV* xrv; LOCK_SV_MUTEX; @@ -515,7 +409,7 @@ new_xrv(void) } STATIC void -del_xrv(XRV *p) +S_del_xrv(pTHX_ XRV *p) { LOCK_SV_MUTEX; p->xrv_rv = (SV*)PL_xrv_root; @@ -524,13 +418,19 @@ del_xrv(XRV *p) } STATIC void -more_xrv(void) +S_more_xrv(pTHX) { register XRV* xrv; register XRV* xrvend; - New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); - xrv = PL_xrv_root; + XPV *ptr; + New(712, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xrv_arenaroot; + PL_xrv_arenaroot = ptr; + + xrv = (XRV*) ptr; xrvend = &xrv[1008 / sizeof(XRV) - 1]; + xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1; + PL_xrv_root = xrv; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); xrv++; @@ -539,7 +439,7 @@ more_xrv(void) } STATIC XPV* -new_xpv(void) +S_new_xpv(pTHX) { XPV* xpv; LOCK_SV_MUTEX; @@ -552,7 +452,7 @@ new_xpv(void) } STATIC void -del_xpv(XPV *p) +S_del_xpv(pTHX_ XPV *p) { LOCK_SV_MUTEX; p->xpv_pv = (char*)PL_xpv_root; @@ -561,13 +461,16 @@ del_xpv(XPV *p) } STATIC void -more_xpv(void) +S_more_xpv(pTHX) { register XPV* xpv; register XPV* xpvend; - New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); - xpv = PL_xpv_root; + New(713, xpv, 1008/sizeof(XPV), XPV); + xpv->xpv_pv = (char*)PL_xpv_arenaroot; + PL_xpv_arenaroot = xpv; + xpvend = &xpv[1008 / sizeof(XPV) - 1]; + PL_xpv_root = ++xpv; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); xpv++; @@ -575,162 +478,511 @@ more_xpv(void) xpv->xpv_pv = 0; } -#ifdef PURIFY -#define new_XIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XIV(p) Safefree((char*)p) -#else -#define new_XIV() (void*)new_xiv() -#define del_XIV(p) del_xiv((XPVIV*) p) -#endif +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; +} -#ifdef PURIFY -#define new_XNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XNV(p) Safefree((char*)p) -#else -#define new_XNV() (void*)new_xnv() -#define del_XNV(p) del_xnv((XPVNV*) p) -#endif +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; +} -#ifdef PURIFY -#define new_XRV() (void*)safemalloc(sizeof(XRV)) -#define del_XRV(p) Safefree((char*)p) -#else -#define new_XRV() (void*)new_xrv() -#define del_XRV(p) del_xrv((XRV*) p) -#endif +STATIC void +S_more_xpviv(pTHX) +{ + register XPVIV* xpviv; + register XPVIV* xpvivend; + New(714, xpviv, 1008/sizeof(XPVIV), XPVIV); + xpviv->xpv_pv = (char*)PL_xpviv_arenaroot; + PL_xpviv_arenaroot = xpviv; + + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + PL_xpviv_root = ++xpviv; + while (xpviv < xpvivend) { + xpviv->xpv_pv = (char*)(xpviv + 1); + xpviv++; + } + xpviv->xpv_pv = 0; +} -#ifdef PURIFY -#define new_XPV() (void*)safemalloc(sizeof(XPV)) -#define del_XPV(p) Safefree((char*)p) -#else -#define new_XPV() (void*)new_xpv() -#define del_XPV(p) del_xpv((XPV *)p) -#endif +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; +} -#ifdef PURIFY -# define my_safemalloc(s) safemalloc(s) -# define my_safefree(s) safefree(s) -#else -STATIC void* -my_safemalloc(MEM_SIZE size) +STATIC void +S_del_xpvnv(pTHX_ XPVNV *p) { - char *p; - New(717, p, size, char); - return (void*)p; -} -# define my_safefree(s) Safefree(s) -#endif - -#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) my_safefree((char*)p) - -#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) my_safefree((char*)p) - -#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) my_safefree((char*)p) - -#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) my_safefree((char*)p) - -#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) my_safefree((char*)p) - -#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) my_safefree((char*)p) - -#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) my_safefree((char*)p) - -#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) my_safefree((char*)p) - -#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) my_safefree((char*)p) - -#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) + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvnv_root; + PL_xpvnv_root = p; + UNLOCK_SV_MUTEX; +} -bool -sv_upgrade(register SV *sv, U32 mt) +STATIC void +S_more_xpvnv(pTHX) { - char* pv; - U32 cur; - U32 len; - IV iv; - double nv; - MAGIC* magic; - HV* stash; + register XPVNV* xpvnv; + register XPVNV* xpvnvend; + New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV); + xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot; + PL_xpvnv_arenaroot = xpvnv; + + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + PL_xpvnv_root = ++xpvnv; + while (xpvnv < xpvnvend) { + xpvnv->xpv_pv = (char*)(xpvnv + 1); + xpvnv++; + } + xpvnv->xpv_pv = 0; +} - if (SvTYPE(sv) == mt) - return TRUE; +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; +} - if (mt < SVt_PVIV) - (void)SvOOK_off(sv); +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; +} - switch (SvTYPE(sv)) { - case SVt_NULL: - pv = 0; - cur = 0; - len = 0; - iv = 0; - nv = 0.0; - magic = 0; - stash = 0; - break; - case SVt_IV: - pv = 0; - cur = 0; - len = 0; - iv = SvIVX(sv); - nv = (double)SvIVX(sv); - del_XIV(SvANY(sv)); - magic = 0; - stash = 0; - if (mt == SVt_NV) - mt = SVt_PVNV; - else if (mt < SVt_PVIV) - mt = SVt_PVIV; - break; - case SVt_NV: - pv = 0; - cur = 0; - len = 0; - nv = SvNVX(sv); - iv = I_V(nv); - magic = 0; - stash = 0; - del_XNV(SvANY(sv)); - SvANY(sv) = 0; - if (mt < SVt_PVNV) - mt = SVt_PVNV; - break; - case SVt_RV: - pv = (char*)SvRV(sv); - cur = 0; - len = 0; - iv = (IV)pv; - nv = (double)(unsigned long)pv; - del_XRV(SvANY(sv)); - magic = 0; - stash = 0; - break; - case SVt_PV: - pv = SvPVX(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = 0; - nv = 0.0; - magic = 0; - stash = 0; - del_XPV(SvANY(sv)); - if (mt <= SVt_IV) - mt = SVt_PVIV; - else if (mt == SVt_NV) - mt = SVt_PVNV; +STATIC void +S_more_xpvcv(pTHX) +{ + register XPVCV* xpvcv; + register XPVCV* xpvcvend; + New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV); + xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot; + PL_xpvcv_arenaroot = xpvcv; + + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + PL_xpvcv_root = ++xpvcv; + 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, xpvav, 1008/sizeof(XPVAV), XPVAV); + xpvav->xav_array = (char*)PL_xpvav_arenaroot; + PL_xpvav_arenaroot = xpvav; + + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + PL_xpvav_root = ++xpvav; + 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, xpvhv, 1008/sizeof(XPVHV), XPVHV); + xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot; + PL_xpvhv_arenaroot = xpvhv; + + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + PL_xpvhv_root = ++xpvhv; + 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, xpvmg, 1008/sizeof(XPVMG), XPVMG); + xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot; + PL_xpvmg_arenaroot = xpvmg; + + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + PL_xpvmg_root = ++xpvmg; + 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, xpvlv, 1008/sizeof(XPVLV), XPVLV); + xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot; + PL_xpvlv_arenaroot = xpvlv; + + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + PL_xpvlv_root = ++xpvlv; + 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, xpvbm, 1008/sizeof(XPVBM), XPVBM); + xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot; + PL_xpvbm_arenaroot = xpvbm; + + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + PL_xpvbm_root = ++xpvbm; + while (xpvbm < xpvbmend) { + xpvbm->xpv_pv = (char*)(xpvbm + 1); + xpvbm++; + } + xpvbm->xpv_pv = 0; +} + +#ifdef LEAKTEST +# define my_safemalloc(s) (void*)safexmalloc(717,s) +# define my_safefree(p) safexfree((char*)p) +#else +# define my_safemalloc(s) (void*)safemalloc(s) +# define my_safefree(p) safefree((char*)p) +#endif + +#ifdef PURIFY + +#define new_XIV() my_safemalloc(sizeof(XPVIV)) +#define del_XIV(p) my_safefree(p) + +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) + +#define new_XRV() my_safemalloc(sizeof(XRV)) +#define del_XRV(p) my_safefree(p) + +#define new_XPV() my_safemalloc(sizeof(XPV)) +#define del_XPV(p) my_safefree(p) + +#define new_XPVIV() my_safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) my_safefree(p) + +#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree(p) + +#define new_XPVCV() my_safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) my_safefree(p) + +#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) + +#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree(p) + +#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree(p) + +#define new_XPVLV() my_safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) my_safefree(p) + +#define new_XPVBM() my_safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) my_safefree(p) + +#else /* !PURIFY */ + +#define new_XIV() (void*)new_xiv() +#define del_XIV(p) del_xiv((XPVIV*) p) + +#define new_XNV() (void*)new_xnv() +#define del_XNV(p) del_xnv((XPVNV*) p) + +#define new_XRV() (void*)new_xrv() +#define del_XRV(p) del_xrv((XRV*) p) + +#define new_XPV() (void*)new_xpv() +#define del_XPV(p) del_xpv((XPV *)p) + +#define new_XPVIV() (void*)new_xpviv() +#define del_XPVIV(p) del_xpviv((XPVIV *)p) + +#define new_XPVNV() (void*)new_xpvnv() +#define del_XPVNV(p) del_xpvnv((XPVNV *)p) + +#define new_XPVCV() (void*)new_xpvcv() +#define del_XPVCV(p) del_xpvcv((XPVCV *)p) + +#define new_XPVAV() (void*)new_xpvav() +#define del_XPVAV(p) del_xpvav((XPVAV *)p) + +#define new_XPVHV() (void*)new_xpvhv() +#define del_XPVHV(p) del_xpvhv((XPVHV *)p) + +#define new_XPVMG() (void*)new_xpvmg() +#define del_XPVMG(p) del_xpvmg((XPVMG *)p) + +#define new_XPVLV() (void*)new_xpvlv() +#define del_XPVLV(p) del_xpvlv((XPVLV *)p) + +#define new_XPVBM() (void*)new_xpvbm() +#define del_XPVBM(p) del_xpvbm((XPVBM *)p) + +#endif /* PURIFY */ + +#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree(p) + +#define new_XPVFM() my_safemalloc(sizeof(XPVFM)) +#define del_XPVFM(p) my_safefree(p) + +#define new_XPVIO() my_safemalloc(sizeof(XPVIO)) +#define del_XPVIO(p) my_safefree(p) + +/* +=for apidoc sv_upgrade + +Upgrade an SV to a more complex form. Use C. See +C. + +=cut +*/ + +bool +Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) +{ + char* pv; + U32 cur; + U32 len; + IV iv; + NV nv; + MAGIC* magic; + HV* stash; + + if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } + + if (SvTYPE(sv) == mt) + return TRUE; + + if (mt < SVt_PVIV) + (void)SvOOK_off(sv); + + switch (SvTYPE(sv)) { + case SVt_NULL: + pv = 0; + cur = 0; + len = 0; + iv = 0; + nv = 0.0; + magic = 0; + stash = 0; + break; + case SVt_IV: + pv = 0; + cur = 0; + len = 0; + iv = SvIVX(sv); + nv = (NV)SvIVX(sv); + del_XIV(SvANY(sv)); + magic = 0; + stash = 0; + if (mt == SVt_NV) + mt = SVt_PVNV; + else if (mt < SVt_PVIV) + mt = SVt_PVIV; + break; + case SVt_NV: + pv = 0; + cur = 0; + len = 0; + nv = SvNVX(sv); + iv = I_V(nv); + magic = 0; + stash = 0; + del_XNV(SvANY(sv)); + SvANY(sv) = 0; + if (mt < SVt_PVNV) + mt = SVt_PVNV; + break; + case SVt_RV: + pv = (char*)SvRV(sv); + cur = 0; + len = 0; + iv = PTR2IV(pv); + nv = PTR2NV(pv); + del_XRV(SvANY(sv)); + magic = 0; + stash = 0; + break; + case SVt_PV: + pv = SvPVX(sv); + cur = SvCUR(sv); + len = SvLEN(sv); + iv = 0; + nv = 0.0; + magic = 0; + stash = 0; + del_XPV(SvANY(sv)); + if (mt <= SVt_IV) + mt = SVt_PVIV; + else if (mt == SVt_NV) + mt = SVt_PVNV; break; case SVt_PVIV: pv = SvPVX(sv); @@ -763,12 +1015,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; @@ -929,7 +1181,7 @@ sv_upgrade(register SV *sv, U32 mt) } int -sv_backoff(register SV *sv) +Perl_sv_backoff(pTHX_ register SV *sv) { assert(SvOOK(sv)); if (SvIVX(sv)) { @@ -943,14 +1195,25 @@ sv_backoff(register SV *sv) return 0; } +/* +=for apidoc sv_grow + +Expands the character buffer in the SV. This will use C and will +upgrade the SV to C. Returns a pointer to the character buffer. +Use C. + +=cut +*/ + char * -sv_grow(register SV *sv, register STRLEN newlen) +Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); + PerlIO_printf(Perl_debug_log, + "Allocation too large: %"UVxf"\n", (UV)newlen); my_exit(1); } #endif /* HAS_64K_LIMIT */ @@ -974,7 +1237,7 @@ sv_grow(register SV *sv, register STRLEN newlen) s = SvPVX(sv); if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { -#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) +#if defined(MYMALLOC) && !defined(LEAKTEST) STRLEN l = malloced_size((void*)SvPVX(sv)); if (newlen <= l) { SvLEN_set(sv, l); @@ -991,8 +1254,17 @@ sv_grow(register SV *sv, register STRLEN newlen) return s; } +/* +=for apidoc sv_setiv + +Copies an integer into the given SV. Does not handle 'set' magic. See +C. + +=cut +*/ + void -sv_setiv(register SV *sv, IV i) +Perl_sv_setiv(pTHX_ register SV *sv, IV i) { SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { @@ -1015,7 +1287,7 @@ sv_setiv(register SV *sv, IV i) case SVt_PVIO: { dTHR; - croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), PL_op_desc[PL_op->op_type]); } } @@ -1024,31 +1296,64 @@ sv_setiv(register SV *sv, IV i) SvTAINT(sv); } +/* +=for apidoc sv_setiv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setiv_mg(register SV *sv, IV i) +Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) { sv_setiv(sv,i); SvSETMAGIC(sv); } +/* +=for apidoc sv_setuv + +Copies an unsigned integer into the given SV. Does not handle 'set' magic. +See C. + +=cut +*/ + void -sv_setuv(register SV *sv, UV u) +Perl_sv_setuv(pTHX_ register SV *sv, UV u) { - if (u <= IV_MAX) - sv_setiv(sv, u); - else - sv_setnv(sv, (double)u); + sv_setiv(sv, 0); + SvIsUV_on(sv); + SvUVX(sv) = u; } +/* +=for apidoc sv_setuv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setuv_mg(register SV *sv, UV u) +Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { sv_setuv(sv,u); SvSETMAGIC(sv); } +/* +=for apidoc sv_setnv + +Copies a double into the given SV. Does not handle 'set' magic. See +C. + +=cut +*/ + void -sv_setnv(register SV *sv, double num) +Perl_sv_setnv(pTHX_ register SV *sv, NV num) { SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { @@ -1070,7 +1375,7 @@ sv_setnv(register SV *sv, double num) case SVt_PVIO: { dTHR; - croak("Can't coerce %s to number in %s", sv_reftype(sv,0), + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), PL_op_name[PL_op->op_type]); } } @@ -1079,15 +1384,23 @@ sv_setnv(register SV *sv, double num) SvTAINT(sv); } +/* +=for apidoc sv_setnv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setnv_mg(register SV *sv, double num) +Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) { sv_setnv(sv,num); SvSETMAGIC(sv); } STATIC void -not_a_number(SV *sv) +S_not_a_number(pTHX_ SV *sv) { dTHR; char tmpbuf[64]; @@ -1135,14 +1448,26 @@ not_a_number(SV *sv) *d = '\0'; if (PL_op) - warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_name[PL_op->op_type]); + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric in %s", tmpbuf, + PL_op_desc[PL_op->op_type]); else - warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric", tmpbuf); } +/* the number can be converted to integer with atol() 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 */ +#define IS_NUMBER_INFINITY 0x10 /* this is big */ + +/* 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; @@ -1151,10 +1476,7 @@ sv_2iv(register SV *sv) if (SvIOKp(sv)) return SvIVX(sv); if (SvNOKp(sv)) { - if (SvNVX(sv) < 0.0) - return I_V(SvNVX(sv)); - else - return (IV) U_V(SvNVX(sv)); + return I_V(SvNVX(sv)); } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); @@ -1162,7 +1484,7 @@ sv_2iv(register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1170,62 +1492,114 @@ sv_2iv(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvIV(tmpstr); - return (IV)SvRV(sv); + 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); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_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 { /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = Atol(SvPVX(sv)); + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } } else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_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; @@ -1241,7 +1615,7 @@ sv_2uv(register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1249,58 +1623,143 @@ sv_2uv(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvUV(tmpstr); - return (UV)SvRV(sv); + return PTR2UV(SvRV(sv)); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_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); + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_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", + PTR2UV(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; @@ -1312,16 +1771,19 @@ sv_2nv(register SV *sv) dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); - SET_NUMERIC_STANDARD(); - return atof(SvPVX(sv)); + return Atof(SvPVX(sv)); } - if (SvIOKp(sv)) - return (double)SvIVX(sv); + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + return (NV)SvIVX(sv); + } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1329,22 +1791,15 @@ sv_2nv(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && + (SvRV(tmpstr) != SvRV(sv))) return SvNV(tmpstr); - return (double)(unsigned long)SvRV(sv); + return PTR2NV(SvRV(sv)); } - if (SvREADONLY(sv)) { + if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; - if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) - not_a_number(sv); - SET_NUMERIC_STANDARD(); - return atof(SvPVX(sv)); - } - if (SvIOKp(sv)) - return (double)SvIVX(sv); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0.0; } } @@ -1353,87 +1808,134 @@ 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({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, + "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_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)) { dTHR; if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); - SET_NUMERIC_STANDARD(); - SvNVX(sv) = atof(SvPVX(sv)); + SvNVX(sv) = Atof(SvPVX(sv)); } else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_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({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif return SvNVX(sv); } STATIC IV -asIV(SV *sv) +S_asIV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); - double d; + NV d; - if (numtype == 1) - return atol(SvPVX(sv)); + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return Atol(SvPVX(sv)); if (!numtype) { dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - SET_NUMERIC_STANDARD(); - d = atof(SvPVX(sv)); - if (d < 0.0) - return I_V(d); - else - return (IV) U_V(d); + d = Atof(SvPVX(sv)); + return I_V(d); } STATIC UV -asUV(SV *sv) +S_asUV(pTHX_ SV *sv) { I32 numtype = looks_like_number(sv); #ifdef HAS_STRTOUL - if (numtype == 1) - 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) { dTHR; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } - SET_NUMERIC_STANDARD(); - return U_V(atof(SvPVX(sv))); + return U_V(Atof(SvPVX(sv))); } +/* + * Returns a combination of (advisory only - can get false negatives) + * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, + * IS_NUMBER_NEG + * 0 if does not look like number. + * + * In fact possible values are 0 and + * IS_NUMBER_TO_INT_BY_ATOL 123 + * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 + * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * IS_NUMBER_INFINITY + * with a possible addition of IS_NUMBER_NEG. + */ + +/* +=for apidoc looks_like_number + +Test if an the content of an SV looks like a number (or is a +number). + +=cut +*/ + 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; + I32 sawinf = 0; STRLEN len; if (SvPOK(sv)) { - sbegin = SvPVX(sv); + sbegin = SvPVX(sv); len = SvCUR(sv); } else if (SvPOKp(sv)) @@ -1445,23 +1947,50 @@ looks_like_number(SV *sv) s = sbegin; while (isSPACE(*s)) s++; - if (*s == '+' || *s == '-') + if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') s++; - /* next must be digit or '.' */ + nbegin = s; + /* + * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted + * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need + * (int)atof(). + */ + + /* next must be digit or the radix separator or beginning of infinity */ 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++; @@ -1470,52 +1999,89 @@ looks_like_number(SV *sv) else return 0; } + else if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'F' && *s != 'f') return 0; + s++; if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'I' && *s != 'i') return 0; + s++; if (*s != 'T' && *s != 't') return 0; + s++; if (*s != 'Y' && *s != 'y') return 0; + } + sawinf = 1; + } 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; - s++; - if (*s == '+' || *s == '-') + if (sawinf) + numtype = IS_NUMBER_INFINITY; + else { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; + if (*s == '+' || *s == '-') + s++; + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } } while (isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(sbegin, "0 but true", 10)) - return 1; + return IS_NUMBER_TO_INT_BY_ATOL; return 0; } char * -sv_2pv_nolen(register SV *sv) +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) +{ + char *ptr = buf + TYPE_CHARS(UV); + char *ebuf = ptr; + int sign; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + char * -sv_2pv(register SV *sv, STRLEN *lp) +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; @@ -1528,13 +2094,15 @@ 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; } @@ -1542,7 +2110,7 @@ sv_2pv(register SV *sv, STRLEN *lp) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; return ""; @@ -1551,7 +2119,8 @@ sv_2pv(register SV *sv, STRLEN *lp) if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && + (SvRV(tmpstr) != SvRV(sv))) return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) @@ -1562,7 +2131,7 @@ sv_2pv(register SV *sv, STRLEN *lp) switch (SvTYPE(sv)) { case SVt_PVMG: if ( ((SvFLAGS(sv) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + (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'))) { @@ -1577,7 +2146,7 @@ sv_2pv(register SV *sv, STRLEN *lp) int right = 4; U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; - while(ch = *fptr++) { + while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } @@ -1612,7 +2181,10 @@ sv_2pv(register SV *sv, STRLEN *lp) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: s = "SCALAR"; break; + case SVt_PVBM: if (SvROK(sv)) + s = "REF"; + else + s = "SCALAR"; break; case SVt_PVLV: s = "LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; @@ -1624,41 +2196,32 @@ sv_2pv(register SV *sv, STRLEN *lp) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) - sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); - sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv); + 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; - } - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); *lp = 0; return ""; } } - (void)SvUPGRADE(sv, SVt_PV); - if (SvNOKp(sv)) { + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ + /* I tried changing this 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); + /* The +20 is pure guesswork. Configure test needed. --jhi */ + SvGROW(sv, NV_DIG + 20); s = SvPVX(sv); olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo @@ -1667,8 +2230,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 @@ -1682,29 +2244,48 @@ sv_2pv(register SV *sv, STRLEN *lp) #endif } else if (SvIOKp(sv)) { - U32 oldIOK = SvIOK(sv); + U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpviv(sv, SvIVX(sv)); - errno = olderrno; + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); - if (oldIOK) + *s = '\0'; + if (isIOK) SvIOK_on(sv); else SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); + SvPOK_on(sv); } else { dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) + && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + { + report_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: @@ -1747,9 +2328,36 @@ sv_2pv(register SV *sv, STRLEN *lp) } } +char * +Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pvbyte(sv, &n_a); +} + +char * +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + +char * +Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pvutf8(sv, &n_a); +} + +char * +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_upgrade(sv); + return sv_2pv(sv,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); @@ -1759,7 +2367,8 @@ sv_2bool(register SV *sv) if (SvROK(sv)) { dTHR; SV* tmpsv; - if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) + if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && + (SvRV(tmpsv) != SvRV(sv))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -1785,13 +2394,135 @@ sv_2bool(register SV *sv) } } +/* +=for apidoc sv_utf8_upgrade + +Convert the PV of an SV to its UTF8-encoded form. + +=cut +*/ + +void +Perl_sv_utf8_upgrade(pTHX_ register SV *sv) +{ + char *s, *t; + bool hibit; + + if (!sv || !SvPOK(sv) || SvUTF8(sv)) + return; + + /* This function could be much more efficient if we had a FLAG in SVs + * to signal if there are any hibit chars in the PV. + */ + for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++) + if (*t & 0x80) + hibit = TRUE; + + if (hibit) { + STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); + SvCUR(sv) = len - 1; + SvLEN(sv) = len; /* No longer know the real size. */ + SvUTF8_on(sv); + Safefree(s); /* No longer using what was there before. */ + } +} + +/* +=for apidoc sv_utf8_downgrade + +Attempt to convert the PV of an SV from UTF8-encoded to byte encoding. +This may not be possible if the PV contains non-byte encoding characters; +if this is the case, either returns false or, if C is not +true, croaks. + +=cut +*/ + +bool +Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) +{ + if (SvPOK(sv) && SvUTF8(sv)) { + char *c = SvPVX(sv); + STRLEN len = SvCUR(sv) + 1; /* include trailing NUL */ + if (!utf8_to_bytes((U8*)c, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + PL_op_desc[PL_op->op_type]); + else + Perl_croak(aTHX_ "Wide character"); + } + } + SvCUR(sv) = len - 1; + SvUTF8_off(sv); + } + return TRUE; +} + +/* +=for apidoc sv_utf8_encode + +Convert the PV of an SV to UTF8-encoded, but then turn off the C +flag so that it looks like bytes again. Nothing calls this. + +=cut +*/ + +void +Perl_sv_utf8_encode(pTHX_ register SV *sv) +{ + sv_utf8_upgrade(sv); + SvUTF8_off(sv); +} + +bool +Perl_sv_utf8_decode(pTHX_ register SV *sv) +{ + if (SvPOK(sv)) { + char *c; + bool has_utf = FALSE; + if (!sv_utf8_downgrade(sv, TRUE)) + return FALSE; + + /* it is actually just a matter of turning the utf8 flag on, but + * we want to make sure everything inside is valid utf8 first. + */ + c = SvPVX(sv); + if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) + return FALSE; + + while (c < SvEND(sv)) { + if (*c++ & 0x80) { + SvUTF8_on(sv); + break; + } + } + } + return TRUE; +} + + /* Note: sv_setsv() should not be called with a source string that needs * to be reused, since it may destroy the source string if it is marked * as temporary. */ +/* +=for apidoc sv_setsv + +Copies the contents of the source SV C into the destination SV C. +The source SV may be destroyed if it is mortal. Does not handle 'set' +magic. See the macro forms C, C and +C. + +=cut +*/ + void -sv_setsv(SV *dstr, register SV *sstr) +Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { dTHR; register U32 sflags; @@ -1834,6 +2565,8 @@ sv_setsv(SV *dstr, register SV *sstr) } (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); SvTAINT(dstr); return; } @@ -1866,8 +2599,11 @@ sv_setsv(SV *dstr, register SV *sstr) SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_on(dstr); + } GvMULTI_on(dstr); return; } @@ -1892,10 +2628,10 @@ sv_setsv(SV *dstr, register SV *sstr) case SVt_PVCV: case SVt_PVIO: if (PL_op) - croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), + Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), PL_op_name[PL_op->op_type]); else - croak("Bizarre copy of %s", sv_reftype(sstr, 0)); + Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); break; case SVt_PVGV: @@ -1905,7 +2641,7 @@ sv_setsv(SV *dstr, register SV *sstr) char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); - sv_magic(dstr, dstr, '*', name, len); + sv_magic(dstr, dstr, '*', Nullch, 0); GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; @@ -1914,15 +2650,18 @@ sv_setsv(SV *dstr, register SV *sstr) /* ahem, death to those who redefine active sort subs */ else if (PL_curstackinfo->si_type == PERLSI_SORT && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) - croak("Can't redefine active sort subroutine %s", + Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); GvINTRO_off(dstr); /* one-shot flag */ gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_on(dstr); + } GvMULTI_on(dstr); return; } @@ -1954,12 +2693,12 @@ sv_setsv(SV *dstr, register SV *sstr) if (intro) { GP *gp; - GvGP(dstr)->gp_refcnt--; + gp_free((GV*)dstr); GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); GvSV(dstr) = NEWSV(72,0); - GvLINE(dstr) = PL_curcop->cop_line; + GvLINE(dstr) = CopLINE(PL_curcop); GvEGV(dstr) = (GV*)dstr; } GvMULTI_on(dstr); @@ -1970,8 +2709,11 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (!GvIMPORTED_AV(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_AV_on(dstr); + } break; case SVt_PVHV: if (intro) @@ -1979,8 +2721,11 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (!GvIMPORTED_HV(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_HV_on(dstr); + } break; case SVt_PVCV: if (intro) { @@ -2000,29 +2745,28 @@ 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)); + SV *const_sv; /* ahem, death to those who redefine * active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) - croak( + Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) { - if (!(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) - warner(WARN_REDEFINE, const_sv ? - "Constant subroutine %s redefined" - : "Subroutine %s redefined", - GvENAME((GV*)dstr)); - } + /* Redefining a sub - warning is mandatory if + it was a const and its value changed. */ + if (ckWARN(WARN_REDEFINE) + || (CvCONST(cv) + && (!CvCONST((CV*)sref) + || sv_cmp(cv_const_sv(cv), + cv_const_sv((CV*)sref))))) + { + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) + ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2032,8 +2776,11 @@ sv_setsv(SV *dstr, register SV *sstr) GvASSUMECV_on(dstr); PL_sub_generation++; } - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (!GvIMPORTED_CV(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_CV_on(dstr); + } break; case SVt_PVIO: if (intro) @@ -2042,14 +2789,24 @@ sv_setsv(SV *dstr, register SV *sstr) dref = (SV*)GvIOp(dstr); GvIOp(dstr) = (IO*)sref; break; + case SVt_PVFM: + if (intro) + SAVESPTR(GvFORM(dstr)); + else + dref = (SV*)GvFORM(dstr); + GvFORM(dstr) = (CV*)sref; + break; default: if (intro) SAVESPTR(GvSV(dstr)); else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) + if (!GvIMPORTED_SV(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { GvIMPORTED_SV_on(dstr); + } break; } if (dref) @@ -2061,7 +2818,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; } } @@ -2075,6 +2833,8 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (sflags & SVf_IVisUV) + SvIsUV_on(dstr); } if (SvAMAGIC(sstr)) { SvAMAGIC_on(dstr); @@ -2091,22 +2851,24 @@ sv_setsv(SV *dstr, register SV *sstr) if (SvTEMP(sstr) && /* slated for free anyway? */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ - !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ + !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ + SvLEN(sstr)) /* and really is a string */ { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ if (SvOOK(dstr)) { SvFLAGS(dstr) &= ~SVf_OOK; Safefree(SvPVX(dstr) - SvIVX(dstr)); } - else + else if (SvLEN(dstr)) Safefree(SvPVX(dstr)); } (void)SvPOK_only(dstr); SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); + SvTEMP_off(dstr); - (void)SvOK_off(sstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); @@ -2121,6 +2883,8 @@ sv_setsv(SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } + if ((sflags & SVf_UTF8) && !IN_BYTE) + SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOK_on(dstr); @@ -2129,24 +2893,31 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + if (sflags & SVf_IVisUV) + SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - if (SvIOK(sstr)) { + if (sflags & SVf_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + if (sflags & SVf_IVisUV) + SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); + if (sflags & SVf_IVisUV) + SvIsUV_on(dstr); } else { if (dtype == SVt_PVGV) { - if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Undefined value assigned to typeglob"); + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob"); } else (void)SvOK_off(dstr); @@ -2154,15 +2925,32 @@ sv_setsv(SV *dstr, register SV *sstr) SvTAINT(dstr); } +/* +=for apidoc sv_setsv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setsv_mg(SV *dstr, register SV *sstr) +Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) { sv_setsv(dstr,sstr); SvSETMAGIC(dstr); } +/* +=for apidoc sv_setpvn + +Copies a string into an SV. The C parameter indicates the number of +bytes to be copied. Does not handle 'set' magic. See C. + +=cut +*/ + void -sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { register char *dptr; assert(len >= 0); /* STRLEN is probably unsigned, so this may @@ -2183,15 +2971,32 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) SvTAINT(sv); } -void -sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len) +/* +=for apidoc sv_setpvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { sv_setpvn(sv,ptr,len); SvSETMAGIC(sv); } +/* +=for apidoc sv_setpv + +Copies a string into an SV. The string must be null-terminated. Does not +handle 'set' magic. See C. + +=cut +*/ + void -sv_setpv(register SV *sv, register const char *ptr) +Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; @@ -2210,15 +3015,37 @@ sv_setpv(register SV *sv, register const char *ptr) SvTAINT(sv); } +/* +=for apidoc sv_setpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setpv_mg(register SV *sv, register const char *ptr) +Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) { sv_setpv(sv,ptr); SvSETMAGIC(sv); } +/* +=for apidoc sv_usepvn + +Tells an SV to use C to find its string value. Normally the string is +stored inside the SV but sv_usepvn allows the SV to use an outside string. +The C should point to memory that was allocated by C. The +string length, C, must be supplied. This function will realloc the +memory pointed to by C, so that pointer should not be freed or used by +the programmer after giving it to sv_usepvn. Does not handle 'set' magic. +See C. + +=cut +*/ + void -sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { SV_CHECK_THINKFIRST(sv); (void)SvUPGRADE(sv, SVt_PV); @@ -2227,7 +3054,7 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) return; } (void)SvOOK_off(sv); - if (SvPVX(sv)) + if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); SvPVX(sv) = ptr; @@ -2238,31 +3065,61 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) SvTAINT(sv); } +/* +=for apidoc sv_usepvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { sv_usepvn(sv,ptr,len); SvSETMAGIC(sv); } void -sv_force_normal(register SV *sv) +Perl_sv_force_normal(pTHX_ register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (PL_curcop != &PL_compiling) - croak(PL_no_modify); + if (SvFAKE(sv)) { + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + U32 hash = SvUVX(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + SvFAKE_off(sv); + SvREADONLY_off(sv); + unsharepvn(pvx,len,hash); + } + else 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); } - + +/* +=for apidoc sv_chop + +Efficient removal of characters from the beginning of the string buffer. +SvPOK(sv) must be true and the C must be a pointer to somewhere inside +the string buffer. The C becomes the first character of the adjusted +string. + +=cut +*/ + 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 */ + + { register STRLEN delta; @@ -2273,10 +3130,17 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { + if (!SvLEN(sv)) { /* make copy of shared string */ + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } SvIVX(sv) = 0; SvFLAGS(sv) |= SVf_OOK; } - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK); + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; @@ -2284,8 +3148,18 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in SvIVX(sv) += delta; } +/* +=for apidoc sv_catpvn + +Concatenates the string onto the end of the string which is in the SV. The +C indicates number of bytes to copy. Handles 'get' magic, but not +'set' magic. See C. + +=cut +*/ + void -sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { STRLEN tlen; char *junk; @@ -2297,37 +3171,78 @@ sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len) Move(ptr,SvPVX(sv)+tlen,len,char); SvCUR(sv) += len; *SvEND(sv) = '\0'; - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } +/* +=for apidoc sv_catpvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { sv_catpvn(sv,ptr,len); SvSETMAGIC(sv); } +/* +=for apidoc sv_catsv + +Concatenates the string from SV C onto the end of the string in SV +C. Handles 'get' magic, but not 'set' magic. See C. + +=cut +*/ + void -sv_catsv(SV *dstr, register SV *sstr) +Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { char *s; STRLEN len; if (!sstr) return; - if (s = SvPV(sstr, len)) - sv_catpvn(dstr,s,len); + if ((s = SvPV(sstr, len))) { + if (DO_UTF8(sstr)) { + sv_utf8_upgrade(dstr); + sv_catpvn(dstr,s,len); + SvUTF8_on(dstr); + } + else + sv_catpvn(dstr,s,len); + } } +/* +=for apidoc sv_catsv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_catsv_mg(SV *dstr, register SV *sstr) +Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) { sv_catsv(dstr,sstr); SvSETMAGIC(dstr); } +/* +=for apidoc sv_catpv + +Concatenates the string onto the end of the string which is in the SV. +Handles 'get' magic, but not 'set' magic. See C. + +=cut +*/ + void -sv_catpv(register SV *sv, register const char *ptr) +Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) { register STRLEN len; STRLEN tlen; @@ -2342,22 +3257,30 @@ sv_catpv(register SV *sv, register const char *ptr) ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR(sv) += len; - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } +/* +=for apidoc sv_catpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_catpv_mg(register SV *sv, register const char *ptr) +Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) { sv_catpv(sv,ptr); SvSETMAGIC(sv); } SV * -newSV(STRLEN len) +Perl_newSV(pTHX_ STRLEN len) { register SV *sv; - + new_SV(sv); if (len) { sv_upgrade(sv, SVt_PV); @@ -2368,15 +3291,23 @@ newSV(STRLEN len) /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ +/* +=for apidoc sv_magic + +Adds magic to an SV. + +=cut +*/ + void -sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) +Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { MAGIC* mg; - + if (SvREADONLY(sv)) { dTHR; if (PL_curcop != &PL_compiling && !strchr("gBf", how)) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2406,7 +3337,7 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); - + switch (how) { case 0: mg->mg_virtual = &PL_vtbl_sv; @@ -2508,6 +3439,9 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) case '.': mg->mg_virtual = &PL_vtbl_pos; break; + case '<': + mg->mg_virtual = &PL_vtbl_backref; + break; case '~': /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ @@ -2515,15 +3449,23 @@ sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen) SvRMAGICAL_on(sv); break; default: - croak("Don't know how to handle magic of type '%c'", how); + Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how); } mg_magical(sv); if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } +/* +=for apidoc sv_unmagic + +Removes magic from an SV. + +=cut +*/ + int -sv_unmagic(SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *sv, int type) { MAGIC* mg; MAGIC** mgp; @@ -2534,8 +3476,8 @@ sv_unmagic(SV *sv, int type) if (mg->mg_type == type) { MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; - if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(sv, mg); + if (vtbl && vtbl->svt_free) + CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2556,8 +3498,82 @@ sv_unmagic(SV *sv, int type) return 0; } +/* +=for apidoc sv_rvweaken + +Weaken a reference. + +=cut +*/ + +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--; + } +} + +/* +=for apidoc sv_insert + +Inserts a string at the specified offset/length within the SV. Similar to +the Perl substr() function. + +=cut +*/ + 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; @@ -2565,17 +3581,19 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *bigend; register I32 i; STRLEN curlen; - + if (!bigstr) - croak("Can't modify non-existent substring"); + Perl_croak(aTHX_ "Can't modify non-existent substring"); SvPV_force(bigstr, curlen); + (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); SvCUR_set(bigstr, offset+len); } + SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); @@ -2602,7 +3620,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) { @@ -2618,7 +3636,7 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) SvCUR_set(bigstr, mid - big); } /*SUPPRESS 560*/ - else if (i = mid - big) { /* faster from front */ + else if ((i = mid - big)) { /* faster from front */ midend -= littlelen; mid = midend; sv_chop(bigstr,midend-i); @@ -2639,15 +3657,22 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) SvSETMAGIC(bigstr); } -/* make sv point to what nstr did */ +/* +=for apidoc sv_replace + +Make the first argument a copy of the second, then delete the original. + +=cut +*/ void -sv_replace(register SV *sv, register SV *nsv) +Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { + dTHR; U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); - if (SvREFCNT(nsv) != 1) - warn("Reference miscount in sv_replace()"); + if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -2667,8 +3692,17 @@ sv_replace(register SV *sv, register SV *nsv) del_SV(nsv); } +/* +=for apidoc sv_clear + +Clear an SV, making it empty. Does not free the memory used by the SV +itself. + +=cut +*/ + void -sv_clear(register SV *sv) +Perl_sv_clear(pTHX_ register SV *sv) { HV* stash; assert(sv); @@ -2698,8 +3732,8 @@ sv_clear(register SV *sv) PUSHMARK(SP); PUSHs(&tmpref); PUTBACK; - perl_call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); + call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; POPSTACK; SPAGAIN; @@ -2711,7 +3745,7 @@ sv_clear(register SV *sv) if (SvREFCNT(sv)) { if (PL_in_clean_objs) - croak("DESTROY created new reference to dead object '%s'", + Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", HvNAME(stash)); /* DESTROY gave object new lease on life */ return; @@ -2735,12 +3769,11 @@ sv_clear(register SV *sv) IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) { - io_close((IO*)sv); + io_close((IO*)sv, FALSE); } - if (IoDIRP(sv)) { + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) PerlDir_close(IoDIRP(sv)); - IoDIRP(sv) = 0; - } + IoDIRP(sv) = (DIR*)NULL; Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2777,10 +3810,18 @@ 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)); + else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { + unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv)); + SvFAKE_off(sv); + } break; /* case SVt_NV: @@ -2850,16 +3891,25 @@ sv_clear(register SV *sv) } SV * -sv_newref(SV *sv) +Perl_sv_newref(pTHX_ SV *sv) { if (sv) ATOMIC_INC(SvREFCNT(sv)); return sv; } +/* +=for apidoc sv_free + +Free the memory used by an SV. + +=cut +*/ + void -sv_free(SV *sv) +Perl_sv_free(pTHX_ SV *sv) { + dTHR; int refcount_is_zero; if (!sv) @@ -2874,7 +3924,8 @@ sv_free(SV *sv) SvREFCNT(sv) = (~(U32)0)/2; return; } - warn("Attempt to free unreferenced scalar"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); return; } ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); @@ -2882,7 +3933,10 @@ sv_free(SV *sv) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%"UVxf, + PTR2UV(sv)); return; } #endif @@ -2896,8 +3950,16 @@ sv_free(SV *sv) del_SV(sv); } +/* +=for apidoc sv_len + +Returns the length of the string in the SV. See also C. + +=cut +*/ + STRLEN -sv_len(register SV *sv) +Perl_sv_len(pTHX_ register SV *sv) { char *junk; STRLEN len; @@ -2912,8 +3974,17 @@ sv_len(register SV *sv) return len; } +/* +=for apidoc sv_len_utf8 + +Returns the number of characters in the string in an SV, counting wide +UTF8 bytes as a single character. + +=cut +*/ + STRLEN -sv_len_utf8(register SV *sv) +Perl_sv_len_utf8(pTHX_ register SV *sv) { U8 *s; U8 *send; @@ -2938,7 +4009,7 @@ sv_len_utf8(register SV *sv) } void -sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) +Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { U8 *start; U8 *s; @@ -2969,7 +4040,7 @@ sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) } void -sv_pos_b2u(register SV *sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) { U8 *s; U8 *send; @@ -2980,7 +4051,7 @@ sv_pos_b2u(register SV *sv, I32* offsetp) s = (U8*)SvPV(sv, len); if (len < *offsetp) - croak("panic: bad byte offset"); + Perl_croak(aTHX_ "panic: bad byte offset"); send = s + *offsetp; len = 0; while (s < send) { @@ -2988,67 +4059,152 @@ sv_pos_b2u(register SV *sv, I32* offsetp) ++len; } if (s != send) { - warn("Malformed UTF-8 character"); + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); --len; } *offsetp = len; return; } +/* +=for apidoc sv_eq + +Returns a boolean indicating whether the strings in the two SVs are +identical. + +=cut +*/ + I32 -sv_eq(register SV *str1, register SV *str2) +Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) { char *pv1; STRLEN cur1; char *pv2; STRLEN cur2; + I32 eq = 0; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (!str1) { + if (!sv1) { pv1 = ""; cur1 = 0; } else - pv1 = SvPV(str1, cur1); + pv1 = SvPV(sv1, cur1); - if (!str2) - return !cur1; + if (!sv2){ + pv2 = ""; + cur2 = 0; + } else - pv2 = SvPV(str2, cur2); + pv2 = SvPV(sv2, cur2); - if (cur1 != cur2) - return 0; + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (SvUTF8(sv1)) { + pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); + pv2tmp = TRUE; + } + else { + pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); + pv1tmp = TRUE; + } + } + + if (cur1 == cur2) + eq = memEQ(pv1, pv2, cur1); + + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); - return memEQ(pv1, pv2, cur1); + return eq; } +/* +=for apidoc sv_cmp + +Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the +string in C is less than, equal to, or greater than the string in +C. + +=cut +*/ + I32 -sv_cmp(register SV *str1, register SV *str2) +Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { - STRLEN cur1 = 0; - char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL; - STRLEN cur2 = 0; - char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL; - I32 retval; + STRLEN cur1, cur2; + char *pv1, *pv2; + I32 cmp; + bool pv1tmp = FALSE; + bool pv2tmp = FALSE; - if (!cur1) - return cur2 ? -1 : 0; + if (!sv1) { + pv1 = ""; + cur1 = 0; + } + else + pv1 = SvPV(sv1, cur1); - if (!cur2) - return 1; + if (!sv2){ + pv2 = ""; + cur2 = 0; + } + else + pv2 = SvPV(sv2, cur2); - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + /* do not utf8ize the comparands as a side-effect */ + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (SvUTF8(sv1)) { + pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); + pv2tmp = TRUE; + } + else { + pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); + pv1tmp = TRUE; + } + } - if (retval) - return retval < 0 ? -1 : 1; + if (!cur1) { + cmp = cur2 ? -1 : 0; + } else if (!cur2) { + cmp = 1; + } else { + I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + if (retval) { + cmp = retval < 0 ? -1 : 1; + } else if (cur1 == cur2) { + cmp = 0; + } else { + cmp = cur1 < cur2 ? -1 : 1; + } + } - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; + if (pv1tmp) + Safefree(pv1); + if (pv2tmp) + Safefree(pv2); + + return cmp; } +/* +=for apidoc sv_cmp_locale + +Compares the strings in two SVs in a locale-aware manner. See +L + +=cut +*/ + 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 @@ -3103,7 +4259,7 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) * according to the locale settings. */ char * -sv_collxfrm(SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { MAGIC *mg; @@ -3148,8 +4304,17 @@ sv_collxfrm(SV *sv, STRLEN *nxp) #endif /* USE_LOCALE_COLLATE */ +/* +=for apidoc sv_gets + +Get a line from the filehandle and store it into the SV, optionally +appending to the currently-stored string. + +=cut +*/ + char * -sv_gets(register SV *sv, register PerlIO *fp, I32 append) +Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { dTHR; char *rsptr; @@ -3214,7 +4379,7 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) /* See if we know enough about I/O mechanism to cheat it ! */ /* This used to be #ifdef test - it is made run-time test for ease - of abstracting out stdio interface. One call should be cheap + of abstracting out stdio interface. One call should be cheap enough here - and may even be a macro allowing compile time optimization. */ @@ -3259,11 +4424,11 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: if (cnt > 0) { @@ -3275,8 +4440,8 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) } } else { - Copy(ptr, bp, cnt, char); /* this | eat */ - bp += cnt; /* screams | dust */ + Copy(ptr, bp, cnt, char); /* this | eat */ + bp += cnt; /* screams | dust */ ptr += cnt; /* louder | sed :-) */ cnt = 0; } @@ -3293,24 +4458,25 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) } DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt)); + "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", + PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n", - (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp), - (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); - /* This used to call 'filbuf' in stdio form, but as that behaves like + "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; @@ -3334,12 +4500,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, @@ -3348,8 +4514,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) { @@ -3394,7 +4568,7 @@ screamer2: } } - if (RsPARA(PL_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') { @@ -3404,16 +4578,20 @@ screamer2: } } -#ifdef WIN32 - win32_strip_return(sv); -#endif - return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } +/* +=for apidoc sv_inc + +Auto-increment of the value in the SV. + +=cut +*/ + void -sv_inc(register SV *sv) +Perl_sv_inc(pTHX_ register SV *sv) { register char *d; int flags; @@ -3426,13 +4604,13 @@ sv_inc(register SV *sv) if (SvREADONLY(sv)) { dTHR; if (PL_curcop != &PL_compiling) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); } if (SvROK(sv)) { IV i; if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; - i = (IV)SvRV(sv); + i = PTR2IV(SvRV(sv)); sv_unref(sv); sv_setiv(sv, i); } @@ -3444,11 +4622,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; } @@ -3463,8 +4649,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--; @@ -3479,7 +4664,7 @@ sv_inc(register SV *sv) /* 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 + * 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') { @@ -3506,8 +4691,16 @@ sv_inc(register SV *sv) *d = d[1]; } +/* +=for apidoc sv_dec + +Auto-decrement of the value in the SV. + +=cut +*/ + void -sv_dec(register SV *sv) +Perl_sv_dec(pTHX_ register SV *sv) { int flags; @@ -3519,13 +4712,13 @@ sv_dec(register SV *sv) if (SvREADONLY(sv)) { dTHR; if (PL_curcop != &PL_compiling) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); } if (SvROK(sv)) { IV i; if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; - i = (IV)SvRV(sv); + i = PTR2IV(SvRV(sv)); sv_unref(sv); sv_setiv(sv, i); } @@ -3537,11 +4730,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; } @@ -3552,17 +4756,25 @@ 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 */ } +/* +=for apidoc sv_mortalcopy + +Creates a new SV which is a copy of the original SV. The new SV is marked +as mortal. + +=cut +*/ + /* Make a string that will exist for the duration of the expression * evaluation. Actually, it may have to last longer than that, but * hopefully we won't free it until it has been assigned to a * permanent location. */ SV * -sv_mortalcopy(SV *oldstr) +Perl_sv_mortalcopy(pTHX_ SV *oldstr) { dTHR; register SV *sv; @@ -3575,8 +4787,16 @@ sv_mortalcopy(SV *oldstr) return sv; } +/* +=for apidoc sv_newmortal + +Creates a new SV which is mortal. The reference count of the SV is set to 1. + +=cut +*/ + SV * -sv_newmortal(void) +Perl_sv_newmortal(pTHX) { dTHR; register SV *sv; @@ -3588,10 +4808,19 @@ sv_newmortal(void) return sv; } +/* +=for apidoc sv_2mortal + +Marks an SV as mortal. The SV will be destroyed when the current context +ends. + +=cut +*/ + /* same thing without the copying */ SV * -sv_2mortal(register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *sv) { dTHR; if (!sv) @@ -3604,8 +4833,18 @@ sv_2mortal(register SV *sv) return sv; } +/* +=for apidoc newSVpv + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. If C is zero, Perl will compute the length using +strlen(). For efficiency, consider using C instead. + +=cut +*/ + SV * -newSVpv(const char *s, STRLEN len) +Perl_newSVpv(pTHX_ const char *s, STRLEN len) { register SV *sv; @@ -3616,8 +4855,19 @@ newSVpv(const char *s, STRLEN len) return sv; } +/* +=for apidoc newSVpvn + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. + +=cut +*/ + SV * -newSVpvn(const char *s, STRLEN len) +Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { register SV *sv; @@ -3626,22 +4876,90 @@ newSVpvn(const char *s, STRLEN len) return sv; } +/* +=for apidoc newSVpvn_share + +Creates a new SV and populates it with a string from +the string table. Turns on READONLY and FAKE. +The idea here is that as string table is used for shared hash +keys these strings will have SvPVX == HeKEY and hash lookup +will avoid string compare. + +=cut +*/ + +SV * +Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash) +{ + register SV *sv; + if (!hash) + PERL_HASH(hash, src, len); + new_SV(sv); + sv_upgrade(sv, SVt_PVIV); + SvPVX(sv) = sharepvn(src, len, hash); + SvCUR(sv) = len; + SvUVX(sv) = hash; + SvLEN(sv) = 0; + SvREADONLY_on(sv); + SvFAKE_on(sv); + SvPOK_on(sv); + return sv; +} + +#if defined(PERL_IMPLICIT_CONTEXT) SV * -newSVpvf(const char* pat, ...) +Perl_newSVpvf_nocontext(const char* pat, ...) { + dTHX; register SV *sv; va_list args; + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + return sv; +} +#endif - new_SV(sv); +/* +=for apidoc newSVpvf + +Creates a new SV an initialize it with the string formatted like +C. + +=cut +*/ + +SV * +Perl_newSVpvf(pTHX_ const char* pat, ...) +{ + register SV *sv; + va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } +SV * +Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +{ + register SV *sv; + new_SV(sv); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +/* +=for apidoc newSVnv + +Creates a new SV and copies a floating point value into it. +The reference count for the SV is set to 1. + +=cut +*/ SV * -newSVnv(double n) +Perl_newSVnv(pTHX_ NV n) { register SV *sv; @@ -3650,8 +4968,17 @@ newSVnv(double n) return sv; } +/* +=for apidoc newSViv + +Creates a new SV and copies an integer into it. The reference count for the +SV is set to 1. + +=cut +*/ + SV * -newSViv(IV i) +Perl_newSViv(pTHX_ IV i) { register SV *sv; @@ -3660,8 +4987,36 @@ newSViv(IV i) return sv; } +/* +=for apidoc newSVuv + +Creates a new SV and copies an unsigned integer into it. +The reference count for the SV is set to 1. + +=cut +*/ + +SV * +Perl_newSVuv(pTHX_ UV u) +{ + register SV *sv; + + new_SV(sv); + sv_setuv(sv,u); + return sv; +} + +/* +=for apidoc newRV_noinc + +Creates an RV wrapper for an SV. The reference count for the original +SV is B incremented. + +=cut +*/ + SV * -newRV_noinc(SV *tmpRef) +Perl_newRV_noinc(pTHX_ SV *tmpRef) { dTHR; register SV *sv; @@ -3674,23 +5029,34 @@ newRV_noinc(SV *tmpRef) return sv; } +/* newRV_inc is #defined to newRV in sv.h */ SV * -newRV(SV *tmpRef) +Perl_newRV(pTHX_ SV *tmpRef) { return newRV_noinc(SvREFCNT_inc(tmpRef)); } +/* +=for apidoc newSVsv + +Creates a new SV which is an exact duplicate of the original SV. + +=cut +*/ + /* 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); @@ -3705,7 +5071,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; @@ -3713,7 +5079,7 @@ sv_reset(register char *s, HV *stash) register I32 i; register PMOP *pm; register I32 max; - char todo[256]; + char todo[PERL_UCHAR_MAX+1]; if (!stash) return; @@ -3732,11 +5098,11 @@ sv_reset(register char *s, HV *stash) Zero(todo, 256, char); while (*s) { - i = *s; + i = (unsigned char)*s; if (s[1] == '-') { s += 2; } - max = *s++; + max = (unsigned char)*s++; for ( ; i <= max; i++) { todo[i] = 1; } @@ -3766,7 +5132,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 !defined( VMS) && !defined(EPOC) /* VMS has no environ array */ if (gv == PL_envgv) environ[0] = Nullch; #endif @@ -3777,7 +5143,7 @@ sv_reset(register char *s, HV *stash) } IO* -sv_2io(SV *sv) +Perl_sv_2io(pTHX_ SV *sv) { IO* io; GV* gv; @@ -3791,11 +5157,11 @@ sv_2io(SV *sv) gv = (GV*)sv; io = GvIO(gv); if (!io) - croak("Bad filehandle: %s", GvNAME(gv)); + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); break; default: if (!SvOK(sv)) - croak(PL_no_usym, "filehandle"); + Perl_croak(aTHX_ PL_no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO); @@ -3804,14 +5170,14 @@ sv_2io(SV *sv) else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); break; } return io; } CV * -sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) +Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; @@ -3852,7 +5218,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) else if(isGV(sv)) gv = (GV*)sv; else - croak("Not a subroutine reference"); + Perl_croak(aTHX_ "Not a subroutine reference"); } else if (isGV(sv)) gv = (GV*)sv; @@ -3868,20 +5234,31 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) ENTER; tmpsv = NEWSV(704,0); gv_efullname3(tmpsv, gv, Nullch); + /* XXX this is probably not what they think they're getting. + * It has the same effect as "sub name;", i.e. just a forward + * declaration! */ newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, tmpsv), Nullop, Nullop); LEAVE; if (!GvCVu(gv)) - croak("Unable to create sub named \"%s\"", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); } return GvCVu(gv); } } +/* +=for apidoc sv_true + +Returns true if the SV has a true value by Perl's rules. + +=cut +*/ + I32 -sv_true(register SV *sv) +Perl_sv_true(pTHX_ register SV *sv) { dTHR; if (!sv) @@ -3889,8 +5266,7 @@ sv_true(register SV *sv) if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && - (*tXpv->xpv_pv > '0' || - tXpv->xpv_cur > 1 || + (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) return 1; else @@ -3909,23 +5285,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); @@ -3933,7 +5315,7 @@ sv_nv(register SV *sv) } char * -sv_pv(SV *sv) +Perl_sv_pv(pTHX_ SV *sv) { STRLEN n_a; @@ -3944,7 +5326,7 @@ sv_pv(SV *sv) } char * -sv_pvn(SV *sv, STRLEN *lp) +Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) { if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -3953,28 +5335,36 @@ sv_pvn(SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } +/* +=for apidoc sv_pvn_force + +Get a sensible string out of the SV somehow. + +=cut +*/ + char * -sv_pvn_force(SV *sv, STRLEN *lp) +Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { char *s; 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) { dTHR; - croak("Can't coerce %s to string in %s", sv_reftype(sv,0), + Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), PL_op_name[PL_op->op_type]); } else s = sv_2pv(sv, lp); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; - + if (SvROK(sv)) sv_unref(sv); (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */ @@ -3986,15 +5376,71 @@ 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_pvbyte(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * +Perl_sv_pvutf8(pTHX_ SV *sv) +{ + sv_utf8_upgrade(sv); + return sv_pv(sv); +} + +char * +Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_upgrade(sv); + return sv_pvn(sv,lp); +} + +/* +=for apidoc sv_pvutf8n_force + +Get a sensible UTF8-encoded string out of the SV somehow. See +L. + +=cut +*/ + +char * +Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_upgrade(sv); + return sv_pvn_force(sv,lp); +} + +/* +=for apidoc sv_reftype + +Returns a string describing what the SV is a reference to. + +=cut +*/ + +char * +Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) return HvNAME(SvSTASH(sv)); @@ -4019,13 +5465,24 @@ sv_reftype(SV *sv, int ob) case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; case SVt_PVFM: return "FORMAT"; + case SVt_PVIO: return "IO"; default: return "UNKNOWN"; } } } +/* +=for apidoc sv_isobject + +Returns a boolean indicating whether the SV is an RV pointing to a blessed +object. If the SV is not an RV, or if the object is not blessed, then this +will return false. + +=cut +*/ + int -sv_isobject(SV *sv) +Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; @@ -4039,8 +5496,18 @@ sv_isobject(SV *sv) return 1; } +/* +=for apidoc sv_isa + +Returns a boolean indicating whether the SV is blessed into the specified +class. This does not check for subtypes; use C to verify +an inheritance relationship. + +=cut +*/ + int -sv_isa(SV *sv, const char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *name) { if (!sv) return 0; @@ -4055,8 +5522,19 @@ sv_isa(SV *sv, const char *name) return strEQ(HvNAME(SvSTASH(sv)), name); } +/* +=for apidoc newSVrv + +Creates a new SV for the RV, C, to point to. If C is not an RV then +it will be upgraded to one. If C is non-null then the new SV will +be blessed in the specified package. The new SV is returned and its +reference count is 1. + +=cut +*/ + SV* -newSVrv(SV *rv, const char *classname) +Perl_newSVrv(pTHX_ SV *rv, const char *classname) { dTHR; SV *sv; @@ -4066,8 +5544,23 @@ newSVrv(SV *rv, const char *classname) SV_CHECK_THINKFIRST(rv); SvAMAGIC_off(rv); + if (SvTYPE(rv) >= SVt_PVMG) { + U32 refcnt = SvREFCNT(rv); + SvREFCNT(rv) = 0; + sv_clear(rv); + SvFLAGS(rv) = 0; + SvREFCNT(rv) = refcnt; + } + if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_RV); + else if (SvTYPE(rv) > SVt_RV) { + (void)SvOOK_off(rv); + if (SvPVX(rv) && SvLEN(rv)) + Safefree(SvPVX(rv)); + SvCUR_set(rv, 0); + SvLEN_set(rv, 0); + } (void)SvOK_off(rv); SvRV(rv) = sv; @@ -4080,50 +5573,117 @@ newSVrv(SV *rv, const char *classname) return sv; } +/* +=for apidoc sv_setref_pv + +Copies a pointer into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. If the C argument is NULL then C will be placed +into the SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +Do not use with other Perl types such as HV, AV, SV, CV, because those +objects will become corrupted by the pointer copy process. + +Note that C copies the string while this copies the pointer. + +=cut +*/ + SV* -sv_setref_pv(SV *rv, const char *classname, void *pv) +Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) { if (!pv) { sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), (IV)pv); + sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); return rv; } +/* +=for apidoc sv_setref_iv + +Copies an integer into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +=cut +*/ + SV* -sv_setref_iv(SV *rv, const char *classname, IV iv) +Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) { sv_setiv(newSVrv(rv,classname), iv); return rv; } +/* +=for apidoc sv_setref_nv + +Copies a double into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +=cut +*/ + SV* -sv_setref_nv(SV *rv, const char *classname, double nv) +Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) { sv_setnv(newSVrv(rv,classname), nv); return rv; } +/* +=for apidoc sv_setref_pvn + +Copies a string into a new SV, optionally blessing the SV. The length of the +string must be specified with C. The C argument will be upgraded to +an RV. That RV will be modified to point to the new SV. The C +argument indicates the package for the blessing. Set C to +C to avoid the blessing. The new SV will be returned and will have +a reference count of 1. + +Note that C copies the pointer while this copies the string. + +=cut +*/ + SV* -sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n) +Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) { sv_setpvn(newSVrv(rv,classname), pv, n); return rv; } +/* +=for apidoc sv_bless + +Blesses an SV into a specified package. The SV must be an RV. The package +must be designated by its stash (see C). The reference count +of the SV is unaffected. + +=cut +*/ + SV* -sv_bless(SV *sv, HV *stash) +Perl_sv_bless(pTHX_ SV *sv, HV *stash) { dTHR; SV *tmpRef; if (!SvROK(sv)) - croak("Can't bless non-reference value"); + Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { if (SvREADONLY(tmpRef)) - croak(PL_no_modify); + Perl_croak(aTHX_ PL_no_modify); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) --PL_sv_objcount; @@ -4145,8 +5705,10 @@ sv_bless(SV *sv, HV *stash) } STATIC void -sv_unglob(SV *sv) +S_sv_unglob(pTHX_ SV *sv) { + void *xpvmg; + assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); if (GvGP(sv)) @@ -4158,15 +5720,38 @@ sv_unglob(SV *sv) sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); GvMULTI_off(sv); + + /* need to keep SvANY(sv) in the right arena */ + xpvmg = new_XPVMG(); + StructCopy(SvANY(sv), xpvmg, XPVMG); + del_XPVGV(SvANY(sv)); + SvANY(sv) = xpvmg; + SvFLAGS(sv) &= ~SVTYPEMASK; SvFLAGS(sv) |= SVt_PVMG; } +/* +=for apidoc sv_unref + +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C. See C. + +=cut +*/ + 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)) @@ -4176,13 +5761,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'); @@ -4192,135 +5777,264 @@ 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'); - if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) + if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv))) return TRUE; } return FALSE; } +/* +=for apidoc sv_setpviv + +Copies an integer into the given SV, also updating its string value. +Does not handle 'set' magic. See C. + +=cut +*/ + 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); } +/* +=for apidoc sv_setpviv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void -sv_setpviv_mg(SV *sv, IV iv) +Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { - sv_setpviv(sv,iv); + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + + sv_setpvn(sv, ptr, ebuf - ptr); SvSETMAGIC(sv); } +#if defined(PERL_IMPLICIT_CONTEXT) void -sv_setpvf(SV *sv, const char* pat, ...) +Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) { + dTHX; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf(sv, pat, &args); va_end(args); } void -sv_setpvf_mg(SV *sv, const char* pat, ...) +Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) { + dTHX; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf_mg(sv, pat, &args); va_end(args); - SvSETMAGIC(sv); } +#endif + +/* +=for apidoc sv_setpvf + +Processes its arguments like C and sets an SV to the formatted +output. Does not handle 'set' magic. See C. + +=cut +*/ void -sv_catpvf(SV *sv, const char* pat, ...) +Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf(sv, pat, &args); va_end(args); } void -sv_catpvf_mg(SV *sv, const char* pat, ...) +Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + +/* +=for apidoc sv_setpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_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 -sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) { - sv_setpvn(sv, "", 0); - sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf(sv, pat, &args); + va_end(args); } void -sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) +Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) { - dTHR; - char *p; - char *q; - char *patend; - STRLEN origlen; - I32 svix = 0; - static char nullstr[] = "(null)"; + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf_mg(sv, pat, &args); + va_end(args); +} +#endif - /* no matter what, this is a string now */ - (void)SvPV_force(sv, origlen); +/* +=for apidoc sv_catpvf - /* special-case "", "%s", and "%_" */ - if (patlen == 0) - return; - if (patlen == 2 && pat[0] == '%') { - switch (pat[1]) { - case 's': - if (args) { - char *s = va_arg(*args, char*); - sv_catpv(sv, s ? s : nullstr); - } - else if (svix < svmax) - sv_catsv(sv, *svargs); - return; - case '_': - if (args) { - sv_catsv(sv, va_arg(*args, SV*)); - return; - } +Processes its arguments like C and appends the formatted output +to an SV. Handles 'get' magic, but not 'set' magic. C must +typically be called after calling this function to handle 'set' magic. + +=cut +*/ + +void +Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvf(sv, pat, &args); + va_end(args); +} + +void +Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + +/* +=for apidoc sv_catpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +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); +} + +/* +=for apidoc sv_vsetpvfn + +Works like C but copies the text into the SV instead of +appending it. + +=cut +*/ + +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, maybe_tainted); +} + +/* +=for apidoc sv_vcatpvfn + +Processes its arguments like C and appends the formatted output +to an SV. Uses an array of SVs if the C style variable argument list is +missing (NULL). When running with taint checks enabled, indicates via +C if results are untrustworthy (often due to the use of +locales). + +=cut +*/ + +void +Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) +{ + dTHR; + char *p; + char *q; + char *patend; + STRLEN origlen; + I32 svix = 0; + static char nullstr[] = "(null)"; + SV *argsv; + + /* no matter what, this is a string now */ + (void)SvPV_force(sv, origlen); + + /* special-case "", "%s", and "%_" */ + if (patlen == 0) + return; + if (patlen == 2 && pat[0] == '%') { + switch (pat[1]) { + case 's': + if (args) { + char *s = va_arg(*args, char*); + sv_catpv(sv, s ? s : nullstr); + } + else if (svix < svmax) { + sv_catsv(sv, *svargs); + if (DO_UTF8(*svargs)) + SvUTF8_on(sv); + } + return; + case '_': + if (args) { + argsv = va_arg(*args, SV*); + sv_catsv(sv, argsv); + if (DO_UTF8(argsv)) + SvUTF8_on(sv); + return; + } /* See comment on '_' below */ break; } @@ -4330,6 +6044,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, for (p = (char*)pat; p < patend; p = q) { bool alt = FALSE; bool left = FALSE; + bool vectorize = FALSE; + bool utf = FALSE; char fill = ' '; char plus = 0; char intsize = 0; @@ -4337,23 +6053,38 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, STRLEN zeros = 0; bool has_precis = FALSE; STRLEN precis = 0; - + bool is_utf = FALSE; + char esignbuf[4]; - U8 utf8buf[10]; + U8 utf8buf[UTF8_MAXLEN]; STRLEN esignlen = 0; char *eptr = Nullch; STRLEN elen = 0; - char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */ + /* Times 4: a decimal digit takes more than 3 binary digits. + * NV_DIG: mantissa takes than many decimal digits. + * Plus 32: Playing safe. */ + char ebuf[IV_DIG * 4 + NV_DIG + 32]; + /* large enough for "%#.#f" --chip */ + /* what about long double NVs? --jhi */ + + SV *vecsv; + U8 *vecstr = Null(U8*); + STRLEN veclen = 0; char c; int i; unsigned base; IV iv; UV uv; - double nv; + NV nv; STRLEN have; STRLEN need; STRLEN gap; + char *dotstr = "."; + STRLEN dotstrlen = 1; + I32 epix = 0; /* explicit parameter index */ + I32 ewix = 0; /* explicit width index */ + bool asterisk = FALSE; for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { @@ -4386,6 +6117,26 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, q++; continue; + case '*': /* printf("%*vX",":",$ipv6addr) */ + if (q[1] != 'v') + break; + q++; + if (args) + vecsv = va_arg(*args, SV*); + else if (svix < svmax) + vecsv = svargs[svix++]; + else + continue; + dotstr = SvPVx(vecsv,dotstrlen); + if (DO_UTF8(vecsv)) + is_utf = TRUE; + /* FALL THROUGH */ + + case 'v': + vectorize = TRUE; + q++; + continue; + default: break; } @@ -4394,6 +6145,15 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* WIDTH */ + scanwidth: + + if (*q == '*') { + if (asterisk) + goto unknown; + asterisk = TRUE; + q++; + } + switch (*q) { case '1': case '2': case '3': case '4': case '5': case '6': @@ -4401,17 +6161,30 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, width = 0; while (isDIGIT(*q)) width = width * 10 + (*q++ - '0'); - break; + if (*q == '$') { + if (asterisk && ewix == 0) { + ewix = width; + width = 0; + q++; + goto scanwidth; + } else if (epix == 0) { + epix = width; + width = 0; + q++; + goto scanwidth; + } else + goto unknown; + } + } - case '*': + if (asterisk) { if (args) i = va_arg(*args, int); else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + i = (ewix ? ewix <= svmax : svix < svmax) ? + SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; left |= (i < 0); width = (i < 0) ? -i : i; - q++; - break; } /* PRECISION */ @@ -4422,7 +6195,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, if (args) i = va_arg(*args, int); else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + i = (ewix ? ewix <= svmax : svix < svmax) + ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; precis = (i < 0) ? 0 : i; q++; } @@ -4434,19 +6208,47 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, has_precis = TRUE; } + if (vectorize) { + if (args) { + vecsv = va_arg(*args, SV*); + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else if (epix ? epix <= svmax : svix < svmax) { + vecsv = svargs[epix ? epix-1 : svix++]; + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + } + else { + vecstr = (U8*)""; + veclen = 0; + } + } + /* SIZE */ switch (*q) { +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) + case 'L': /* Ld */ + /* FALL THROUGH */ +#endif +#ifdef HAS_QUAD + case 'q': /* qd */ + intsize = 'q'; + q++; + break; +#endif case 'l': -#if 0 /* when quads have better support within Perl */ - if (*(q + 1) == 'l') { +#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; - } + } #endif /* FALL THROUGH */ case 'h': + /* FALL THROUGH */ case 'V': intsize = *q++; break; @@ -4464,45 +6266,52 @@ 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; - + if (args) + uv = va_arg(*args, int); + else + uv = (epix ? epix <= svmax : svix < svmax) ? + SvIVx(svargs[epix ? epix-1 : svix++]) : 0; + if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { eptr = (char*)utf8buf; elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; - goto string; + is_utf = TRUE; + } + else { + c = (char)uv; + eptr = &c; + elen = 1; } - if (args) - c = va_arg(*args, int); - else - c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - eptr = &c; - elen = 1; goto string; case 's': if (args) { eptr = va_arg(*args, char*); if (eptr) +#ifdef MACOS_TRADITIONAL + /* On MacOS, %#s format is used for Pascal strings */ + if (alt) + elen = *eptr++; + else +#endif elen = strlen(eptr); else { eptr = nullstr; elen = sizeof nullstr - 1; } } - else if (svix < svmax) { - eptr = SvPVx(svargs[svix++], elen); - if (IN_UTF8) { + else if (epix ? epix <= svmax : svix < svmax) { + argsv = svargs[epix ? epix-1 : svix++]; + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { I32 p = precis; - sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ + sv_pos_u2b(argsv, &p, 0); /* sticks at end */ precis = p; } if (width) { /* fudge width (can't fudge elen) */ - width += elen - sv_len_utf8(svargs[svix - 1]); + width += elen - sv_len_utf8(argsv); } + is_utf = TRUE; } } goto string; @@ -4515,9 +6324,13 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, */ if (!args) goto unknown; - eptr = SvPVx(va_arg(*args, SV*), elen); + argsv = va_arg(*args,SV*); + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) + is_utf = TRUE; string: + vectorize = FALSE; if (has_precis && elen > precis) elen = precis; break; @@ -4525,33 +6338,62 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* INTEGERS */ case 'p': + if (alt) + goto unknown; if (args) - uv = (UV)va_arg(*args, void*); + uv = PTR2UV(va_arg(*args, void*)); else - uv = (svix < svmax) ? (UV)svargs[svix++] : 0; + uv = (epix ? epix <= svmax : svix < svmax) ? + PTR2UV(svargs[epix ? epix-1 : svix++]) : 0; base = 16; goto integer; case 'D': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'd': case 'i': - if (args) { + if (vectorize) { + STRLEN ulen; + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + iv = (IV)utf8_to_uv_chk(vecstr, veclen, &ulen, 0); + else { + iv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else if (args) { switch (intsize) { case 'h': iv = (short)va_arg(*args, int); break; default: iv = va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; +#ifdef HAS_QUAD + case 'q': iv = va_arg(*args, Quad_t); break; +#endif } } else { - iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + iv = (epix ? epix <= svmax : svix < svmax) ? + SvIVx(svargs[epix ? epix-1 : svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; - default: iv = (int)iv; break; + default: break; case 'l': iv = (long)iv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': iv = (Quad_t)iv; break; +#endif } } if (iv >= 0) { @@ -4567,7 +6409,11 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto integer; case 'U': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'u': base = 10; @@ -4578,7 +6424,11 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto uns_integer; case 'O': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'o': base = 8; @@ -4589,21 +6439,44 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, base = 16; uns_integer: - if (args) { + if (vectorize) { + STRLEN ulen; + vector: + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + uv = utf8_to_uv_chk(vecstr, veclen, &ulen, 0); + else { + uv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else if (args) { switch (intsize) { case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; default: uv = va_arg(*args, unsigned); break; case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; +#ifdef HAS_QUAD + case 'q': uv = va_arg(*args, Quad_t); break; +#endif } } else { - uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; + uv = (epix ? epix <= svmax : svix < svmax) ? + SvUVx(svargs[epix ? epix-1 : svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; - default: uv = (unsigned)uv; break; + default: break; case 'l': uv = (unsigned long)uv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': uv = (Quad_t)uv; break; +#endif } } @@ -4614,7 +6487,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, case 16: if (!uv) alt = FALSE; - p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); do { dig = uv & 15; *--eptr = p[dig]; @@ -4637,10 +6511,25 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, dig = uv & 1; *--eptr = '0' + dig; } while (uv >>= 1); - if (alt && *eptr != '0') - *--eptr = '0'; + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = 'b'; + } break; default: /* it had better be ten or less */ +#if defined(PERL_Y2KWARN) + if (ckWARN(WARN_Y2K)) { + 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_Y2K, + "Possible Y2K bug: %%%c %s", + c, "format string following '19'"); + } + } +#endif do { dig = uv % base; *--eptr = '0' + dig; @@ -4667,17 +6556,19 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, /* This is evil, but floating point is even more evil */ + vectorize = FALSE; if (args) - nv = va_arg(*args, double); + nv = va_arg(*args, NV); else - nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0; + nv = (epix ? epix <= svmax : svix < svmax) ? + SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0; need = 0; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; - (void)frexp(nv, &i); + (void)Perl_frexp(nv, &i); if (i == PERL_INT_MIN) - die("panic: frexp"); + Perl_die(aTHX_ "panic: frexp"); if (i > 0) need = BIT_DIGITS(i); } @@ -4690,11 +6581,22 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, Safefree(PL_efloatbuf); PL_efloatsize = need + 20; /* more fudge */ New(906, PL_efloatbuf, PL_efloatsize, char); + PL_efloatbuf[0] = '\0'; } eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; +#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl) + { + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const prifldbl[] = PERL_PRIfldbl; + char const *p = prifldbl + sizeof(prifldbl) - 3; + while (p >= prifldbl) { *--eptr = *p--; } + } +#endif if (has_precis) { base = precis; do { *--eptr = '0' + (base % 10); } while (base /= 10); @@ -4714,26 +6616,24 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, *--eptr = '#'; *--eptr = '%'; - (void)sprintf(PL_efloatbuf, eptr, nv); + { + STORE_NUMERIC_STANDARD_SET_LOCAL(); +#ifdef USE_LOCALE_NUMERIC + if (!was_standard && maybe_tainted) + *maybe_tainted = TRUE; +#endif + (void)sprintf(PL_efloatbuf, eptr, nv); + RESTORE_NUMERIC_STANDARD(); + } eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); - -#ifdef LC_NUMERIC - /* - * User-defined locales may include arbitrary characters. - * And, unfortunately, some system may alloc the "C" locale - * to be overridden by a malicious user. - */ - if (used_locale) - *used_locale = TRUE; -#endif /* LC_NUMERIC */ - break; /* SPECIAL */ case 'n': + vectorize = FALSE; i = SvCUR(sv) - origlen; if (args) { switch (intsize) { @@ -4741,27 +6641,36 @@ 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 HAS_QUAD + case 'q': *(va_arg(*args, Quad_t*)) = i; break; +#endif } } - else if (svix < svmax) - sv_setuv(svargs[svix++], (UV)i); + else if (epix ? epix <= svmax : svix < svmax) + sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i); continue; /* not "break" */ /* UNKNOWN */ default: unknown: + vectorize = FALSE; if (!args && ckWARN(WARN_PRINTF) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); - sv_setpvf(msg, "Invalid conversion in %s: ", + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); - if (c) - sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", - c & 0xFF); - else + if (c) { + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03"UVof"\"", + (UV)c & 0xFF); + } else sv_catpv(msg, "end of string"); - warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -4784,7 +6693,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, need = (have > width ? have : width); gap = need - have; - SvGROW(sv, SvCUR(sv) + need + 1); + SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) @@ -4810,7 +6719,1700 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, memset(p, ' ', gap); p += gap; } + if (vectorize) { + if (veclen) { + memcpy(p, dotstr, dotstrlen); + p += dotstrlen; + } + else + vectorize = FALSE; /* done iterating over vecstr */ + } + if (is_utf) + SvUTF8_on(sv); *p = '\0'; SvCUR(sv) = p - SvPVX(sv); + if (vectorize) { + esignlen = 0; + goto vector; + } + } +} + +#if defined(USE_ITHREADS) + +#if defined(USE_THREADS) +# include "error: USE_THREADS and USE_ITHREADS are incompatible" +#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) +{ + /* XXX fix when pmop->op_pmregexp becomes shared */ + return ReREFCNT_inc(r); +} + +PerlIO * +Perl_fp_dup(pTHX_ PerlIO *fp, char type) +{ + PerlIO *ret; + if (!fp) + return (PerlIO*)NULL; + + /* look for it in the table first */ + ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); + if (ret) + return ret; + + /* create anew and remember what it is */ + ret = PerlIO_fdupopen(fp); + ptr_table_store(PL_ptr_table, fp, ret); + return ret; +} + +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*)ptr_table_fetch(PL_ptr_table, gp); + if (ret) + return ret; + + /* create anew and remember what it is */ + Newz(0, ret, 1, GP); + ptr_table_store(PL_ptr_table, gp, ret); + + /* clone */ + ret->gp_refcnt = 0; /* must be before any other dups! */ + 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 = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */ + 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 */ + return ret; +} + +MAGIC * +Perl_mg_dup(pTHX_ MAGIC *mg) +{ + MAGIC *mgret = (MAGIC*)NULL; + MAGIC *mgprev; + if (!mg) + return (MAGIC*)NULL; + /* look for it in the table first */ + mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg); + if (mgret) + return mgret; + + 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; } + return mgret; } + +PTR_TBL_t * +Perl_ptr_table_new(pTHX) +{ + PTR_TBL_t *tbl; + Newz(0, tbl, 1, PTR_TBL_t); + tbl->tbl_max = 511; + tbl->tbl_items = 0; + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); + return tbl; +} + +void * +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) +{ + PTR_TBL_ENT_t *tblent; + UV hash = PTR2UV(sv); + assert(tbl); + tblent = tbl->tbl_ary[hash & tbl->tbl_max]; + for (; tblent; tblent = tblent->next) { + if (tblent->oldval == sv) + return tblent->newval; + } + return (void*)NULL; +} + +void +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) +{ + PTR_TBL_ENT_t *tblent, **otblent; + /* XXX this may be pessimal on platforms where pointers aren't good + * hash values e.g. if they grow faster in the most significant + * bits */ + UV hash = PTR2UV(oldv); + 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 == oldv) { + tblent->newval = newv; + tbl->tbl_items++; + return; + } + } + Newz(0, tblent, 1, PTR_TBL_ENT_t); + tblent->oldval = oldv; + tblent->newval = newv; + tblent->next = *otblent; + *otblent = tblent; + tbl->tbl_items++; + if (i && tbl->tbl_items > tbl->tbl_max) + ptr_table_split(tbl); +} + +void +Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) +{ + PTR_TBL_ENT_t **ary = tbl->tbl_ary; + UV oldsize = tbl->tbl_max + 1; + UV newsize = oldsize * 2; + UV i; + + Renew(ary, newsize, PTR_TBL_ENT_t*); + Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); + tbl->tbl_max = --newsize; + tbl->tbl_ary = ary; + for (i=0; i < oldsize; i++, ary++) { + PTR_TBL_ENT_t **curentp, **entp, *ent; + if (!*ary) + continue; + curentp = ary + oldsize; + for (entp = ary, ent = *ary; ent; ent = *entp) { + if ((newsize & PTR2UV(ent->oldval)) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + continue; + } + else + entp = &ent->next; + } + } +} + +#ifdef DEBUGGING +char *PL_watch_pvx; +#endif + +SV * +Perl_sv_dup(pTHX_ SV *sstr) +{ + SV *dstr; + + if (!sstr || SvTYPE(sstr) == SVTYPEMASK) + return Nullsv; + /* look for it in the table first */ + dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); + if (dstr) + return dstr; + + /* create anew and remember what it is */ + new_SV(dstr); + ptr_table_store(PL_ptr_table, sstr, dstr); + + /* clone */ + SvFLAGS(dstr) = SvFLAGS(sstr); + SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ + SvREFCNT(dstr) = 0; /* must be before any other dups! */ + +#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 + + switch (SvTYPE(sstr)) { + case SVt_NULL: + SvANY(dstr) = NULL; + break; + case SVt_IV: + SvANY(dstr) = new_XIV(); + SvIVX(dstr) = SvIVX(sstr); + break; + case SVt_NV: + SvANY(dstr) = new_XNV(); + SvNVX(dstr) = SvNVX(sstr); + break; + case SVt_RV: + SvANY(dstr) = new_XRV(); + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + break; + case SVt_PV: + 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: + 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: + 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: + 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_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_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: + 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)); + break; + case SVt_PVIO: + 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 + 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: + 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 (AvARRAY((AV*)sstr)) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((AV*)sstr) + 1; + + src_ary = AvARRAY((AV*)sstr); + Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); + 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: + 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)) { + 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**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], + !!HvSHAREKEYS(sstr)); + ++i; + } + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr)); + } + 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_PVFM: + SvANY(dstr) = new_XPVFM(); + FmLINES(dstr) = FmLINES(sstr); + 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)); + } + else + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + CvFLAGS(dstr) = CvFLAGS(sstr); + break; + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); + break; + } + + if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) + ++PL_sv_objcount; + + return dstr; +} + +PERL_CONTEXT * +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) +{ + PERL_CONTEXT *ncxs; + + if (!cxs) + return (PERL_CONTEXT*)NULL; + + /* look for it in the table first */ + ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); + if (ncxs) + return ncxs; + + /* create anew and remember what it is */ + Newz(56, ncxs, max + 1, PERL_CONTEXT); + ptr_table_store(PL_ptr_table, cxs, ncxs); + + while (ix >= 0) { + PERL_CONTEXT *cx = &cxs[ix]; + PERL_CONTEXT *ncx = &ncxs[ix]; + ncx->cx_type = cx->cx_type; + if (CxTYPE(cx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldsp = cx->blk_oldsp; + ncx->blk_oldcop = cx->blk_oldcop; + ncx->blk_oldretsp = cx->blk_oldretsp; + ncx->blk_oldmarksp = cx->blk_oldmarksp; + ncx->blk_oldscopesp = cx->blk_oldscopesp; + ncx->blk_oldpm = cx->blk_oldpm; + ncx->blk_gimme = cx->blk_gimme; + switch (CxTYPE(cx)) { + case CXt_SUB: + ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 + ? cv_dup_inc(cx->blk_sub.cv) + : cv_dup(cx->blk_sub.cv)); + ncx->blk_sub.argarray = (cx->blk_sub.hasargs + ? av_dup_inc(cx->blk_sub.argarray) + : Nullav); + ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.olddepth = cx->blk_sub.olddepth; + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + ncx->blk_sub.lval = cx->blk_sub.lval; + break; + case CXt_EVAL: + ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; + ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; + ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv); + ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; + ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); + break; + case CXt_LOOP: + ncx->blk_loop.label = cx->blk_loop.label; + ncx->blk_loop.resetsp = cx->blk_loop.resetsp; + ncx->blk_loop.redo_op = cx->blk_loop.redo_op; + ncx->blk_loop.next_op = cx->blk_loop.next_op; + ncx->blk_loop.last_op = cx->blk_loop.last_op; + ncx->blk_loop.iterdata = (CxPADLOOP(cx) + ? cx->blk_loop.iterdata + : gv_dup((GV*)cx->blk_loop.iterdata)); + ncx->blk_loop.oldcurpad + = (SV**)ptr_table_fetch(PL_ptr_table, + cx->blk_loop.oldcurpad); + ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave); + ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval); + ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary); + ncx->blk_loop.iterix = cx->blk_loop.iterix; + ncx->blk_loop.itermax = cx->blk_loop.itermax; + break; + case CXt_FORMAT: + ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv); + ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv); + ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv); + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + break; + case CXt_BLOCK: + case CXt_NULL: + break; + } + } + --ix; + } + return ncxs; +} + +PERL_SI * +Perl_si_dup(pTHX_ PERL_SI *si) +{ + PERL_SI *nsi; + + if (!si) + return (PERL_SI*)NULL; + + /* look for it in the table first */ + nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); + if (nsi) + return nsi; + + /* create anew and remember what it is */ + Newz(56, nsi, 1, PERL_SI); + ptr_table_store(PL_ptr_table, si, nsi); + + nsi->si_stack = av_dup_inc(si->si_stack); + nsi->si_cxix = si->si_cxix; + nsi->si_cxmax = si->si_cxmax; + nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax); + nsi->si_type = si->si_type; + nsi->si_prev = si_dup(si->si_prev); + nsi->si_next = si_dup(si->si_next); + nsi->si_markoff = si->si_markoff; + + return nsi; +} + +#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) +#define TOPINT(ss,ix) ((ss)[ix].any_i32) +#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) +#define TOPLONG(ss,ix) ((ss)[ix].any_long) +#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) +#define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) +#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) +#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) +#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) +#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) +#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) + +/* XXXXX todo */ +#define pv_dup_inc(p) SAVEPV(p) +#define pv_dup(p) SAVEPV(p) +#define svp_dup_inc(p,pp) any_dup(p,pp) + +void * +Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +{ + void *ret; + + if (!v) + return (void*)NULL; + + /* look for it in the table first */ + ret = ptr_table_fetch(PL_ptr_table, v); + if (ret) + return ret; + + /* see if it is part of the interpreter structure */ + if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) + ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl)); + else + ret = v; + + return ret; +} + +ANY * +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) +{ + ANY *ss = proto_perl->Tsavestack; + I32 ix = proto_perl->Tsavestack_ix; + I32 max = proto_perl->Tsavestack_max; + ANY *nss; + SV *sv; + GV *gv; + AV *av; + HV *hv; + void* ptr; + int intval; + long longval; + GP *gp; + IV iv; + I32 i; + char *c; + void (*dptr) (void*); + void (*dxptr) (pTHXo_ void*); + OP *o; + + Newz(54, nss, max, ANY); + + while (ix > 0) { + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + switch (i) { + case SAVEt_ITEM: /* normal string */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_SV: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv); + break; + case SAVEt_GENERIC_PVREF: /* generic char* */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_GENERIC_SVREF: /* generic sv */ + case SAVEt_SVREF: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; + case SAVEt_AV: /* array reference */ + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_HV: /* hash reference */ + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_HPTR: /* HV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup(hv); + break; + case SAVEt_APTR: /* AV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; + case SAVEt_NSTAB: + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp); + (void)GpREFCNT_inc(gp); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(c); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_FREESV: + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = ptr; + o = (OP*)ptr; + OpREFCNT_inc(o); + break; + default: + TOPPTR(nss,ix) = Nullop; + break; + } + } + else + TOPPTR(nss,ix) = Nullop; + break; + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_CLEARSV: + longval = POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_DELETE: + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dptr = POPDPTR(ss,ix); + TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl); + break; + case SAVEt_DESTRUCTOR_X: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dxptr = POPDXPTR(ss,ix); + TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + ix -= i; + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_AELEM: /* array element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + break; + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; + case SAVEt_HINTS: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_COMPPAD: + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; + default: + Perl_croak(aTHX_ "panic: ss_dup inconsistency"); + } + } + + return nss; +} + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)proto_perl; +#endif + +#ifdef PERL_IMPLICIT_SYS + return perl_clone_using(proto_perl, flags, + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); +} + +PerlInterpreter * +perl_clone_using(PerlInterpreter *proto_perl, UV flags, + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) +{ + /* 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. */ + + IV i; +# ifdef PERL_OBJECT + CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, + ipD, ipS, ipP); + PERL_SET_THX(pPerl); +# else /* !PERL_OBJECT */ + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_THX(my_perl); + +# ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ + + /* host pointers */ + PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; +# endif /* PERL_OBJECT */ +#else /* !PERL_IMPLICIT_SYS */ + IV i; + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + PERL_SET_THX(my_perl); + +# ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ +#endif /* PERL_IMPLICIT_SYS */ + + /* arena roots */ + PL_xiv_arenaroot = NULL; + PL_xiv_root = NULL; + PL_xnv_arenaroot = NULL; + PL_xnv_root = NULL; + PL_xrv_arenaroot = NULL; + PL_xrv_root = NULL; + PL_xpv_arenaroot = NULL; + PL_xpv_root = NULL; + PL_xpviv_arenaroot = NULL; + PL_xpviv_root = NULL; + PL_xpvnv_arenaroot = NULL; + PL_xpvnv_root = NULL; + PL_xpvcv_arenaroot = NULL; + PL_xpvcv_root = NULL; + PL_xpvav_arenaroot = NULL; + PL_xpvav_root = NULL; + PL_xpvhv_arenaroot = NULL; + PL_xpvhv_root = NULL; + PL_xpvmg_arenaroot = NULL; + PL_xpvmg_root = NULL; + PL_xpvlv_arenaroot = NULL; + PL_xpvlv_root = NULL; + PL_xpvbm_arenaroot = NULL; + PL_xpvbm_root = NULL; + PL_he_arenaroot = 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_ptr_table = ptr_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; + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); + +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_no, SVt_PVNV); +#else + SvANY(&PL_sv_no) = new_XPVNV(); +#endif + 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; + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); + +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_yes, SVt_PVNV); +#else + SvANY(&PL_sv_yes) = new_XPVNV(); +#endif + 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; + ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + + /* create shared string table */ + PL_strtab = newHV(); + HvSHAREKEYS_off(PL_strtab); + hv_ksplit(PL_strtab, 512); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, 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); + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); + if (!specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); + + /* 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; + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); + 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) when asked for? */ + 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_checkav = av_dup_inc(proto_perl->Icheckav); + 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 = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); + PL_copline = proto_perl->Icopline; + + PL_filemode = proto_perl->Ifilemode; + PL_lastfd = proto_perl->Ilastfd; + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ + 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; + PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); + /* 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 = (SV**)ptr_table_fetch(PL_ptr_table, + proto_perl->Tcurpad); + +#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_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 not quite right */ + PL_origalen = proto_perl->Iorigalen; + PL_pidstatus = newHV(); /* XXX flag for cloning? */ + 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); + +#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_dojoin = proto_perl->Ilex_dojoin; + PL_lex_starts = proto_perl->Ilex_starts; + PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl); + 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 not quite right */ + + 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; /* reinits on demand */ + PL_last_swash_klen = 0; + PL_last_swash_key[0]= '\0'; + PL_last_swash_tmps = (U8*)NULL; + 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; /* reinits on demand */ + PL_bitcount = Nullch; /* reinits on demand */ + + if (proto_perl->Ipsig_ptr) { + int sig_num[] = { SIG_NUM }; + Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + for (i = 1; PL_sig_name[i]; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); + } + } + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } + + /* thrdvar.h stuff */ + + if (flags & 1) { + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Ttmps_ix; + PL_tmps_max = proto_perl->Ttmps_max; + PL_tmps_floor = proto_perl->Ttmps_floor; + Newz(50, PL_tmps_stack, PL_tmps_max, SV*); + i = 0; + while (i <= PL_tmps_ix) { + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]); + ++i; + } + + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + Newz(54, PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max + - proto_perl->Tmarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr + - proto_perl->Tmarkstack); + Copy(proto_perl->Tmarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Tscopestack_ix; + PL_scopestack_max = proto_perl->Tscopestack_max; + Newz(54, PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + + /* next push_return() sets PL_retstack[PL_retstack_ix] + * NOTE: unlike the others! */ + PL_retstack_ix = proto_perl->Tretstack_ix; + PL_retstack_max = proto_perl->Tretstack_max; + Newz(54, PL_retstack, PL_retstack_max, OP*); + Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); + + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo); + + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Tcurstack); + PL_mainstack = av_dup(proto_perl->Tmainstack); + + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp + - proto_perl->Tstack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Tsavestack_ix; + PL_savestack_max = proto_perl->Tsavestack_max; + /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl); + } + else { + init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ + } + + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; + + PL_op = proto_perl->Top; + + PL_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; + + 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 never deallocated */ + 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; + +#ifdef PERL_FLEXIBLE_EXCEPTIONS + PL_protect = proto_perl->Tprotect; +#endif + 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_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); + 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; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ + + /* regex stuff */ + + PL_screamfirst = NULL; + PL_screamnext = NULL; + PL_maxscream = -1; /* reinits on demand */ + PL_lastscream = Nullsv; + + PL_watchaddr = NULL; + PL_watchok = Nullch; + + PL_regdummy = proto_perl->Tregdummy; + PL_regcomp_parse = Nullch; + PL_regxend = Nullch; + PL_regcode = (regnode*)NULL; + PL_regnaughty = 0; + PL_regsawback = 0; + PL_regprecomp = Nullch; + PL_regnpar = 0; + PL_regsize = 0; + PL_regflags = 0; + PL_regseen = 0; + PL_seen_zerolen = 0; + PL_seen_evals = 0; + PL_regcomp_rx = (regexp*)NULL; + PL_extralen = 0; + PL_colorset = 0; /* reinits PL_colors[] */ + /*PL_colors[6] = {0,0,0,0,0,0};*/ + PL_reg_whilem_seen = 0; + PL_reginput = Nullch; + PL_regbol = Nullch; + PL_regeol = Nullch; + PL_regstartp = (I32*)NULL; + PL_regendp = (I32*)NULL; + PL_reglastparen = (U32*)NULL; + PL_regtill = Nullch; + PL_regprev = '\n'; + PL_reg_start_tmp = (char**)NULL; + PL_reg_start_tmpl = 0; + PL_regdata = (struct reg_data*)NULL; + PL_bostr = Nullch; + PL_reg_flags = 0; + PL_reg_eval_set = 0; + PL_regnarrate = 0; + PL_regprogram = (regnode*)NULL; + PL_regindent = 0; + PL_regcc = (CURCUR*)NULL; + PL_reg_call_cc = (struct re_cc_state*)NULL; + PL_reg_re = (regexp*)NULL; + PL_reg_ganch = Nullch; + PL_reg_sv = Nullsv; + PL_reg_magic = (MAGIC*)NULL; + PL_reg_oldpos = 0; + PL_reg_oldcurpm = (PMOP*)NULL; + PL_reg_curpm = (PMOP*)NULL; + PL_reg_oldsaved = Nullch; + PL_reg_oldsavedlen = 0; + PL_reg_maxiter = 0; + PL_reg_leftiter = 0; + PL_reg_poscache = Nullch; + PL_reg_poscache_size= 0; + + /* 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_reginterp_cnt = 0; + PL_reg_starttry = 0; + +#ifdef PERL_OBJECT + return (PerlInterpreter*)pPerl; +#else + return my_perl; +#endif +} + +#else /* !USE_ITHREADS */ + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +#endif /* USE_ITHREADS */ + +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));) + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + } else { + 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 && GvGP(sv)) { + 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); +} +