X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2f5ea0b7b7a2d5cd0074400dd5c87310ea5f0d68;hb=6b49d2665cf5b4cee8758bc654f9290f3855049e;hp=9ba9f6cb1536c45f36ea20660a81db4fa89557c2;hpb=089c015b3a0d1c9d3f152ace22b1d60ce258b208;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 9ba9f6c..2f5ea0b 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. @@ -15,12 +15,6 @@ #define PERL_IN_SV_C #include "perl.h" -#ifdef PERL_OBJECT -#define VTBL this->*vtbl -#else /* !PERL_OBJECT */ -#define VTBL *vtbl -#endif /* PERL_OBJECT */ - #define FCALL *f #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) @@ -31,105 +25,6 @@ static void do_clean_named_objs(pTHXo_ SV *sv); #endif static void do_clean_all(pTHXo_ SV *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) \ - Perl_die(aTHX_ "SV registry bug"); \ - } \ - registry[i] = (b); \ - } STMT_END - -#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) -#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) - -STATIC void -S_reg_add(pTHX_ 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 -S_reg_remove(pTHX_ SV *sv) -{ - REG_REMOVE(sv); - --PL_sv_count; -} - -STATIC void -S_visit(pTHX_ SVFUNC_t f) -{ - I32 i; - - for (i = 0; i < registry_size; ++i) { - SV* sv = registry[i]; - if (sv && SvTYPE(sv) != SVTYPEMASK) - (*f)(sv); - } -} - -void -Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) -{ - if (!(flags & SVf_FAKE)) - Safefree(ptr); -} - -#else /* ! PURIFY */ - /* * "A time to plant, and a time to uproot what was planted..." */ @@ -192,7 +87,8 @@ S_del_sv(pTHX_ SV *p) if (!ok) { if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL, - "Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + "Attempt to free non-arena SV: 0x%"UVxf, + PTR2UV(p)); return; } } @@ -211,7 +107,7 @@ 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 */ @@ -267,8 +163,6 @@ S_visit(pTHX_ SVFUNC_t f) } } -#endif /* PURIFY */ - void Perl_sv_report_used(pTHX) { @@ -321,6 +215,16 @@ Perl_sv_free_arenas(pTHX) 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* S_new_xiv(pTHX) { @@ -481,4795 +385,7601 @@ S_more_xpv(pTHX) 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 -#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 void +S_more_xpviv(pTHX) +{ + register XPVIV* xpviv; + register XPVIV* xpvivend; + New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV); + xpviv = PL_xpviv_root; + xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1]; + while (xpviv < xpvivend) { + xpviv->xpv_pv = (char*)(xpviv + 1); + xpviv++; + } + xpviv->xpv_pv = 0; +} -#ifdef PURIFY -# define my_safemalloc(s) safemalloc(s) -# define my_safefree(s) safefree(s) -#else -STATIC void* -S_my_safemalloc(MEM_SIZE size) + +STATIC XPVNV* +S_new_xpvnv(pTHX) { - char *p; - New(717, p, size, char); - return (void*)p; + 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; } -# 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) +STATIC void +S_del_xpvnv(pTHX_ XPVNV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvnv_root; + PL_xpvnv_root = p; + UNLOCK_SV_MUTEX; +} -bool -Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) + +STATIC void +S_more_xpvnv(pTHX) { - char* pv; - U32 cur; - U32 len; - IV iv; - NV nv; - MAGIC* magic; - HV* stash; + register XPVNV* xpvnv; + register XPVNV* xpvnvend; + New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV); + xpvnv = PL_xpvnv_root; + xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1]; + while (xpvnv < xpvnvend) { + xpvnv->xpv_pv = (char*)(xpvnv + 1); + xpvnv++; + } + xpvnv->xpv_pv = 0; +} - 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 = (IV)pv; - nv = (NV)(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; - break; - case SVt_PVIV: - pv = SvPVX(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = 0.0; - magic = 0; - stash = 0; - del_XPVIV(SvANY(sv)); - break; - case SVt_PVNV: - pv = SvPVX(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - magic = 0; - stash = 0; - del_XPVNV(SvANY(sv)); - break; - case SVt_PVMG: - pv = SvPVX(sv); - cur = SvCUR(sv); - len = SvLEN(sv); - iv = SvIVX(sv); - nv = SvNVX(sv); - magic = SvMAGIC(sv); - stash = SvSTASH(sv); - del_XPVMG(SvANY(sv)); - break; - default: - Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); +STATIC XPVCV* +S_new_xpvcv(pTHX) +{ + XPVCV* xpvcv; + LOCK_SV_MUTEX; + if (!PL_xpvcv_root) + more_xpvcv(); + xpvcv = PL_xpvcv_root; + PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpvcv; +} + +STATIC void +S_del_xpvcv(pTHX_ XPVCV *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvcv_root; + PL_xpvcv_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvcv(pTHX) +{ + register XPVCV* xpvcv; + register XPVCV* xpvcvend; + New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV); + xpvcv = PL_xpvcv_root; + xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1]; + while (xpvcv < xpvcvend) { + xpvcv->xpv_pv = (char*)(xpvcv + 1); + xpvcv++; } + xpvcv->xpv_pv = 0; +} - switch (mt) { - case SVt_NULL: - Perl_croak(aTHX_ "Can't upgrade to undef"); - case SVt_IV: - SvANY(sv) = new_XIV(); - SvIVX(sv) = iv; - break; - case SVt_NV: - SvANY(sv) = new_XNV(); - SvNVX(sv) = nv; - break; - case SVt_RV: - SvANY(sv) = new_XRV(); - SvRV(sv) = (SV*)pv; - break; - case SVt_PV: - SvANY(sv) = new_XPV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - break; - case SVt_PVIV: - SvANY(sv) = new_XPVIV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - if (SvNIOK(sv)) - (void)SvIOK_on(sv); - SvNOK_off(sv); - break; - case SVt_PVNV: - SvANY(sv) = new_XPVNV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - break; - case SVt_PVMG: - SvANY(sv) = new_XPVMG(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVLV: - SvANY(sv) = new_XPVLV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - LvTARGOFF(sv) = 0; - LvTARGLEN(sv) = 0; - LvTARG(sv) = 0; - LvTYPE(sv) = 0; - break; - case SVt_PVAV: - SvANY(sv) = new_XPVAV(); - if (pv) - Safefree(pv); - SvPVX(sv) = 0; - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - SvIVX(sv) = 0; - SvNVX(sv) = 0.0; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - AvALLOC(sv) = 0; - AvARYLEN(sv) = 0; - AvFLAGS(sv) = 0; - break; - case SVt_PVHV: - SvANY(sv) = new_XPVHV(); - if (pv) - Safefree(pv); - SvPVX(sv) = 0; - HvFILL(sv) = 0; - HvMAX(sv) = 0; - HvKEYS(sv) = 0; - SvNVX(sv) = 0.0; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - HvRITER(sv) = 0; - HvEITER(sv) = 0; - HvPMROOT(sv) = 0; - HvNAME(sv) = 0; - break; - case SVt_PVCV: - SvANY(sv) = new_XPVCV(); - Zero(SvANY(sv), 1, XPVCV); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVGV: - SvANY(sv) = new_XPVGV(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - GvGP(sv) = 0; - GvNAME(sv) = 0; - GvNAMELEN(sv) = 0; - GvSTASH(sv) = 0; - GvFLAGS(sv) = 0; - break; - case SVt_PVBM: - SvANY(sv) = new_XPVBM(); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - BmRARE(sv) = 0; - BmUSEFUL(sv) = 0; - BmPREVIOUS(sv) = 0; - break; - case SVt_PVFM: - SvANY(sv) = new_XPVFM(); - Zero(SvANY(sv), 1, XPVFM); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - break; - case SVt_PVIO: - SvANY(sv) = new_XPVIO(); - Zero(SvANY(sv), 1, XPVIO); - SvPVX(sv) = pv; - SvCUR(sv) = cur; - SvLEN(sv) = len; - SvIVX(sv) = iv; - SvNVX(sv) = nv; - SvMAGIC(sv) = magic; - SvSTASH(sv) = stash; - IoPAGE_LEN(sv) = 60; - break; - } - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= mt; - return TRUE; -} -int -Perl_sv_backoff(pTHX_ register SV *sv) + +STATIC XPVAV* +S_new_xpvav(pTHX) { - assert(SvOOK(sv)); - if (SvIVX(sv)) { - char *s = SvPVX(sv); - SvLEN(sv) += SvIVX(sv); - SvPVX(sv) -= SvIVX(sv); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } - SvFLAGS(sv) &= ~SVf_OOK; - return 0; + 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; } -char * -Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) +STATIC void +S_del_xpvav(pTHX_ XPVAV *p) { - register char *s; - -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ - if (SvROK(sv)) - sv_unref(sv); - if (SvTYPE(sv) < SVt_PV) { - sv_upgrade(sv, SVt_PV); - s = SvPVX(sv); - } - else if (SvOOK(sv)) { /* pv is offset? */ - sv_backoff(sv); - s = SvPVX(sv); - if (newlen > SvLEN(sv)) - newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) - newlen = 0xFFFF; -#endif - } - else - s = SvPVX(sv); - if (newlen > SvLEN(sv)) { /* need more room? */ - if (SvLEN(sv) && s) { -#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) - STRLEN l = malloced_size((void*)SvPVX(sv)); - if (newlen <= l) { - SvLEN_set(sv, l); - return s; - } else -#endif - Renew(s,newlen,char); - } - else - New(703,s,newlen,char); - SvPV_set(sv, s); - SvLEN_set(sv, newlen); - } - return s; + LOCK_SV_MUTEX; + p->xav_array = (char*)PL_xpvav_root; + PL_xpvav_root = p; + UNLOCK_SV_MUTEX; } -void -Perl_sv_setiv(pTHX_ register SV *sv, IV i) -{ - SV_CHECK_THINKFIRST(sv); - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; - case SVt_RV: - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - case SVt_PVGV: - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); - } +STATIC void +S_more_xpvav(pTHX) +{ + register XPVAV* xpvav; + register XPVAV* xpvavend; + New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV); + xpvav = PL_xpvav_root; + xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1]; + while (xpvav < xpvavend) { + xpvav->xav_array = (char*)(xpvav + 1); + xpvav++; } - (void)SvIOK_only(sv); /* validate number */ - SvIVX(sv) = i; - SvTAINT(sv); + xpvav->xav_array = 0; } -void -Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) + + +STATIC XPVHV* +S_new_xpvhv(pTHX) { - sv_setiv(sv,i); - SvSETMAGIC(sv); + 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; } -void -Perl_sv_setuv(pTHX_ register SV *sv, UV u) +STATIC void +S_del_xpvhv(pTHX_ XPVHV *p) { - sv_setiv(sv, 0); - SvIsUV_on(sv); - SvUVX(sv) = u; + LOCK_SV_MUTEX; + p->xhv_array = (char*)PL_xpvhv_root; + PL_xpvhv_root = p; + UNLOCK_SV_MUTEX; } -void -Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) + +STATIC void +S_more_xpvhv(pTHX) { - sv_setuv(sv,u); - SvSETMAGIC(sv); + register XPVHV* xpvhv; + register XPVHV* xpvhvend; + New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV); + xpvhv = PL_xpvhv_root; + xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1]; + while (xpvhv < xpvhvend) { + xpvhv->xhv_array = (char*)(xpvhv + 1); + xpvhv++; + } + xpvhv->xhv_array = 0; } -void -Perl_sv_setnv(pTHX_ register SV *sv, NV num) + +STATIC XPVMG* +S_new_xpvmg(pTHX) { - SV_CHECK_THINKFIRST(sv); - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - sv_upgrade(sv, SVt_NV); - break; - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - sv_upgrade(sv, SVt_PVNV); - break; + 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; +} - case SVt_PVGV: - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: - { - dTHR; - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); - } +STATIC void +S_del_xpvmg(pTHX_ XPVMG *p) +{ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvmg_root; + PL_xpvmg_root = p; + UNLOCK_SV_MUTEX; +} + + +STATIC void +S_more_xpvmg(pTHX) +{ + register XPVMG* xpvmg; + register XPVMG* xpvmgend; + New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG); + xpvmg = PL_xpvmg_root; + xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1]; + while (xpvmg < xpvmgend) { + xpvmg->xpv_pv = (char*)(xpvmg + 1); + xpvmg++; } - SvNVX(sv) = num; - (void)SvNOK_only(sv); /* validate number */ - SvTAINT(sv); + xpvmg->xpv_pv = 0; } -void -Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) + + +STATIC XPVLV* +S_new_xpvlv(pTHX) { - sv_setnv(sv,num); - SvSETMAGIC(sv); + 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_not_a_number(pTHX_ SV *sv) +S_del_xpvlv(pTHX_ XPVLV *p) { - dTHR; - char tmpbuf[64]; - char *d = tmpbuf; - char *s; - char *limit = tmpbuf + sizeof(tmpbuf) - 8; - /* each *s can expand to 4 chars + "...\0", - i.e. need room for 8 chars */ + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpvlv_root; + PL_xpvlv_root = p; + UNLOCK_SV_MUTEX; +} - for (s = SvPVX(sv); *s && d < limit; s++) { - int ch = *s & 0xFF; - if (ch & 128 && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; - ch &= 127; - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (*s) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; + +STATIC void +S_more_xpvlv(pTHX) +{ + register XPVLV* xpvlv; + register XPVLV* xpvlvend; + New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV); + xpvlv = PL_xpvlv_root; + xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1]; + while (xpvlv < xpvlvend) { + xpvlv->xpv_pv = (char*)(xpvlv + 1); + xpvlv++; } - *d = '\0'; + xpvlv->xpv_pv = 0; +} - if (PL_op) - Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_name[PL_op->op_type]); - else - Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); + +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; } -/* 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 */ +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; +} -/* Actually, ISO C leaves conversion of UV to IV undefined, but - until proven guilty, assume that things are not that bad... */ -IV -Perl_sv_2iv(pTHX_ register SV *sv) +STATIC void +S_more_xpvbm(pTHX) { - if (!sv) - return 0; - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvIOKp(sv)) - return SvIVX(sv); - if (SvNOKp(sv)) { - return I_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } - return 0; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvIV(tmpstr); - return (IV)SvRV(sv); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - return 0; - } - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) { - return (IV)(SvUVX(sv)); - } - else { - return SvIVX(sv); - } + register XPVBM* xpvbm; + register XPVBM* xpvbmend; + New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM); + xpvbm = PL_xpvbm_root; + xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1]; + while (xpvbm < xpvbmend) { + xpvbm->xpv_pv = (char*)(xpvbm + 1); + xpvbm++; } - 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); + xpvbm->xpv_pv = 0; +} - (void)SvIOK_on(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) - SvIVX(sv) = I_V(SvNVX(sv)); - else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - ret_iv_max: -#ifdef IV_IS_QUAD - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n", - (UV)sv, - (UV)SvUVX(sv), (IV)SvUVX(sv))); +#ifdef LEAKTEST +# define my_safemalloc(s) (void*)safexmalloc(717,s) +# define my_safefree(p) safexfree((char*)p) #else - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2iv(%lu => %ld) (as unsigned)\n", - (unsigned long)sv, - (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv))); +# define my_safemalloc(s) (void*)safemalloc(s) +# define my_safefree(p) safefree((char*)p) #endif - return (IV)SvUVX(sv); - } - } - else if (SvPOKp(sv) && SvLEN(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; +#ifdef PURIFY - d = Atof(SvPVX(sv)); +#define new_XIV() my_safemalloc(sizeof(XPVIV)) +#define del_XIV(p) my_safefree(p) - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); - (void)SvIOK_on(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", - (unsigned long)sv, SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", - (unsigned long)sv, SvNVX(sv))); -#endif - if (SvNVX(sv) < (NV)IV_MAX + 0.5) - SvIVX(sv) = I_V(SvNVX(sv)); - else { - SvUVX(sv) = U_V(SvNVX(sv)); - SvIsUV_on(sv); - goto ret_iv_max; - } - } - else if (numtype) { - /* The NV may be reconstructed from IV - safe to cache IV, - which may be calculated by atol(). */ - if (SvTYPE(sv) == SVt_PV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - SvIVX(sv) = Atol(SvPVX(sv)); - } - else { /* Not a number. Cache 0. */ - dTHR; +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = 0; - (void)SvIOK_on(sv); - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - } - else { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - return 0; - } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", - (unsigned long)sv,(long)SvIVX(sv))); - return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); -} +#define new_XRV() my_safemalloc(sizeof(XRV)) +#define del_XRV(p) my_safefree(p) -UV -Perl_sv_2uv(pTHX_ register SV *sv) -{ - if (!sv) - return 0; - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvIOKp(sv)) - return SvUVX(sv); - if (SvNOKp(sv)) - return U_V(SvNVX(sv)); - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } - return 0; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) - return SvUV(tmpstr); - return (UV)SvRV(sv); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - return 0; - } - } - 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); - if (SvNVX(sv) >= -0.5) { - SvIsUV_on(sv); - SvUVX(sv) = U_V(SvNVX(sv)); - } - else { - SvIVX(sv) = I_V(SvNVX(sv)); - ret_zero: -#ifdef IV_IS_QUAD - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n", - (unsigned long)sv,(long)SvIVX(sv), - (long)(UV)SvIVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%lx 2uv(%ld => %lu) (as signed)\n", - (unsigned long)sv,(long)SvIVX(sv), - (long)(UV)SvIVX(sv))); -#endif - return (UV)SvIVX(sv); - } - } - else if (SvPOKp(sv) && SvLEN(sv)) { - I32 numtype = looks_like_number(sv); +#define new_XPV() my_safemalloc(sizeof(XPV)) +#define del_XPV(p) my_safefree(p) - /* 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; +#define new_XPVIV() my_safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) my_safefree(p) - d = Atof(SvPVX(sv)); +#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree(p) - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNVX(sv) = d; - (void)SvNOK_on(sv); - (void)SvIOK_on(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", - (unsigned long)sv, SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", - (unsigned long)sv, SvNVX(sv))); -#endif - if (SvNVX(sv) < -0.5) { - SvIVX(sv) = I_V(SvNVX(sv)); - goto ret_zero; - } 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; +#define new_XPVCV() my_safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) my_safefree(p) - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - SvUVX(sv) = 0; /* We assume that 0s have the - same bitmap in IV and UV. */ - (void)SvIOK_on(sv); - (void)SvIsUV_on(sv); - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - } - else { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - return 0; - } +#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", - (unsigned long)sv,SvUVX(sv))); - return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); -} +#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) -NV -Perl_sv_2nv(pTHX_ register SV *sv) -{ - if (!sv) - return 0.0; - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvNOKp(sv)) - return SvNVX(sv); - if (SvPOKp(sv) && SvLEN(sv)) { - dTHR; - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) - not_a_number(sv); - return Atof(SvPVX(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) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } - return 0; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) - return SvNV(tmpstr); - return (NV)(unsigned long)SvRV(sv); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - return 0.0; - } - } - if (SvTYPE(sv) < SVt_NV) { - if (SvTYPE(sv) == SVt_IV) - sv_upgrade(sv, SVt_PVNV); - else - sv_upgrade(sv, SVt_NV); -#if defined(USE_LONG_DOUBLE) - DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n", - (unsigned long)sv, SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n", - (unsigned long)sv, SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif - } - else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - if (SvIOKp(sv) && - (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) - { - SvNVX(sv) = SvIsUV(sv) ? (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); - SvNVX(sv) = Atof(SvPVX(sv)); - } - else { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - if (SvTYPE(sv) < SVt_NV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_NV); - return 0.0; - } - SvNOK_on(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", - (unsigned long)sv, SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n", - (unsigned long)sv, SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif - return SvNVX(sv); -} +#define new_XPVLV() my_safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) my_safefree(p) -STATIC IV -S_asIV(pTHX_ SV *sv) -{ - I32 numtype = looks_like_number(sv); - NV d; +#define new_XPVBM() my_safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) my_safefree(p) - if (numtype & IS_NUMBER_TO_INT_BY_ATOL) - return Atol(SvPVX(sv)); - if (!numtype) { - dTHR; - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - d = Atof(SvPVX(sv)); - return I_V(d); -} +#else /* !PURIFY */ -STATIC UV -S_asUV(pTHX_ SV *sv) -{ - I32 numtype = looks_like_number(sv); +#define new_XIV() (void*)new_xiv() +#define del_XIV(p) del_xiv((XPVIV*) p) -#ifdef HAS_STRTOUL - 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); - } - return U_V(Atof(SvPVX(sv))); -} +#define new_XNV() (void*)new_xnv() +#define del_XNV(p) del_xnv((XPVNV*) p) -/* - * Returns a combination of (advisory only - can get false negatives) - * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, - * IS_NUMBER_NEG - * 0 if does not look like number. - * - * In fact possible values are 0 and - * IS_NUMBER_TO_INT_BY_ATOL 123 - * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 - * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 - * with a possible addition of IS_NUMBER_NEG. - */ +#define new_XRV() (void*)new_xrv() +#define del_XRV(p) del_xrv((XRV*) p) -I32 -Perl_looks_like_number(pTHX_ SV *sv) -{ - register char *s; - register char *send; - register char *sbegin; - register char *nbegin; - I32 numtype = 0; - STRLEN len; +#define new_XPV() (void*)new_xpv() +#define del_XPV(p) del_xpv((XPV *)p) - if (SvPOK(sv)) { - sbegin = SvPVX(sv); - len = SvCUR(sv); - } - else if (SvPOKp(sv)) - sbegin = SvPV(sv, len); - else - return 1; - send = sbegin + len; +#define new_XPVIV() (void*)new_xpviv() +#define del_XPVIV(p) del_xpviv((XPVIV *)p) - s = sbegin; - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - numtype = IS_NUMBER_NEG; - } - else if (*s == '+') - s++; +#define new_XPVNV() (void*)new_xpvnv() +#define del_XPVNV(p) del_xpvnv((XPVNV *)p) - 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(). - */ +#define new_XPVCV() (void*)new_xpvcv() +#define del_XPVCV(p) del_xpvcv((XPVCV *)p) - /* next must be digit or the radix separator */ - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); +#define new_XPVAV() (void*)new_xpvav() +#define del_XPVAV(p) del_xpvav((XPVAV *)p) - 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; +#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) - if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) -#endif - ) { - s++; - numtype |= IS_NUMBER_NOT_IV; - while (isDIGIT(*s)) /* optional digits after the radix */ - s++; - } - } - else if (*s == '.' -#ifdef USE_LOCALE_NUMERIC - || IS_NUMERIC_RADIX(*s) -#endif - ) { - s++; - numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; - /* no digits before the radix means we need digits after it */ - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; - } - else - return 0; +#define new_XPVLV() (void*)new_xpvlv() +#define del_XPVLV(p) del_xpvlv((XPVLV *)p) - /* 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 (*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 IS_NUMBER_TO_INT_BY_ATOL; - return 0; -} +#define new_XPVBM() (void*)new_xpvbm() +#define del_XPVBM(p) del_xpvbm((XPVBM *)p) -char * -Perl_sv_2pv_nolen(pTHX_ register SV *sv) -{ - STRLEN n_a; - return sv_2pv(sv, &n_a); -} +#endif /* PURIFY */ -/* We assume that buf is at least TYPE_CHARS(UV) long. */ -static char * -uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) -{ - STRLEN len; - char *ptr = buf + TYPE_CHARS(UV); - char *ebuf = ptr; - int sign; - char *p; +#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) - 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; -} +/* +=for apidoc sv_upgrade -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - register char *s; - int olderrno; - SV *tsv; - char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ - char *tmpbuf = tbuf; +Upgrade an SV to a more complex form. Use C. See +C. - if (!sv) { - *lp = 0; - return ""; - } - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvPOKp(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - if (SvIOKp(sv)) { -#ifdef IV_IS_QUAD - if (SvIsUV(sv)) - (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv)); - else - (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv)); -#else - if (SvIsUV(sv)) - (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); - else - (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); -#endif - tsv = Nullsv; - goto tokensave; - } - if (SvNOKp(sv)) { - Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } - *lp = 0; - return ""; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) - return SvPV(tmpstr,*lp); - sv = (SV*)SvRV(sv); - if (!sv) - s = "NULLREF"; - else { - MAGIC *mg; - - switch (SvTYPE(sv)) { - case SVt_PVMG: - if ( ((SvFLAGS(sv) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) - == (SVs_OBJECT|SVs_RMG)) - && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") - && (mg = mg_find(sv, 'r'))) { - dTHR; - regexp *re = (regexp *)mg->mg_obj; +=cut +*/ - if (!mg->mg_ptr) { - char *fptr = "msix"; - char reflags[6]; - char ch; - int left = 0; - int right = 4; - U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; +bool +Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) +{ + char* pv; + U32 cur; + U32 len; + IV iv; + NV nv; + MAGIC* magic; + HV* stash; - while(ch = *fptr++) { - if(reganch & 1) { - reflags[left++] = ch; - } - else { - reflags[right--] = ch; - } - reganch >>= 1; - } - if(left != 4) { - reflags[left] = '-'; - left = 5; - } + if (SvTYPE(sv) == mt) + return TRUE; - mg->mg_len = re->prelen + 4 + left; - New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); - Copy("(?", mg->mg_ptr, 2, char); - Copy(reflags, mg->mg_ptr+2, left, char); - Copy(":", mg->mg_ptr+left+2, 1, char); - Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); - mg->mg_ptr[mg->mg_len - 1] = ')'; - mg->mg_ptr[mg->mg_len] = 0; - } - PL_reginterp_cnt += re->program[0].next_off; - *lp = mg->mg_len; - return mg->mg_ptr; - } - /* Fall through */ - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVBM: s = "SCALAR"; break; - case SVt_PVLV: s = "LVALUE"; break; - case SVt_PVAV: s = "ARRAY"; break; - case SVt_PVHV: s = "HASH"; break; - case SVt_PVCV: s = "CODE"; break; + 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); + cur = SvCUR(sv); + len = SvLEN(sv); + iv = SvIVX(sv); + nv = 0.0; + magic = 0; + stash = 0; + del_XPVIV(SvANY(sv)); + break; + case SVt_PVNV: + pv = SvPVX(sv); + cur = SvCUR(sv); + len = SvLEN(sv); + iv = SvIVX(sv); + nv = SvNVX(sv); + magic = 0; + stash = 0; + del_XPVNV(SvANY(sv)); + break; + case SVt_PVMG: + pv = SvPVX(sv); + cur = SvCUR(sv); + len = SvLEN(sv); + iv = SvIVX(sv); + nv = SvNVX(sv); + magic = SvMAGIC(sv); + stash = SvSTASH(sv); + del_XPVMG(SvANY(sv)); + break; + default: + Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); + } + + switch (mt) { + case SVt_NULL: + Perl_croak(aTHX_ "Can't upgrade to undef"); + case SVt_IV: + SvANY(sv) = new_XIV(); + SvIVX(sv) = iv; + break; + case SVt_NV: + SvANY(sv) = new_XNV(); + SvNVX(sv) = nv; + break; + case SVt_RV: + SvANY(sv) = new_XRV(); + SvRV(sv) = (SV*)pv; + break; + case SVt_PV: + SvANY(sv) = new_XPV(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + break; + case SVt_PVIV: + SvANY(sv) = new_XPVIV(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + if (SvNIOK(sv)) + (void)SvIOK_on(sv); + SvNOK_off(sv); + break; + case SVt_PVNV: + SvANY(sv) = new_XPVNV(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + break; + case SVt_PVMG: + SvANY(sv) = new_XPVMG(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + break; + case SVt_PVLV: + SvANY(sv) = new_XPVLV(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + LvTARGOFF(sv) = 0; + LvTARGLEN(sv) = 0; + LvTARG(sv) = 0; + LvTYPE(sv) = 0; + break; + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + if (pv) + Safefree(pv); + SvPVX(sv) = 0; + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + SvIVX(sv) = 0; + SvNVX(sv) = 0.0; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + AvALLOC(sv) = 0; + AvARYLEN(sv) = 0; + AvFLAGS(sv) = 0; + break; + case SVt_PVHV: + SvANY(sv) = new_XPVHV(); + if (pv) + Safefree(pv); + SvPVX(sv) = 0; + HvFILL(sv) = 0; + HvMAX(sv) = 0; + HvKEYS(sv) = 0; + SvNVX(sv) = 0.0; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + HvRITER(sv) = 0; + HvEITER(sv) = 0; + HvPMROOT(sv) = 0; + HvNAME(sv) = 0; + break; + case SVt_PVCV: + SvANY(sv) = new_XPVCV(); + Zero(SvANY(sv), 1, XPVCV); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + break; + case SVt_PVGV: + SvANY(sv) = new_XPVGV(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + GvGP(sv) = 0; + GvNAME(sv) = 0; + GvNAMELEN(sv) = 0; + GvSTASH(sv) = 0; + GvFLAGS(sv) = 0; + break; + case SVt_PVBM: + SvANY(sv) = new_XPVBM(); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + BmRARE(sv) = 0; + BmUSEFUL(sv) = 0; + BmPREVIOUS(sv) = 0; + break; + case SVt_PVFM: + SvANY(sv) = new_XPVFM(); + Zero(SvANY(sv), 1, XPVFM); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + break; + case SVt_PVIO: + SvANY(sv) = new_XPVIO(); + Zero(SvANY(sv), 1, XPVIO); + SvPVX(sv) = pv; + SvCUR(sv) = cur; + SvLEN(sv) = len; + SvIVX(sv) = iv; + SvNVX(sv) = nv; + SvMAGIC(sv) = magic; + SvSTASH(sv) = stash; + IoPAGE_LEN(sv) = 60; + break; + } + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= mt; + return TRUE; +} + +int +Perl_sv_backoff(pTHX_ register SV *sv) +{ + assert(SvOOK(sv)); + if (SvIVX(sv)) { + char *s = SvPVX(sv); + SvLEN(sv) += SvIVX(sv); + SvPVX(sv) -= SvIVX(sv); + SvIV_set(sv, 0); + Move(s, SvPVX(sv), SvCUR(sv)+1, char); + } + SvFLAGS(sv) &= ~SVf_OOK; + 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 * +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: %"UVxf"\n", (UV)newlen); + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ + if (SvROK(sv)) + sv_unref(sv); + if (SvTYPE(sv) < SVt_PV) { + sv_upgrade(sv, SVt_PV); + s = SvPVX(sv); + } + else if (SvOOK(sv)) { /* pv is offset? */ + sv_backoff(sv); + s = SvPVX(sv); + if (newlen > SvLEN(sv)) + newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ +#ifdef HAS_64K_LIMIT + if (newlen >= 0x10000) + newlen = 0xFFFF; +#endif + } + else + s = SvPVX(sv); + if (newlen > SvLEN(sv)) { /* need more room? */ + if (SvLEN(sv) && s) { +#if defined(MYMALLOC) && !defined(LEAKTEST) + STRLEN l = malloced_size((void*)SvPVX(sv)); + if (newlen <= l) { + SvLEN_set(sv, l); + return s; + } else +#endif + Renew(s,newlen,char); + } + else + New(703,s,newlen,char); + SvPV_set(sv, s); + SvLEN_set(sv, newlen); + } + return s; +} + +/* +=for apidoc sv_setiv + +Copies an integer into the given SV. Does not handle 'set' magic. See +C. + +=cut +*/ + +void +Perl_sv_setiv(pTHX_ register SV *sv, IV i) +{ + SV_CHECK_THINKFIRST(sv); + switch (SvTYPE(sv)) { + case SVt_NULL: + sv_upgrade(sv, SVt_IV); + break; + case SVt_NV: + sv_upgrade(sv, SVt_PVNV); + break; + case SVt_RV: + case SVt_PV: + sv_upgrade(sv, SVt_PVIV); + break; + + case SVt_PVGV: + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + { + dTHR; + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + PL_op_desc[PL_op->op_type]); + } + } + (void)SvIOK_only(sv); /* validate number */ + SvIVX(sv) = i; + SvTAINT(sv); +} + +/* +=for apidoc sv_setiv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +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 +Perl_sv_setuv(pTHX_ register SV *sv, UV 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 +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 +Perl_sv_setnv(pTHX_ register SV *sv, NV num) +{ + SV_CHECK_THINKFIRST(sv); + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + sv_upgrade(sv, SVt_NV); + break; + case SVt_RV: + case SVt_PV: + case SVt_PVIV: + sv_upgrade(sv, SVt_PVNV); + break; + + case SVt_PVGV: + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + { + dTHR; + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); + } + } + SvNVX(sv) = num; + (void)SvNOK_only(sv); /* validate number */ + SvTAINT(sv); +} + +/* +=for apidoc sv_setnv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) +{ + sv_setnv(sv,num); + SvSETMAGIC(sv); +} + +STATIC void +S_not_a_number(pTHX_ SV *sv) +{ + dTHR; + char tmpbuf[64]; + char *d = tmpbuf; + char *s; + char *limit = tmpbuf + sizeof(tmpbuf) - 8; + /* each *s can expand to 4 chars + "...\0", + i.e. need room for 8 chars */ + + for (s = SvPVX(sv); *s && d < limit; s++) { + int ch = *s & 0xFF; + if (ch & 128 && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; + ch &= 127; + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (*s) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + + if (PL_op) + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric in %s", tmpbuf, + PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_NUMERIC, + "Argument \"%s\" isn't numeric", tmpbuf); +} + +/* the number can be converted to integer with atol() or atoll() */ +#define IS_NUMBER_TO_INT_BY_ATOL 0x01 +#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ +#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ +#define IS_NUMBER_NEG 0x08 /* not good to cache UV */ + +/* Actually, ISO C leaves conversion of UV to IV undefined, but + until proven guilty, assume that things are not that bad... */ + +IV +Perl_sv_2iv(pTHX_ register SV *sv) +{ + if (!sv) + return 0; + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvIOKp(sv)) + return SvIVX(sv); + if (SvNOKp(sv)) { + return I_V(SvNVX(sv)); + } + if (SvPOKp(sv) && SvLEN(sv)) + return asIV(sv); + if (!SvROK(sv)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + report_uninit(); + } + return 0; + } + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + return SvIV(tmpstr); + return PTR2IV(SvRV(sv)); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + return 0; + } + } + 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) < (NV)IV_MAX + 0.5) + SvIVX(sv) = I_V(SvNVX(sv)); + 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)) { + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache an IV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such an IV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + if (numtype & IS_NUMBER_NOT_IV) { + /* May be not an integer. Need to cache NV if we cache IV + * - otherwise future conversion to NV will be wrong. */ + NV d; + + d = Atof(SvPVX(sv)); + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif + if (SvNVX(sv) < (NV)IV_MAX + 0.5) + SvIVX(sv) = I_V(SvNVX(sv)); + else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + goto ret_iv_max; + } + } + else if (numtype) { + /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = Atol(SvPVX(sv)); + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = 0; + (void)SvIOK_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + } + else { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + 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%"UVxf" 2iv(%"IVdf")\n", + PTR2UV(sv),SvIVX(sv))); + return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); +} + +UV +Perl_sv_2uv(pTHX_ register SV *sv) +{ + if (!sv) + return 0; + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvIOKp(sv)) + return SvUVX(sv); + if (SvNOKp(sv)) + return U_V(SvNVX(sv)); + if (SvPOKp(sv) && SvLEN(sv)) + return asUV(sv); + if (!SvROK(sv)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + report_uninit(); + } + return 0; + } + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer))) + return SvUV(tmpstr); + return PTR2UV(SvRV(sv)); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + return 0; + } + } + 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); + 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)) { + I32 numtype = looks_like_number(sv); + + /* We want to avoid a possible problem when we cache a UV which + may be later translated to an NV, and the resulting NV is not + the translation of the initial data. + + This means that if we cache such a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if not needed. + */ + if (numtype & IS_NUMBER_NOT_IV) { + /* May be not an integer. Need to cache NV if we cache IV + * - otherwise future conversion to NV will be wrong. */ + NV d; + + d = Atof(SvPVX(sv)); + + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNVX(sv) = d; + (void)SvNOK_on(sv); + (void)SvIOK_on(sv); +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2nv(%g)\n", + PTR2UV(sv), SvNVX(sv))); +#endif + if (SvNVX(sv) < -0.5) { + SvIVX(sv) = I_V(SvNVX(sv)); + goto ret_zero; + } else { + SvUVX(sv) = U_V(SvNVX(sv)); + SvIsUV_on(sv); + } + } + else if (numtype & IS_NUMBER_NEG) { + /* The NV may be reconstructed from IV - safe to cache IV, + which may be calculated by atol(). */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + SvIVX(sv) = (IV)Atol(SvPVX(sv)); + } + else if (numtype) { /* Non-negative */ + /* The NV may be reconstructed from UV - safe to cache UV, + which may be calculated by strtoul()/atol. */ + if (SvTYPE(sv) == SVt_PV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); +#ifdef HAS_STRTOUL + SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10); +#else /* no atou(), but we know the number fits into IV... */ + /* The only problem may be if it is negative... */ + SvUVX(sv) = (UV)Atol(SvPVX(sv)); +#endif + } + else { /* Not a number. Cache 0. */ + dTHR; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ + (void)SvIOK_on(sv); + (void)SvIsUV_on(sv); + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + } + else { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + 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%"UVxf" 2uv(%"UVuf")\n", + PTR2UV(sv),SvUVX(sv))); + return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); +} + +NV +Perl_sv_2nv(pTHX_ register SV *sv) +{ + if (!sv) + return 0.0; + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvNOKp(sv)) + return SvNVX(sv); + if (SvPOKp(sv) && SvLEN(sv)) { + dTHR; + if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) + not_a_number(sv); + return Atof(SvPVX(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) + report_uninit(); + } + return 0; + } + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer))) + return SvNV(tmpstr); + return PTR2NV(SvRV(sv)); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + return 0.0; + } + } + if (SvTYPE(sv) < SVt_NV) { + if (SvTYPE(sv) == SVt_IV) + sv_upgrade(sv, SVt_PVNV); + else + sv_upgrade(sv, SVt_NV); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, + "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif + } + else if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + if (SvIOKp(sv) && + (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) + { + SvNVX(sv) = 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); + SvNVX(sv) = Atof(SvPVX(sv)); + } + else { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + 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); +#if defined(USE_LONG_DOUBLE) + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + RESTORE_NUMERIC_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif + return SvNVX(sv); +} + +STATIC IV +S_asIV(pTHX_ SV *sv) +{ + I32 numtype = looks_like_number(sv); + NV d; + + if (numtype & IS_NUMBER_TO_INT_BY_ATOL) + return Atol(SvPVX(sv)); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + d = Atof(SvPVX(sv)); + return I_V(d); +} + +STATIC UV +S_asUV(pTHX_ SV *sv) +{ + I32 numtype = looks_like_number(sv); + +#ifdef HAS_STRTOUL + 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); + } + return U_V(Atof(SvPVX(sv))); +} + +/* + * Returns a combination of (advisory only - can get false negatives) + * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV, + * IS_NUMBER_NEG + * 0 if does not look like number. + * + * In fact possible values are 0 and + * IS_NUMBER_TO_INT_BY_ATOL 123 + * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 + * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * with a possible addition of IS_NUMBER_NEG. + */ + +/* +=for apidoc looks_like_number + +Test if an the content of an SV looks like a number (or is a +number). + +=cut +*/ + +I32 +Perl_looks_like_number(pTHX_ SV *sv) +{ + register char *s; + register char *send; + register char *sbegin; + register char *nbegin; + I32 numtype = 0; + STRLEN len; + + if (SvPOK(sv)) { + sbegin = SvPVX(sv); + len = SvCUR(sv); + } + else if (SvPOKp(sv)) + sbegin = SvPV(sv, len); + else + return 1; + send = sbegin + len; + + s = sbegin; + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + nbegin = s; + /* + * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted + * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need + * (int)atof(). + */ + + /* next must be digit or the radix separator */ + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + + if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */ + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; + else + numtype |= IS_NUMBER_TO_INT_BY_ATOL; + + if (*s == '.' +#ifdef USE_LOCALE_NUMERIC + || IS_NUMERIC_RADIX(*s) +#endif + ) { + s++; + numtype |= IS_NUMBER_NOT_IV; + while (isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (*s == '.' +#ifdef USE_LOCALE_NUMERIC + || IS_NUMERIC_RADIX(*s) +#endif + ) { + s++; + numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV; + /* no digits before the radix means we need digits after it */ + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } + else + return 0; + + /* 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 (*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 IS_NUMBER_TO_INT_BY_ATOL; + return 0; +} + +char * +Perl_sv_2pv_nolen(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +/* We assume that buf is at least TYPE_CHARS(UV) long. */ +static char * +uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +{ + STRLEN len; + char *ptr = buf + TYPE_CHARS(UV); + char *ebuf = ptr; + int sign; + char *p; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + +char * +Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) +{ + register char *s; + int olderrno; + SV *tsv; + char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + char *tmpbuf = tbuf; + + if (!sv) { + *lp = 0; + return ""; + } + if (SvGMAGICAL(sv)) { + mg_get(sv); + if (SvPOKp(sv)) { + *lp = SvCUR(sv); + return SvPVX(sv); + } + if (SvIOKp(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)) { + Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); + tsv = Nullsv; + goto tokensave; + } + if (!SvROK(sv)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + report_uninit(); + } + *lp = 0; + return ""; + } + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + SV* tmpstr; + if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string))) + return SvPV(tmpstr,*lp); + sv = (SV*)SvRV(sv); + if (!sv) + s = "NULLREF"; + else { + MAGIC *mg; + + switch (SvTYPE(sv)) { + case SVt_PVMG: + if ( ((SvFLAGS(sv) & + (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|SVs_RMG)) + && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") + && (mg = mg_find(sv, 'r'))) { + dTHR; + regexp *re = (regexp *)mg->mg_obj; + + if (!mg->mg_ptr) { + char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; + + while(ch = *fptr++) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); + Copy("(?", mg->mg_ptr, 2, char); + Copy(reflags, mg->mg_ptr+2, left, char); + Copy(":", mg->mg_ptr+left+2, 1, char); + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; + } + PL_reginterp_cnt += re->program[0].next_off; + *lp = mg->mg_len; + return mg->mg_ptr; + } + /* Fall through */ + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_RV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVBM: s = "SCALAR"; break; + case SVt_PVLV: s = "LVALUE"; break; + case SVt_PVAV: s = "ARRAY"; break; + case SVt_PVHV: s = "HASH"; break; + case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; case SVt_PVFM: s = "FORMAT"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } - tsv = NEWSV(0,0); - if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); - else - sv_setpv(tsv, s); -#ifdef IV_IS_QUAD - Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv); -#else - Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv); -#endif - goto tokensaveref; + tsv = NEWSV(0,0); + if (SvOBJECT(sv)) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + else + sv_setpv(tsv, s); + Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); + goto tokensaveref; + } + *lp = strlen(s); + return s; + } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + *lp = 0; + return ""; + } + } + if (SvNOKp(sv)) { /* See note in sv_2uv() */ + /* XXXX 64-bit? IV may have better precision... */ + /* I tried changing this for to be 64-bit-aware and + * the t/op/numconvert.t became very, very, angry. + * --jhi Sep 1999 */ + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvGROW(sv, 28); + s = SvPVX(sv); + olderrno = errno; /* some Xenix systems wipe out errno here */ +#ifdef apollo + if (SvNVX(sv) == 0.0) + (void)strcpy(s,"0"); + else +#endif /*apollo*/ + { + Gconvert(SvNVX(sv), NV_DIG, 0, s); + } + errno = olderrno; +#ifdef FIXNEGATIVEZERO + if (*s == '-' && s[1] == '0' && !s[2]) + strcpy(s,"0"); +#endif + while (*s) s++; +#ifdef hcx + if (s[-1] == '.') + *--s = '\0'; +#endif + } + else if (SvIOKp(sv)) { + U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; + + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + if (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); + *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)) + { + 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%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); + return SvPVX(sv); + + tokensave: + if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ + /* Sneaky stuff here */ + + tokensaveref: + if (!tsv) + tsv = newSVpv(tmpbuf, 0); + sv_2mortal(tsv); + *lp = SvCUR(tsv); + return SvPVX(tsv); + } + else { + STRLEN len; + char *t; + + if (tsv) { + sv_2mortal(tsv); + t = SvPVX(tsv); + len = SvCUR(tsv); + } + else { + t = tmpbuf; + len = strlen(tmpbuf); + } +#ifdef FIXNEGATIVEZERO + if (len == 2 && t[0] == '-' && t[1] == '0') { + t = "0"; + len = 1; + } +#endif + (void)SvUPGRADE(sv, SVt_PV); + *lp = len; + s = SvGROW(sv, len + 1); + SvCUR_set(sv, len); + (void)strcpy(s, t); + SvPOKp_on(sv); + return s; + } +} + +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 +Perl_sv_2bool(pTHX_ register SV *sv) +{ + if (SvGMAGICAL(sv)) + mg_get(sv); + + if (!SvOK(sv)) + return 0; + if (SvROK(sv)) { + dTHR; + SV* tmpsv; + if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) + return SvTRUE(tmpsv); + return SvRV(sv) != 0; + } + if (SvPOKp(sv)) { + register XPV* Xpvtmp; + if ((Xpvtmp = (XPV*)SvANY(sv)) && + (*Xpvtmp->xpv_pv > '0' || + Xpvtmp->xpv_cur > 1 || + (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0'))) + return 1; + else + return 0; + } + else { + if (SvIOKp(sv)) + return SvIVX(sv) != 0; + else { + if (SvNOKp(sv)) + return SvNVX(sv) != 0.0; + else + return FALSE; + } + } +} + +void +Perl_sv_utf8_upgrade(pTHX_ register SV *sv) +{ + int hicount; + char *c; + + if (!sv || !SvPOK(sv) || SvUTF8(sv)) + return; + + /* This function could be much more efficient if we had a FLAG + * to signal if there are any hibit chars in the string + */ + hicount = 0; + for (c = SvPVX(sv); c < SvEND(sv); c++) { + if (*c & 0x80) + hicount++; + } + + if (hicount) { + char *src, *dst; + SvGROW(sv, SvCUR(sv) + hicount + 1); + + src = SvEND(sv) - 1; + SvCUR_set(sv, SvCUR(sv) + hicount); + dst = SvEND(sv) - 1; + + while (src < dst) { + if (*src & 0x80) { + dst--; + uv_to_utf8((U8*)dst, (U8)*src--); + dst--; + } + else { + *dst-- = *src--; + } + } + + SvUTF8_on(sv); + } +} + +bool +Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) +{ + if (SvPOK(sv) && SvUTF8(sv)) { + char *c = SvPVX(sv); + char *first_hi = 0; + /* need to figure out if this is possible at all first */ + while (c < SvEND(sv)) { + if (*c & 0x80) { + I32 len; + UV uv = utf8_to_uv((U8*)c, &len); + if (uv >= 256) { + if (fail_ok) + return FALSE; + else { + /* XXX might want to make a callback here instead */ + Perl_croak(aTHX_ "Big byte"); + } + } + if (!first_hi) + first_hi = c; + c += len; + } + else { + c++; + } + } + + if (first_hi) { + char *src = first_hi; + char *dst = first_hi; + while (src < SvEND(sv)) { + if (*src & 0x80) { + I32 len; + U8 u = (U8)utf8_to_uv((U8*)src, &len); + *dst++ = u; + src += len; + } + else { + *dst++ = *src++; + } + } + SvCUR_set(sv, dst - SvPVX(sv)); + } + SvUTF8_off(sv); + } + return TRUE; +} + +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); + while (c < SvEND(sv)) { + if (*c & 0x80) { + I32 len; + (void)utf8_to_uv((U8*)c, &len); + if (len == 1) { + /* bad utf8 */ + return FALSE; + } + c += len; + has_utf = TRUE; + } + else { + c++; + } + } + + if (has_utf) + SvUTF8_on(sv); + } + 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 +Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) +{ + dTHR; + register U32 sflags; + register int dtype; + register int stype; + + if (sstr == dstr) + return; + SV_CHECK_THINKFIRST(dstr); + if (!sstr) + sstr = &PL_sv_undef; + stype = SvTYPE(sstr); + dtype = SvTYPE(dstr); + + SvAMAGIC_off(dstr); + + /* There's a lot of redundancy below but we're going for speed here */ + + switch (stype) { + case SVt_NULL: + undef_sstr: + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; + case SVt_IV: + if (SvIOK(sstr)) { + switch (dtype) { + case SVt_NULL: + sv_upgrade(dstr, SVt_IV); + break; + case SVt_NV: + sv_upgrade(dstr, SVt_PVNV); + break; + case SVt_RV: + case SVt_PV: + sv_upgrade(dstr, SVt_PVIV); + break; + } + (void)SvIOK_only(dstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); + SvTAINT(dstr); + return; + } + goto undef_sstr; + + case SVt_NV: + if (SvNOK(sstr)) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: + sv_upgrade(dstr, SVt_NV); + break; + case SVt_RV: + case SVt_PV: + case SVt_PVIV: + sv_upgrade(dstr, SVt_PVNV); + break; + } + SvNVX(dstr) = SvNVX(sstr); + (void)SvNOK_only(dstr); + SvTAINT(dstr); + return; + } + goto undef_sstr; + + case SVt_RV: + if (dtype < SVt_RV) + sv_upgrade(dstr, SVt_RV); + else if (dtype == SVt_PVGV && + SvTYPE(SvRV(sstr)) == SVt_PVGV) { + sstr = SvRV(sstr); + if (sstr == dstr) { + if (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_on(dstr); + } + GvMULTI_on(dstr); + return; + } + goto glob_assign; + } + break; + case SVt_PV: + case SVt_PVFM: + if (dtype < SVt_PV) + sv_upgrade(dstr, SVt_PV); + break; + case SVt_PVIV: + if (dtype < SVt_PVIV) + sv_upgrade(dstr, SVt_PVIV); + break; + case SVt_PVNV: + if (dtype < SVt_PVNV) + sv_upgrade(dstr, SVt_PVNV); + break; + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVIO: + if (PL_op) + Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), + PL_op_name[PL_op->op_type]); + else + Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); + break; + + case SVt_PVGV: + if (dtype <= SVt_PVGV) { + glob_assign: + if (dtype != SVt_PVGV) { + char *name = GvNAME(sstr); + STRLEN len = GvNAMELEN(sstr); + sv_upgrade(dstr, SVt_PVGV); + sv_magic(dstr, dstr, '*', name, len); + GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); + GvNAME(dstr) = savepvn(name, len); + GvNAMELEN(dstr) = len; + SvFAKE_on(dstr); /* can coerce to non-glob */ + } + /* ahem, death to those who redefine active sort subs */ + else if (PL_curstackinfo->si_type == PERLSI_SORT + && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) + Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", + GvNAME(dstr)); + (void)SvOK_off(dstr); + GvINTRO_off(dstr); /* one-shot flag */ + gp_free((GV*)dstr); + GvGP(dstr) = gp_ref(GvGP(sstr)); + SvTAINT(dstr); + if (GvIMPORTED(dstr) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_on(dstr); + } + GvMULTI_on(dstr); + return; + } + /* FALL THROUGH */ + + default: + if (SvGMAGICAL(sstr)) { + mg_get(sstr); + if (SvTYPE(sstr) != stype) { + stype = SvTYPE(sstr); + if (stype == SVt_PVGV && dtype <= SVt_PVGV) + goto glob_assign; + } + } + if (stype == SVt_PVLV) + (void)SvUPGRADE(dstr, SVt_PVNV); + else + (void)SvUPGRADE(dstr, stype); + } + + sflags = SvFLAGS(sstr); + + if (sflags & SVf_ROK) { + if (dtype >= SVt_PV) { + if (dtype == SVt_PVGV) { + SV *sref = SvREFCNT_inc(SvRV(sstr)); + SV *dref = 0; + int intro = GvINTRO(dstr); + + if (intro) { + GP *gp; + 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) = CopLINE(PL_curcop); + GvEGV(dstr) = (GV*)dstr; + } + GvMULTI_on(dstr); + switch (SvTYPE(sref)) { + case SVt_PVAV: + if (intro) + SAVESPTR(GvAV(dstr)); + else + dref = (SV*)GvAV(dstr); + GvAV(dstr) = (AV*)sref; + if (GvIMPORTED_AV_off(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_AV_on(dstr); + } + break; + case SVt_PVHV: + if (intro) + SAVESPTR(GvHV(dstr)); + else + dref = (SV*)GvHV(dstr); + GvHV(dstr) = (HV*)sref; + if (GvIMPORTED_HV_off(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_HV_on(dstr); + } + break; + case SVt_PVCV: + if (intro) { + if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { + SvREFCNT_dec(GvCV(dstr)); + GvCV(dstr) = Nullcv; + GvCVGEN(dstr) = 0; /* Switch off cacheness. */ + PL_sub_generation++; + } + SAVESPTR(GvCV(dstr)); + } + else + dref = (SV*)GvCV(dstr); + if (GvCV(dstr) != (CV*)sref) { + CV* cv = GvCV(dstr); + if (cv) { + if (!GvCVGEN((GV*)dstr) && + (CvROOT(cv) || CvXSUB(cv))) + { + SV *const_sv = cv_const_sv(cv); + bool const_changed = TRUE; + if(const_sv) + const_changed = sv_cmp(const_sv, + op_const_sv(CvSTART((CV*)sref), + Nullcv)); + /* ahem, death to those who redefine + * active sort subs */ + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) + Perl_croak(aTHX_ + "Can't redefine active sort subroutine %s", + GvENAME((GV*)dstr)); + if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE)) + Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } + cv_ckproto(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX(sref) : Nullch); + } + GvCV(dstr) = (CV*)sref; + GvCVGEN(dstr) = 0; /* Switch off cacheness. */ + GvASSUMECV_on(dstr); + PL_sub_generation++; + } + if (GvIMPORTED_CV_off(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_CV_on(dstr); + } + break; + case SVt_PVIO: + if (intro) + SAVESPTR(GvIOp(dstr)); + else + dref = (SV*)GvIOp(dstr); + GvIOp(dstr) = (IO*)sref; + break; + default: + if (intro) + SAVESPTR(GvSV(dstr)); + else + dref = (SV*)GvSV(dstr); + GvSV(dstr) = sref; + if (GvIMPORTED_SV_off(dstr) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) + { + GvIMPORTED_SV_on(dstr); + } + break; + } + if (dref) + SvREFCNT_dec(dref); + if (intro) + SAVEFREESV(sref); + SvTAINT(dstr); + return; + } + if (SvPVX(dstr)) { + (void)SvOOK_off(dstr); /* backoff */ + if (SvLEN(dstr)) + Safefree(SvPVX(dstr)); + SvLEN(dstr)=SvCUR(dstr)=0; } - *lp = strlen(s); - return s; } - if (SvREADONLY(sv) && !SvOK(sv)) { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - *lp = 0; - return ""; + (void)SvOK_off(dstr); + SvRV(dstr) = SvREFCNT_inc(SvRV(sstr)); + SvROK_on(dstr); + if (sflags & SVp_NOK) { + SvNOK_on(dstr); + SvNVX(dstr) = SvNVX(sstr); + } + if (sflags & SVp_IOK) { + (void)SvIOK_on(dstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); + } + if (SvAMAGIC(sstr)) { + SvAMAGIC_on(dstr); } } - if (SvNOKp(sv)) { /* See note in sv_2uv() */ - /* XXXX 64-bit? IV may have better precision... */ - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvGROW(sv, 28); - s = SvPVX(sv); - olderrno = errno; /* some Xenix systems wipe out errno here */ -#ifdef apollo - if (SvNVX(sv) == 0.0) - (void)strcpy(s,"0"); - else -#endif /*apollo*/ + else if (sflags & SVp_POK) { + + /* + * Check to see if we can just swipe the string. If so, it's a + * possible small lose on short strings, but a big win on long ones. + * It might even be a win on short strings if SvPVX(dstr) + * has to be allocated and SvPVX(sstr) has to be freed. + */ + + 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? */ { - Gconvert(SvNVX(sv), NV_DIG, 0, s); + if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ + if (SvOOK(dstr)) { + SvFLAGS(dstr) &= ~SVf_OOK; + Safefree(SvPVX(dstr) - SvIVX(dstr)); + } + 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); + SvPV_set(sstr, Nullch); + SvLEN_set(sstr, 0); + SvCUR_set(sstr, 0); + SvTEMP_off(sstr); } - errno = olderrno; -#ifdef FIXNEGATIVEZERO - if (*s == '-' && s[1] == '0' && !s[2]) - strcpy(s,"0"); -#endif - while (*s) s++; -#ifdef hcx - if (s[-1] == '.') - *--s = '\0'; -#endif - } - else if (SvIOKp(sv)) { - U32 isIOK = SvIOK(sv); - U32 isUIOK = SvIsUV(sv); - char buf[TYPE_CHARS(UV)]; - char *ebuf, *ptr; + else { /* have to copy actual string */ + STRLEN len = SvCUR(sstr); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - 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); - *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); - SvPOK_on(sv); + SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ + Move(SvPVX(sstr),SvPVX(dstr),len,char); + SvCUR_set(dstr, len); + *SvEND(dstr) = '\0'; + (void)SvPOK_only(dstr); + } + if (DO_UTF8(sstr)) + SvUTF8_on(dstr); + /*SUPPRESS 560*/ + if (sflags & SVp_NOK) { + SvNOK_on(dstr); + SvNVX(dstr) = SvNVX(sstr); + } + if (sflags & SVp_IOK) { + (void)SvIOK_on(dstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); + } + } + else if (sflags & SVp_NOK) { + SvNVX(dstr) = SvNVX(sstr); + (void)SvNOK_only(dstr); + if (SvIOK(sstr)) { + (void)SvIOK_on(dstr); + SvIVX(dstr) = SvIVX(sstr); + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + if (SvIsUV(sstr)) + SvIsUV_on(dstr); + } + } + else if (sflags & SVp_IOK) { + (void)SvIOK_only(dstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvIsUV(sstr)) + SvIsUV_on(dstr); } else { - dTHR; - if (ckWARN(WARN_UNINITIALIZED) - && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - { - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + if (dtype == SVt_PVGV) { + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob"); } - *lp = 0; - if (SvTYPE(sv) < SVt_PV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_PV); - return ""; + else + (void)SvOK_off(dstr); } - *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))); - return SvPVX(sv); + SvTAINT(dstr); +} + +/* +=for apidoc sv_setsv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +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 +Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +{ + register char *dptr; + assert(len >= 0); /* STRLEN is probably unsigned, so this may + elicit a warning, but it won't hurt. */ + SV_CHECK_THINKFIRST(sv); + if (!ptr) { + (void)SvOK_off(sv); + return; + } + (void)SvUPGRADE(sv, SVt_PV); + + SvGROW(sv, len + 1); + dptr = SvPVX(sv); + Move(ptr,dptr,len,char); + dptr[len] = '\0'; + SvCUR_set(sv, len); + (void)SvPOK_only(sv); /* validate pointer */ + SvTAINT(sv); +} + +/* +=for apidoc sv_setpvn_mg - tokensave: - if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ - /* Sneaky stuff here */ +Like C, but also handles 'set' magic. - tokensaveref: - if (!tsv) - tsv = newSVpv(tmpbuf, 0); - sv_2mortal(tsv); - *lp = SvCUR(tsv); - return SvPVX(tsv); +=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 +Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) +{ + register STRLEN len; + + SV_CHECK_THINKFIRST(sv); + if (!ptr) { + (void)SvOK_off(sv); + return; } - else { - STRLEN len; - char *t; + len = strlen(ptr); + (void)SvUPGRADE(sv, SVt_PV); - if (tsv) { - sv_2mortal(tsv); - t = SvPVX(tsv); - len = SvCUR(tsv); - } - else { - t = tmpbuf; - len = strlen(tmpbuf); - } -#ifdef FIXNEGATIVEZERO - if (len == 2 && t[0] == '-' && t[1] == '0') { - t = "0"; - len = 1; - } -#endif - (void)SvUPGRADE(sv, SVt_PV); - *lp = len; - s = SvGROW(sv, len + 1); - SvCUR_set(sv, len); - (void)strcpy(s, t); - SvPOKp_on(sv); - return s; + SvGROW(sv, len + 1); + Move(ptr,SvPVX(sv),len+1,char); + SvCUR_set(sv, len); + (void)SvPOK_only(sv); /* validate pointer */ + SvTAINT(sv); +} + +/* +=for apidoc sv_setpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +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 +Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) +{ + SV_CHECK_THINKFIRST(sv); + (void)SvUPGRADE(sv, SVt_PV); + if (!ptr) { + (void)SvOK_off(sv); + return; } + (void)SvOOK_off(sv); + if (SvPVX(sv) && SvLEN(sv)) + Safefree(SvPVX(sv)); + Renew(ptr, len+1, char); + SvPVX(sv) = ptr; + SvCUR_set(sv, len); + SvLEN_set(sv, len+1); + *SvEND(sv) = '\0'; + (void)SvPOK_only(sv); /* validate pointer */ + SvTAINT(sv); } -/* This function is only called on magical items */ -bool -Perl_sv_2bool(pTHX_ register SV *sv) +/* +=for apidoc sv_usepvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { - if (SvGMAGICAL(sv)) - mg_get(sv); + sv_usepvn(sv,ptr,len); + SvSETMAGIC(sv); +} - if (!SvOK(sv)) - return 0; - if (SvROK(sv)) { +void +Perl_sv_force_normal(pTHX_ register SV *sv) +{ + if (SvREADONLY(sv)) { dTHR; - SV* tmpsv; - if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) - return SvTRUE(tmpsv); - return SvRV(sv) != 0; - } - if (SvPOKp(sv)) { - register XPV* Xpvtmp; - if ((Xpvtmp = (XPV*)SvANY(sv)) && - (*Xpvtmp->xpv_pv > '0' || - Xpvtmp->xpv_cur > 1 || - (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0'))) - return 1; - else - return 0; + if (PL_curcop != &PL_compiling) + Perl_croak(aTHX_ PL_no_modify); } - else { - if (SvIOKp(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOKp(sv)) - return SvNVX(sv) != 0.0; - else - return FALSE; + 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 +Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ + + +{ + register STRLEN delta; + + if (!ptr || !SvPOKp(sv)) + return; + SV_CHECK_THINKFIRST(sv); + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv,SVt_PVIV); + + if (!SvOOK(sv)) { + if (!SvLEN(sv)) { /* make copy of shared string */ + char *pvx = SvPVX(sv); + STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; } + SvIVX(sv) = 0; + SvFLAGS(sv) |= SVf_OOK; } + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); + delta = ptr - SvPVX(sv); + SvLEN(sv) -= delta; + SvCUR(sv) -= delta; + SvPVX(sv) += delta; + SvIVX(sv) += delta; } -/* 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_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 -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) +Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { - dTHR; - register U32 sflags; - register int dtype; - register int stype; + STRLEN tlen; + char *junk; - if (sstr == dstr) - return; - SV_CHECK_THINKFIRST(dstr); - if (!sstr) - sstr = &PL_sv_undef; - stype = SvTYPE(sstr); - dtype = SvTYPE(dstr); + junk = SvPV_force(sv, tlen); + SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); + Move(ptr,SvPVX(sv)+tlen,len,char); + SvCUR(sv) += len; + *SvEND(sv) = '\0'; + (void)SvPOK_only_UTF8(sv); /* validate pointer */ + SvTAINT(sv); +} - SvAMAGIC_off(dstr); +/* +=for apidoc sv_catpvn_mg - /* There's a lot of redundancy below but we're going for speed here */ +Like C, but also handles 'set' magic. - switch (stype) { - case SVt_NULL: - undef_sstr: - if (dtype != SVt_PVGV) { - (void)SvOK_off(dstr); - return; - } - break; - case SVt_IV: - if (SvIOK(sstr)) { - switch (dtype) { - case SVt_NULL: - sv_upgrade(dstr, SVt_IV); - break; - case SVt_NV: - sv_upgrade(dstr, SVt_PVNV); - break; - case SVt_RV: - case SVt_PV: - sv_upgrade(dstr, SVt_PVIV); - break; - } - (void)SvIOK_only(dstr); - SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) - SvIsUV_on(dstr); - SvTAINT(dstr); - return; - } - goto undef_sstr; +=cut +*/ + +void +Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +{ + sv_catpvn(sv,ptr,len); + SvSETMAGIC(sv); +} - case SVt_NV: - if (SvNOK(sstr)) { - switch (dtype) { - case SVt_NULL: - case SVt_IV: - sv_upgrade(dstr, SVt_NV); - break; - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - sv_upgrade(dstr, SVt_PVNV); - break; - } - SvNVX(dstr) = SvNVX(sstr); - (void)SvNOK_only(dstr); - SvTAINT(dstr); - return; - } - goto undef_sstr; +/* +=for apidoc sv_catsv - case SVt_RV: - if (dtype < SVt_RV) - sv_upgrade(dstr, SVt_RV); - else if (dtype == SVt_PVGV && - SvTYPE(SvRV(sstr)) == SVt_PVGV) { - sstr = SvRV(sstr); - if (sstr == dstr) { - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_on(dstr); - GvMULTI_on(dstr); - return; - } - goto glob_assign; - } - break; - case SVt_PV: - case SVt_PVFM: - if (dtype < SVt_PV) - sv_upgrade(dstr, SVt_PV); - break; - case SVt_PVIV: - if (dtype < SVt_PVIV) - sv_upgrade(dstr, SVt_PVIV); - break; - case SVt_PVNV: - if (dtype < SVt_PVNV) - sv_upgrade(dstr, SVt_PVNV); - break; - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVIO: - if (PL_op) - Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), - PL_op_name[PL_op->op_type]); - else - Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); - break; +Concatenates the string from SV C onto the end of the string in SV +C. Handles 'get' magic, but not 'set' magic. See C. - case SVt_PVGV: - if (dtype <= SVt_PVGV) { - glob_assign: - if (dtype != SVt_PVGV) { - char *name = GvNAME(sstr); - STRLEN len = GvNAMELEN(sstr); - sv_upgrade(dstr, SVt_PVGV); - sv_magic(dstr, dstr, '*', name, len); - GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); - GvNAME(dstr) = savepvn(name, len); - GvNAMELEN(dstr) = len; - SvFAKE_on(dstr); /* can coerce to non-glob */ - } - /* ahem, death to those who redefine active sort subs */ - else if (PL_curstackinfo->si_type == PERLSI_SORT - && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", - GvNAME(dstr)); - (void)SvOK_off(dstr); - GvINTRO_off(dstr); /* one-shot flag */ - gp_free((GV*)dstr); - GvGP(dstr) = gp_ref(GvGP(sstr)); - SvTAINT(dstr); - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_on(dstr); - GvMULTI_on(dstr); - return; - } - /* FALL THROUGH */ +=cut +*/ - default: - if (SvGMAGICAL(sstr)) { - mg_get(sstr); - if (SvTYPE(sstr) != stype) { - stype = SvTYPE(sstr); - if (stype == SVt_PVGV && dtype <= SVt_PVGV) - goto glob_assign; - } - } - if (stype == SVt_PVLV) - (void)SvUPGRADE(dstr, SVt_PVNV); - else - (void)SvUPGRADE(dstr, stype); +void +Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) +{ + char *s; + STRLEN len; + if (!sstr) + return; + if (s = SvPV(sstr, len)) { + if (SvUTF8(sstr)) + sv_utf8_upgrade(dstr); + sv_catpvn(dstr,s,len); + if (SvUTF8(sstr)) + SvUTF8_on(dstr); } +} - sflags = SvFLAGS(sstr); +/* +=for apidoc sv_catsv_mg - if (sflags & SVf_ROK) { - if (dtype >= SVt_PV) { - if (dtype == SVt_PVGV) { - SV *sref = SvREFCNT_inc(SvRV(sstr)); - SV *dref = 0; - int intro = GvINTRO(dstr); +Like C, but also handles 'set' magic. - if (intro) { - GP *gp; - GvGP(dstr)->gp_refcnt--; - 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; - GvEGV(dstr) = (GV*)dstr; - } - GvMULTI_on(dstr); - switch (SvTYPE(sref)) { - case SVt_PVAV: - if (intro) - SAVESPTR(GvAV(dstr)); - else - dref = (SV*)GvAV(dstr); - GvAV(dstr) = (AV*)sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_AV_on(dstr); - break; - case SVt_PVHV: - if (intro) - SAVESPTR(GvHV(dstr)); - else - dref = (SV*)GvHV(dstr); - GvHV(dstr) = (HV*)sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_HV_on(dstr); - break; - case SVt_PVCV: - if (intro) { - if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { - SvREFCNT_dec(GvCV(dstr)); - GvCV(dstr) = Nullcv; - GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - PL_sub_generation++; - } - SAVESPTR(GvCV(dstr)); - } - else - dref = (SV*)GvCV(dstr); - if (GvCV(dstr) != (CV*)sref) { - CV* cv = GvCV(dstr); - if (cv) { - if (!GvCVGEN((GV*)dstr) && - (CvROOT(cv) || CvXSUB(cv))) - { - SV *const_sv = cv_const_sv(cv); - bool const_changed = TRUE; - if(const_sv) - const_changed = sv_cmp(const_sv, - op_const_sv(CvSTART((CV*)sref), - Nullcv)); - /* ahem, death to those who redefine - * active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && - PL_sortcop == CvSTART(cv)) - 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"))) - Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? - "Constant subroutine %s redefined" - : "Subroutine %s redefined", - GvENAME((GV*)dstr)); - } - } - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX(sref) : Nullch); - } - GvCV(dstr) = (CV*)sref; - GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - GvASSUMECV_on(dstr); - PL_sub_generation++; - } - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_CV_on(dstr); - break; - case SVt_PVIO: - if (intro) - SAVESPTR(GvIOp(dstr)); - else - dref = (SV*)GvIOp(dstr); - GvIOp(dstr) = (IO*)sref; - break; - default: - if (intro) - SAVESPTR(GvSV(dstr)); - else - dref = (SV*)GvSV(dstr); - GvSV(dstr) = sref; - if (PL_curcop->cop_stash != GvSTASH(dstr)) - GvIMPORTED_SV_on(dstr); - break; - } - if (dref) - SvREFCNT_dec(dref); - if (intro) - SAVEFREESV(sref); - SvTAINT(dstr); - return; - } - if (SvPVX(dstr)) { - (void)SvOOK_off(dstr); /* backoff */ - if (SvLEN(dstr)) - Safefree(SvPVX(dstr)); - SvLEN(dstr)=SvCUR(dstr)=0; - } - } - (void)SvOK_off(dstr); - SvRV(dstr) = SvREFCNT_inc(SvRV(sstr)); - SvROK_on(dstr); - if (sflags & SVp_NOK) { - SvNOK_on(dstr); - SvNVX(dstr) = SvNVX(sstr); - } - if (sflags & SVp_IOK) { - (void)SvIOK_on(dstr); - SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) - SvIsUV_on(dstr); - } - if (SvAMAGIC(sstr)) { - SvAMAGIC_on(dstr); - } +=cut +*/ + +void +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 +Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) +{ + register STRLEN len; + STRLEN tlen; + char *junk; + + if (!ptr) + return; + junk = SvPV_force(sv, tlen); + len = strlen(ptr); + SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); + Move(ptr,SvPVX(sv)+tlen,len+1,char); + SvCUR(sv) += len; + (void)SvPOK_only_UTF8(sv); /* validate pointer */ + SvTAINT(sv); +} + +/* +=for apidoc sv_catpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) +{ + sv_catpv(sv,ptr); + SvSETMAGIC(sv); +} + +SV * +Perl_newSV(pTHX_ STRLEN len) +{ + register SV *sv; + + new_SV(sv); + if (len) { + sv_upgrade(sv, SVt_PV); + SvGROW(sv, len + 1); } - else if (sflags & SVp_POK) { + return sv; +} - /* - * Check to see if we can just swipe the string. If so, it's a - * possible small lose on short strings, but a big win on long ones. - * It might even be a win on short strings if SvPVX(dstr) - * has to be allocated and SvPVX(sstr) has to be freed. - */ +/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ - 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? */ - { - if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ - if (SvOOK(dstr)) { - SvFLAGS(dstr) &= ~SVf_OOK; - Safefree(SvPVX(dstr) - SvIVX(dstr)); - } - 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); - SvPV_set(sstr, Nullch); - SvLEN_set(sstr, 0); - SvCUR_set(sstr, 0); - SvTEMP_off(sstr); - } - else { /* have to copy actual string */ - STRLEN len = SvCUR(sstr); +/* +=for apidoc sv_magic - SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ - Move(SvPVX(sstr),SvPVX(dstr),len,char); - SvCUR_set(dstr, len); - *SvEND(dstr) = '\0'; - (void)SvPOK_only(dstr); - } - /*SUPPRESS 560*/ - if (sflags & SVp_NOK) { - SvNOK_on(dstr); - SvNVX(dstr) = SvNVX(sstr); - } - if (sflags & SVp_IOK) { - (void)SvIOK_on(dstr); - SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) - SvIsUV_on(dstr); - } +Adds magic to an SV. + +=cut +*/ + +void +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)) + Perl_croak(aTHX_ PL_no_modify); } - else if (sflags & SVp_NOK) { - SvNVX(dstr) = SvNVX(sstr); - (void)SvNOK_only(dstr); - if (SvIOK(sstr)) { - (void)SvIOK_on(dstr); - SvIVX(dstr) = SvIVX(sstr); - /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - if (SvIsUV(sstr)) - SvIsUV_on(dstr); + if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + if (how == 't') + mg->mg_len |= 1; + return; } } - else if (sflags & SVp_IOK) { - (void)SvIOK_only(dstr); - SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) - SvIsUV_on(dstr); + else { + (void)SvUPGRADE(sv, SVt_PVMG); } + Newz(702,mg, 1, MAGIC); + mg->mg_moremagic = SvMAGIC(sv); + + SvMAGIC(sv) = mg; + if (!obj || obj == sv || how == '#' || how == 'r') + mg->mg_obj = obj; else { - if (dtype == SVt_PVGV) { - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob"); + dTHR; + mg->mg_obj = SvREFCNT_inc(obj); + mg->mg_flags |= MGf_REFCOUNTED; + } + mg->mg_type = how; + mg->mg_len = namlen; + if (name) + if (namlen >= 0) + 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; + break; + case 'A': + mg->mg_virtual = &PL_vtbl_amagic; + break; + case 'a': + mg->mg_virtual = &PL_vtbl_amagicelem; + break; + case 'c': + mg->mg_virtual = 0; + break; + case 'B': + mg->mg_virtual = &PL_vtbl_bm; + break; + case 'D': + mg->mg_virtual = &PL_vtbl_regdata; + break; + case 'd': + mg->mg_virtual = &PL_vtbl_regdatum; + break; + case 'E': + mg->mg_virtual = &PL_vtbl_env; + break; + case 'f': + mg->mg_virtual = &PL_vtbl_fm; + break; + case 'e': + mg->mg_virtual = &PL_vtbl_envelem; + break; + case 'g': + mg->mg_virtual = &PL_vtbl_mglob; + break; + case 'I': + mg->mg_virtual = &PL_vtbl_isa; + break; + case 'i': + mg->mg_virtual = &PL_vtbl_isaelem; + break; + case 'k': + mg->mg_virtual = &PL_vtbl_nkeys; + break; + case 'L': + SvRMAGICAL_on(sv); + mg->mg_virtual = 0; + break; + case 'l': + mg->mg_virtual = &PL_vtbl_dbline; + break; +#ifdef USE_THREADS + case 'm': + mg->mg_virtual = &PL_vtbl_mutex; + break; +#endif /* USE_THREADS */ +#ifdef USE_LOCALE_COLLATE + case 'o': + mg->mg_virtual = &PL_vtbl_collxfrm; + break; +#endif /* USE_LOCALE_COLLATE */ + case 'P': + mg->mg_virtual = &PL_vtbl_pack; + break; + case 'p': + case 'q': + mg->mg_virtual = &PL_vtbl_packelem; + break; + case 'r': + mg->mg_virtual = &PL_vtbl_regexp; + break; + case 'S': + mg->mg_virtual = &PL_vtbl_sig; + break; + case 's': + mg->mg_virtual = &PL_vtbl_sigelem; + break; + case 't': + mg->mg_virtual = &PL_vtbl_taint; + mg->mg_len = 1; + break; + case 'U': + mg->mg_virtual = &PL_vtbl_uvar; + break; + case 'v': + mg->mg_virtual = &PL_vtbl_vec; + break; + case 'x': + mg->mg_virtual = &PL_vtbl_substr; + break; + case 'y': + mg->mg_virtual = &PL_vtbl_defelem; + break; + case '*': + mg->mg_virtual = &PL_vtbl_glob; + break; + case '#': + mg->mg_virtual = &PL_vtbl_arylen; + break; + 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 */ + /* etc holding private data from one are passed to another. */ + SvRMAGICAL_on(sv); + break; + default: + 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); +} + +int +Perl_sv_unmagic(pTHX_ SV *sv, int type) +{ + MAGIC* mg; + MAGIC** mgp; + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &SvMAGIC(sv); + for (mg = *mgp; mg; mg = *mgp) { + if (mg->mg_type == type) { + MGVTBL* vtbl = mg->mg_virtual; + *mgp = mg->mg_moremagic; + 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); + else if (mg->mg_len == HEf_SVKEY) + SvREFCNT_dec((SV*)mg->mg_ptr); + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); } else - (void)SvOK_off(dstr); + mgp = &mg->mg_moremagic; + } + if (!SvMAGIC(sv)) { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } - SvTAINT(dstr); -} -void -Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv(dstr,sstr); - SvSETMAGIC(dstr); + return 0; } -void -Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +SV * +Perl_sv_rvweaken(pTHX_ SV *sv) { - register char *dptr; - assert(len >= 0); /* STRLEN is probably unsigned, so this may - elicit a warning, but it won't hurt. */ - SV_CHECK_THINKFIRST(sv); - if (!ptr) { - (void)SvOK_off(sv); - return; + 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; } - (void)SvUPGRADE(sv, SVt_PV); - - SvGROW(sv, len + 1); - dptr = SvPVX(sv); - Move(ptr,dptr,len,char); - dptr[len] = '\0'; - SvCUR_set(sv, len); - (void)SvPOK_only(sv); /* validate pointer */ - SvTAINT(sv); + tsv = SvRV(sv); + sv_add_backref(tsv, sv); + SvWEAKREF_on(sv); + SvREFCNT_dec(tsv); + return sv; } -void -Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +STATIC void +S_sv_add_backref(pTHX_ SV *tsv, SV *sv) { - sv_setpvn(sv,ptr,len); - SvSETMAGIC(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); } -void -Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) +STATIC void +S_sv_del_backref(pTHX_ SV *sv) { - register STRLEN len; - - SV_CHECK_THINKFIRST(sv); - if (!ptr) { - (void)SvOK_off(sv); - return; + 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--; } - len = strlen(ptr); - (void)SvUPGRADE(sv, SVt_PV); - - SvGROW(sv, len + 1); - Move(ptr,SvPVX(sv),len+1,char); - SvCUR_set(sv, len); - (void)SvPOK_only(sv); /* validate pointer */ - SvTAINT(sv); } -void -Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) -{ - sv_setpv(sv,ptr); - SvSETMAGIC(sv); -} +/* +=for apidoc sv_insert -void -Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) -{ - SV_CHECK_THINKFIRST(sv); - (void)SvUPGRADE(sv, SVt_PV); - if (!ptr) { - (void)SvOK_off(sv); - return; - } - (void)SvOOK_off(sv); - if (SvPVX(sv) && SvLEN(sv)) - Safefree(SvPVX(sv)); - Renew(ptr, len+1, char); - SvPVX(sv) = ptr; - SvCUR_set(sv, len); - SvLEN_set(sv, len+1); - *SvEND(sv) = '\0'; - (void)SvPOK_only(sv); /* validate pointer */ - SvTAINT(sv); -} +Inserts a string at the specified offset/length within the SV. Similar to +the Perl substr() function. -void -Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) -{ - sv_usepvn(sv,ptr,len); - SvSETMAGIC(sv); -} +=cut +*/ void -Perl_sv_force_normal(pTHX_ register SV *sv) +Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) { - if (SvREADONLY(sv)) { - dTHR; - if (PL_curcop != &PL_compiling) - Perl_croak(aTHX_ PL_no_modify); - } - if (SvROK(sv)) - sv_unref(sv); - else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) - sv_unglob(sv); -} + register char *big; + register char *mid; + register char *midend; + register char *bigend; + register I32 i; + STRLEN curlen; -void -Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ - - -{ - register STRLEN delta; - if (!ptr || !SvPOKp(sv)) + if (!bigstr) + Perl_croak(aTHX_ "Can't modify non-existent substring"); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } + + SvTAINT(bigstr); + i = littlelen - len; + if (i > 0) { /* string might grow */ + big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); + mid = big + offset + len; + midend = bigend = big + SvCUR(bigstr); + bigend += i; + *bigend = '\0'; + while (midend > mid) /* shove everything down */ + *--bigend = *--midend; + Move(little,big+offset,littlelen,char); + SvCUR(bigstr) += i; + SvSETMAGIC(bigstr); return; - SV_CHECK_THINKFIRST(sv); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv,SVt_PVIV); + } + else if (i == 0) { + Move(little,SvPVX(bigstr)+offset,len,char); + SvSETMAGIC(bigstr); + return; + } - 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'; + big = SvPVX(bigstr); + mid = big + offset; + midend = mid + len; + bigend = big + SvCUR(bigstr); + + if (midend > bigend) + Perl_croak(aTHX_ "panic: sv_insert"); + + if (mid - big > bigend - midend) { /* faster to shorten from end */ + if (littlelen) { + Move(little, mid, littlelen,char); + mid += littlelen; } - SvIVX(sv) = 0; - SvFLAGS(sv) |= SVf_OOK; + i = bigend - midend; + if (i > 0) { + Move(midend, mid, i,char); + mid += i; + } + *mid = '\0'; + SvCUR_set(bigstr, mid - big); + } + /*SUPPRESS 560*/ + else if (i = mid - big) { /* faster from front */ + midend -= littlelen; + mid = midend; + sv_chop(bigstr,midend-i); + big += i; + while (i--) + *--midend = *--big; + if (littlelen) + Move(little, mid, littlelen,char); + } + else if (littlelen) { + midend -= littlelen; + sv_chop(bigstr,midend); + Move(little,midend,littlelen,char); + } + else { + sv_chop(bigstr,midend); } - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); - delta = ptr - SvPVX(sv); - SvLEN(sv) -= delta; - SvCUR(sv) -= delta; - SvPVX(sv) += delta; - SvIVX(sv) += delta; -} - -void -Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) -{ - STRLEN tlen; - char *junk; - - junk = SvPV_force(sv, tlen); - SvGROW(sv, tlen + len + 1); - if (ptr == junk) - ptr = SvPVX(sv); - Move(ptr,SvPVX(sv)+tlen,len,char); - SvCUR(sv) += len; - *SvEND(sv) = '\0'; - (void)SvPOK_only(sv); /* validate pointer */ - SvTAINT(sv); -} - -void -Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) -{ - sv_catpvn(sv,ptr,len); - SvSETMAGIC(sv); + SvSETMAGIC(bigstr); } -void -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); -} +/* make sv point to what nstr did */ void -Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) +Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { - sv_catsv(dstr,sstr); - SvSETMAGIC(dstr); + dTHR; + U32 refcnt = SvREFCNT(sv); + SV_CHECK_THINKFIRST(sv); + if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); + if (SvMAGICAL(sv)) { + if (SvMAGICAL(nsv)) + mg_free(nsv); + else + sv_upgrade(nsv, SVt_PVMG); + SvMAGIC(nsv) = SvMAGIC(sv); + SvFLAGS(nsv) |= SvMAGICAL(sv); + SvMAGICAL_off(sv); + SvMAGIC(sv) = 0; + } + SvREFCNT(sv) = 0; + sv_clear(sv); + assert(!SvREFCNT(sv)); + StructCopy(nsv,sv,SV); + SvREFCNT(sv) = refcnt; + SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ + del_SV(nsv); } void -Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_clear(pTHX_ register SV *sv) { - register STRLEN len; - STRLEN tlen; - char *junk; + HV* stash; + assert(sv); + assert(SvREFCNT(sv) == 0); - if (!ptr) - return; - junk = SvPV_force(sv, tlen); - len = strlen(ptr); - SvGROW(sv, tlen + len + 1); - if (ptr == junk) - ptr = SvPVX(sv); - Move(ptr,SvPVX(sv)+tlen,len+1,char); - SvCUR(sv) += len; - (void)SvPOK_only(sv); /* validate pointer */ - SvTAINT(sv); -} + if (SvOBJECT(sv)) { + dTHR; + if (PL_defstash) { /* Still have a symbol table? */ + djSP; + GV* destructor; + SV tmpref; -void -Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) -{ - sv_catpv(sv,ptr); - SvSETMAGIC(sv); -} + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; -SV * -Perl_newSV(pTHX_ STRLEN len) -{ - register SV *sv; - - new_SV(sv); - if (len) { - sv_upgrade(sv, SVt_PV); - SvGROW(sv, len + 1); - } - return sv; -} + do { + stash = SvSTASH(sv); + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + SvRV(&tmpref) = SvREFCNT_inc(sv); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(&tmpref); + PUTBACK; + call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); + SvREFCNT(sv)--; + POPSTACK; + SPAGAIN; + LEAVE; + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); -/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ + del_XRV(SvANY(&tmpref)); -void -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)) - Perl_croak(aTHX_ PL_no_modify); - } - if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { - if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - if (how == 't') - mg->mg_len |= 1; - return; + if (SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", + HvNAME(stash)); + /* DESTROY gave object new lease on life */ + return; + } } - } - else { - (void)SvUPGRADE(sv, SVt_PVMG); - } - Newz(702,mg, 1, MAGIC); - mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#' || how == 'r') - mg->mg_obj = obj; - else { - dTHR; - mg->mg_obj = SvREFCNT_inc(obj); - mg->mg_flags |= MGf_REFCOUNTED; + if (SvOBJECT(sv)) { + SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ + SvOBJECT_off(sv); /* Curse the object. */ + if (SvTYPE(sv) != SVt_PVIO) + --PL_sv_objcount; /* XXX Might want something more general */ + } } - mg->mg_type = how; - mg->mg_len = namlen; - if (name) - if (namlen >= 0) - 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; - break; - case 'A': - mg->mg_virtual = &PL_vtbl_amagic; - break; - case 'a': - mg->mg_virtual = &PL_vtbl_amagicelem; - break; - case 'c': - mg->mg_virtual = 0; - break; - case 'B': - mg->mg_virtual = &PL_vtbl_bm; - break; - case 'D': - mg->mg_virtual = &PL_vtbl_regdata; - break; - case 'd': - mg->mg_virtual = &PL_vtbl_regdatum; - break; - case 'E': - mg->mg_virtual = &PL_vtbl_env; - break; - case 'f': - mg->mg_virtual = &PL_vtbl_fm; - break; - case 'e': - mg->mg_virtual = &PL_vtbl_envelem; - break; - case 'g': - mg->mg_virtual = &PL_vtbl_mglob; - break; - case 'I': - mg->mg_virtual = &PL_vtbl_isa; - break; - case 'i': - mg->mg_virtual = &PL_vtbl_isaelem; - break; - case 'k': - mg->mg_virtual = &PL_vtbl_nkeys; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) + mg_free(sv); + stash = NULL; + switch (SvTYPE(sv)) { + case SVt_PVIO: + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && + IoIFP(sv) != PerlIO_stdout() && + IoIFP(sv) != PerlIO_stderr()) + { + io_close((IO*)sv, FALSE); + } + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = (DIR*)NULL; + Safefree(IoTOP_NAME(sv)); + Safefree(IoFMT_NAME(sv)); + Safefree(IoBOTTOM_NAME(sv)); + /* FALL THROUGH */ + case SVt_PVBM: + goto freescalar; + case SVt_PVCV: + case SVt_PVFM: + cv_undef((CV*)sv); + goto freescalar; + case SVt_PVHV: + hv_undef((HV*)sv); break; - case 'L': - SvRMAGICAL_on(sv); - mg->mg_virtual = 0; + case SVt_PVAV: + av_undef((AV*)sv); break; - case 'l': - mg->mg_virtual = &PL_vtbl_dbline; + case SVt_PVLV: + SvREFCNT_dec(LvTARG(sv)); + goto freescalar; + case SVt_PVGV: + gp_free((GV*)sv); + Safefree(GvNAME(sv)); + /* cannot decrease stash refcount yet, as we might recursively delete + ourselves when the refcnt drops to zero. Delay SvREFCNT_dec + of stash until current sv is completely gone. + -- JohnPC, 27 Mar 1998 */ + stash = GvSTASH(sv); + /* FALL THROUGH */ + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: + freescalar: + (void)SvOOK_off(sv); + /* FALL THROUGH */ + case SVt_PV: + case SVt_RV: + if (SvROK(sv)) { + if (SvWEAKREF(sv)) + sv_del_backref(sv); + else + SvREFCNT_dec(SvRV(sv)); + } + else if (SvPVX(sv) && SvLEN(sv)) + Safefree(SvPVX(sv)); break; -#ifdef USE_THREADS - case 'm': - mg->mg_virtual = &PL_vtbl_mutex; +/* + case SVt_NV: + case SVt_IV: + case SVt_NULL: break; -#endif /* USE_THREADS */ -#ifdef USE_LOCALE_COLLATE - case 'o': - mg->mg_virtual = &PL_vtbl_collxfrm; - break; -#endif /* USE_LOCALE_COLLATE */ - case 'P': - mg->mg_virtual = &PL_vtbl_pack; +*/ + } + + switch (SvTYPE(sv)) { + case SVt_NULL: break; - case 'p': - case 'q': - mg->mg_virtual = &PL_vtbl_packelem; + case SVt_IV: + del_XIV(SvANY(sv)); break; - case 'r': - mg->mg_virtual = &PL_vtbl_regexp; + case SVt_NV: + del_XNV(SvANY(sv)); break; - case 'S': - mg->mg_virtual = &PL_vtbl_sig; + case SVt_RV: + del_XRV(SvANY(sv)); break; - case 's': - mg->mg_virtual = &PL_vtbl_sigelem; + case SVt_PV: + del_XPV(SvANY(sv)); break; - case 't': - mg->mg_virtual = &PL_vtbl_taint; - mg->mg_len = 1; + case SVt_PVIV: + del_XPVIV(SvANY(sv)); break; - case 'U': - mg->mg_virtual = &PL_vtbl_uvar; + case SVt_PVNV: + del_XPVNV(SvANY(sv)); break; - case 'v': - mg->mg_virtual = &PL_vtbl_vec; + case SVt_PVMG: + del_XPVMG(SvANY(sv)); break; - case 'x': - mg->mg_virtual = &PL_vtbl_substr; + case SVt_PVLV: + del_XPVLV(SvANY(sv)); break; - case 'y': - mg->mg_virtual = &PL_vtbl_defelem; + case SVt_PVAV: + del_XPVAV(SvANY(sv)); break; - case '*': - mg->mg_virtual = &PL_vtbl_glob; + case SVt_PVHV: + del_XPVHV(SvANY(sv)); break; - case '#': - mg->mg_virtual = &PL_vtbl_arylen; + case SVt_PVCV: + del_XPVCV(SvANY(sv)); break; - case '.': - mg->mg_virtual = &PL_vtbl_pos; + case SVt_PVGV: + del_XPVGV(SvANY(sv)); + /* code duplication for increased performance. */ + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + /* decrease refcount of the stash that owns this GV, if any */ + if (stash) + SvREFCNT_dec(stash); + return; /* not break, SvFLAGS reset already happened */ + case SVt_PVBM: + del_XPVBM(SvANY(sv)); break; - case '<': - mg->mg_virtual = &PL_vtbl_backref; + case SVt_PVFM: + del_XPVFM(SvANY(sv)); 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 */ - /* etc holding private data from one are passed to another. */ - SvRMAGICAL_on(sv); + case SVt_PVIO: + del_XPVIO(SvANY(sv)); break; - default: - Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how); } - mg_magical(sv); + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; +} + +SV * +Perl_sv_newref(pTHX_ SV *sv) +{ + if (sv) + ATOMIC_INC(SvREFCNT(sv)); + return sv; +} + +void +Perl_sv_free(pTHX_ SV *sv) +{ + dTHR; + int refcount_is_zero; + + if (!sv) + return; + if (SvREFCNT(sv) == 0) { + if (SvFLAGS(sv) & SVf_BREAK) + return; + if (PL_in_clean_all) /* All is fair */ + return; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } + 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)); + if (!refcount_is_zero) + return; +#ifdef DEBUGGING + if (SvTEMP(sv)) { + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%"UVxf, + PTR2UV(sv)); + return; + } +#endif + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } + sv_clear(sv); + if (! SvREFCNT(sv)) + del_SV(sv); +} + +/* +=for apidoc sv_len + +Returns the length of the string in the SV. See also C. + +=cut +*/ + +STRLEN +Perl_sv_len(pTHX_ register SV *sv) +{ + char *junk; + STRLEN len; + + if (!sv) + return 0; + if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + len = mg_length(sv); + else + junk = SvPV(sv, len); + return len; } -int -Perl_sv_unmagic(pTHX_ SV *sv, int type) +STRLEN +Perl_sv_len_utf8(pTHX_ register SV *sv) +{ + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return 0; + +#ifdef NOTYET + if (SvGMAGICAL(sv)) + len = mg_length(sv); + else +#endif + s = (U8*)SvPV(sv, len); + send = s + len; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + len++; + } + return len; +} + +void +Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) +{ + U8 *start; + U8 *s; + U8 *send; + I32 uoffset = *offsetp; + STRLEN len; + + if (!sv) + return; + + start = s = (U8*)SvPV(sv, len); + send = s + len; + while (s < send && uoffset--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + *offsetp = s - start; + if (lenp) { + I32 ulen = *lenp; + start = s; + while (s < send && ulen--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + *lenp = s - start; + } + return; +} + +void +Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) { - MAGIC* mg; - MAGIC** mgp; - if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) - return 0; - mgp = &SvMAGIC(sv); - for (mg = *mgp; mg; mg = *mgp) { - if (mg->mg_type == type) { - MGVTBL* vtbl = mg->mg_virtual; - *mgp = mg->mg_moremagic; - if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != 'g') - if (mg->mg_len >= 0) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec((SV*)mg->mg_ptr); - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); - } - else - mgp = &mg->mg_moremagic; + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return; + + s = (U8*)SvPV(sv, len); + if (len < *offsetp) + Perl_croak(aTHX_ "panic: bad byte offset"); + send = s + *offsetp; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + ++len; } - if (!SvMAGIC(sv)) { - SvMAGICAL_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + if (s != send) { + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); + --len; } - - return 0; + *offsetp = len; + return; } -SV * -Perl_sv_rvweaken(pTHX_ SV *sv) +/* +=for apidoc sv_eq + +Returns a boolean indicating whether the strings in the two SVs are +identical. + +=cut +*/ + +I32 +Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) { - 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; + char *pv1; + STRLEN cur1; + char *pv2; + STRLEN cur2; + + if (!str1) { + pv1 = ""; + cur1 = 0; } - tsv = SvRV(sv); - sv_add_backref(tsv, sv); - SvWEAKREF_on(sv); - SvREFCNT_dec(tsv); - return sv; + else + pv1 = SvPV(str1, cur1); + + if (!str2) + return !cur1; + else + pv2 = SvPV(str2, cur2); + + if (cur1 != cur2) + return 0; + + return memEQ(pv1, pv2, cur1); } -STATIC void -S_sv_add_backref(pTHX_ SV *tsv, SV *sv) +/* +=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 +Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) { - AV *av; - MAGIC *mg; - if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<'))) - av = (AV*)mg->mg_obj; + STRLEN cur1, cur2; + char *pv1, *pv2; + I32 retval; + bool utf1; + + if (str1) { + pv1 = SvPV(str1, cur1); + } else { - av = newAV(); - sv_magic(tsv, (SV*)av, '<', NULL, 0); - SvREFCNT_dec(av); /* for sv_magic */ + cur1 = 0; } - 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 */ + if (str2) { + if (SvPOK(str2)) { + if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) { + /* must upgrade other to UTF8 first */ + if (SvUTF8(str1)) { + sv_utf8_upgrade(str2); + } + else { + sv_utf8_upgrade(str1); + /* refresh pointer and length */ + pv1 = SvPVX(str1); + cur1 = SvCUR(str1); + } + } + pv2 = SvPVX(str2); + cur2 = SvCUR(str2); + } + else { + pv2 = sv_2pv(str2, &cur2); } - i--; } + else { + cur2 = 0; + } + + if (!cur1) + return cur2 ? -1 : 0; + + if (!cur2) + return 1; + + retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + if (retval) + return retval < 0 ? -1 : 1; + + if (cur1 == cur2) + return 0; + else + return cur1 < cur2 ? -1 : 1; } -void -Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) +I32 +Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) { - register char *big; - register char *mid; - register char *midend; - register char *bigend; - register I32 i; - STRLEN curlen; - +#ifdef USE_LOCALE_COLLATE - if (!bigstr) - Perl_croak(aTHX_ "Can't modify non-existent substring"); - SvPV_force(bigstr, curlen); - if (offset + len > curlen) { - SvGROW(bigstr, offset+len+1); - Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); - SvCUR_set(bigstr, offset+len); - } + char *pv1, *pv2; + STRLEN len1, len2; + I32 retval; - i = littlelen - len; - if (i > 0) { /* string might grow */ - big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); - mid = big + offset + len; - midend = bigend = big + SvCUR(bigstr); - bigend += i; - *bigend = '\0'; - while (midend > mid) /* shove everything down */ - *--bigend = *--midend; - Move(little,big+offset,littlelen,char); - SvCUR(bigstr) += i; - SvSETMAGIC(bigstr); - return; + if (PL_collation_standard) + goto raw_compare; + + len1 = 0; + pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL; + len2 = 0; + pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL; + + if (!pv1 || !len1) { + if (pv2 && len2) + return -1; + else + goto raw_compare; } - else if (i == 0) { - Move(little,SvPVX(bigstr)+offset,len,char); - SvSETMAGIC(bigstr); - return; + else { + if (!pv2 || !len2) + return 1; } - big = SvPVX(bigstr); - mid = big + offset; - midend = mid + len; - bigend = big + SvCUR(bigstr); + retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); - if (midend > bigend) - Perl_croak(aTHX_ "panic: sv_insert"); + if (retval) + return retval < 0 ? -1 : 1; - if (mid - big > bigend - midend) { /* faster to shorten from end */ - if (littlelen) { - Move(little, mid, littlelen,char); - mid += littlelen; + /* + * When the result of collation is equality, that doesn't mean + * that there are no differences -- some locales exclude some + * characters from consideration. So to avoid false equalities, + * we use the raw string as a tiebreaker. + */ + + raw_compare: + /* FALL THROUGH */ + +#endif /* USE_LOCALE_COLLATE */ + + return sv_cmp(sv1, sv2); +} + +#ifdef USE_LOCALE_COLLATE +/* + * Any scalar variable may carry an 'o' magic that contains the + * scalar data of the variable transformed to such a format that + * a normal memory comparison can be used to compare the data + * according to the locale settings. + */ +char * +Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) +{ + MAGIC *mg; + + mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; + if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { + char *s, *xf; + STRLEN len, xlen; + + if (mg) + Safefree(mg->mg_ptr); + s = SvPV(sv, len); + if ((xf = mem_collxfrm(s, len, &xlen))) { + if (SvREADONLY(sv)) { + SAVEFREEPV(xf); + *nxp = xlen; + return xf + sizeof(PL_collation_ix); + } + if (! mg) { + sv_magic(sv, 0, 'o', 0, 0); + mg = mg_find(sv, 'o'); + assert(mg); + } + mg->mg_ptr = xf; + mg->mg_len = xlen; } - i = bigend - midend; - if (i > 0) { - Move(midend, mid, i,char); - mid += i; + else { + if (mg) { + mg->mg_ptr = NULL; + mg->mg_len = -1; + } } - *mid = '\0'; - SvCUR_set(bigstr, mid - big); - } - /*SUPPRESS 560*/ - else if (i = mid - big) { /* faster from front */ - midend -= littlelen; - mid = midend; - sv_chop(bigstr,midend-i); - big += i; - while (i--) - *--midend = *--big; - if (littlelen) - Move(little, mid, littlelen,char); } - else if (littlelen) { - midend -= littlelen; - sv_chop(bigstr,midend); - Move(little,midend,littlelen,char); + if (mg && mg->mg_ptr) { + *nxp = mg->mg_len; + return mg->mg_ptr + sizeof(PL_collation_ix); } else { - sv_chop(bigstr,midend); + *nxp = 0; + return NULL; } - SvSETMAGIC(bigstr); } -/* make sv point to what nstr did */ +#endif /* USE_LOCALE_COLLATE */ -void -Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) +char * +Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { dTHR; - U32 refcnt = SvREFCNT(sv); + char *rsptr; + STRLEN rslen; + register STDCHAR rslast; + register STDCHAR *bp; + register I32 cnt; + I32 i; + SV_CHECK_THINKFIRST(sv); - if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); - if (SvMAGICAL(sv)) { - if (SvMAGICAL(nsv)) - mg_free(nsv); - else - sv_upgrade(nsv, SVt_PVMG); - SvMAGIC(nsv) = SvMAGIC(sv); - SvFLAGS(nsv) |= SvMAGICAL(sv); - SvMAGICAL_off(sv); - SvMAGIC(sv) = 0; + (void)SvUPGRADE(sv, SVt_PV); + + SvSCREAM_off(sv); + + if (RsSNARF(PL_rs)) { + rsptr = NULL; + rslen = 0; } - SvREFCNT(sv) = 0; - sv_clear(sv); - assert(!SvREFCNT(sv)); - StructCopy(nsv,sv,SV); - SvREFCNT(sv) = refcnt; - SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ - del_SV(nsv); -} + else if (RsRECORD(PL_rs)) { + I32 recsize, bytesread; + char *buffer; -void -Perl_sv_clear(pTHX_ register SV *sv) -{ - HV* stash; - assert(sv); - assert(SvREFCNT(sv) == 0); + /* Grab the size of the record we're getting */ + recsize = SvIV(SvRV(PL_rs)); + (void)SvPOK_only(sv); /* Validate pointer */ + buffer = SvGROW(sv, recsize + 1); + /* Go yank in */ +#ifdef VMS + /* VMS wants read instead of fread, because fread doesn't respect */ + /* RMS record boundaries. This is not necessarily a good thing to be */ + /* doing, but we've got no other real choice */ + bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); +#else + bytesread = PerlIO_read(fp, buffer, recsize); +#endif + SvCUR_set(sv, bytesread); + buffer[bytesread] = '\0'; + return(SvCUR(sv) ? SvPVX(sv) : Nullch); + } + else if (RsPARA(PL_rs)) { + rsptr = "\n\n"; + rslen = 2; + } + else + rsptr = SvPV(PL_rs, rslen); + rslast = rslen ? rsptr[rslen - 1] : '\0'; - if (SvOBJECT(sv)) { - dTHR; - if (PL_defstash) { /* Still have a symbol table? */ - djSP; - GV* destructor; - SV tmpref; + if (RsPARA(PL_rs)) { /* have to do this both before and after */ + do { /* to make sure file boundaries work right */ + if (PerlIO_eof(fp)) + return 0; + i = PerlIO_getc(fp); + if (i != '\n') { + if (i == -1) + return 0; + PerlIO_ungetc(fp,i); + break; + } + } while (i != EOF); + } - Zero(&tmpref, 1, SV); - sv_upgrade(&tmpref, SVt_RV); - SvROK_on(&tmpref); - SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ - SvREFCNT(&tmpref) = 1; + /* See if we know enough about I/O mechanism to cheat it ! */ - do { - stash = SvSTASH(sv); - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); - if (destructor) { - ENTER; - PUSHSTACKi(PERLSI_DESTROY); - SvRV(&tmpref) = SvREFCNT_inc(sv); - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(&tmpref); - PUTBACK; - call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); - SvREFCNT(sv)--; - POPSTACK; - SPAGAIN; - LEAVE; + /* This used to be #ifdef test - it is made run-time test for ease + of abstracting out stdio interface. One call should be cheap + enough here - and may even be a macro allowing compile + time optimization. + */ + + if (PerlIO_fast_gets(fp)) { + + /* + * We're going to steal some values from the stdio struct + * and put EVERYTHING in the innermost loop into registers. + */ + register STDCHAR *ptr; + STRLEN bpx; + I32 shortbuffered; + +#if defined(VMS) && defined(PERLIO_IS_STDIO) + /* An ungetc()d char is handled separately from the regular + * buffer, so we getc() it back out and stuff it in the buffer. + */ + i = PerlIO_getc(fp); + if (i == EOF) return 0; + *(--((*fp)->_ptr)) = (unsigned char) i; + (*fp)->_cnt++; +#endif + + /* Here is some breathtakingly efficient cheating */ + + cnt = PerlIO_get_cnt(fp); /* get count into register */ + (void)SvPOK_only(sv); /* validate pointer */ + if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ + if (cnt > 80 && SvLEN(sv) > append) { + shortbuffered = cnt - SvLEN(sv) + append + 1; + cnt -= shortbuffered; + } + else { + shortbuffered = 0; + /* remember that cnt can be negative */ + SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1))); + } + } + else + shortbuffered = 0; + 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=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "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) { + if (rslen) { + while (cnt > 0) { /* this | eat */ + cnt--; + if ((*bp++ = *ptr++) == rslast) /* really | dust */ + goto thats_all_folks; /* screams | sed :-) */ } - } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + } + else { + Copy(ptr, bp, cnt, char); /* this | eat */ + bp += cnt; /* screams | dust */ + ptr += cnt; /* louder | sed :-) */ + cnt = 0; + } + } + + if (shortbuffered) { /* oh well, must extend */ + cnt = shortbuffered; + shortbuffered = 0; + bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); + SvGROW(sv, SvLEN(sv) + append + cnt + 2); + bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ + continue; + } + + DEBUG_P(PerlIO_printf(Perl_debug_log, + "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=%"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=%"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=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + + if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; + + bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); + SvGROW(sv, bpx + cnt + 2); + bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ - del_XRV(SvANY(&tmpref)); + *bp++ = i; /* store character from PerlIO_getc */ - if (SvREFCNT(sv)) { - if (PL_in_clean_objs) - Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", - HvNAME(stash)); - /* DESTROY gave object new lease on life */ - return; - } - } + if (rslen && (STDCHAR)i == rslast) /* all done for now? */ + goto thats_all_folks; + } - if (SvOBJECT(sv)) { - SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ - SvOBJECT_off(sv); /* Curse the object. */ - if (SvTYPE(sv) != SVt_PVIO) - --PL_sv_objcount; /* XXX Might want something more general */ - } +thats_all_folks: + if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || + memNE((char*)bp - rslen, rsptr, rslen)) + goto screamer; /* go back to the fray */ +thats_really_all_folks: + if (shortbuffered) + cnt += shortbuffered; + DEBUG_P(PerlIO_printf(Perl_debug_log, + "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=%"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, + "Screamer: done, len=%ld, string=|%.*s|\n", + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) - mg_free(sv); - stash = NULL; - switch (SvTYPE(sv)) { - case SVt_PVIO: - if (IoIFP(sv) && - IoIFP(sv) != PerlIO_stdin() && - IoIFP(sv) != PerlIO_stdout() && - IoIFP(sv) != PerlIO_stderr()) - { - io_close((IO*)sv, FALSE); + 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) { + register STDCHAR *bpe = buf + sizeof(buf); + bp = buf; + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) + ; /* keep reading */ + cnt = bp - buf; } - if (IoDIRP(sv)) { - PerlDir_close(IoDIRP(sv)); - IoDIRP(sv) = 0; + else { + cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); + /* Accomodate broken VAXC compiler, which applies U8 cast to + * both args of ?: operator, causing EOF to change into 255 + */ + if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } } - Safefree(IoTOP_NAME(sv)); - Safefree(IoFMT_NAME(sv)); - Safefree(IoBOTTOM_NAME(sv)); - /* FALL THROUGH */ - case SVt_PVBM: - goto freescalar; - case SVt_PVCV: - case SVt_PVFM: - cv_undef((CV*)sv); - goto freescalar; - case SVt_PVHV: - hv_undef((HV*)sv); - break; - case SVt_PVAV: - av_undef((AV*)sv); - break; - case SVt_PVLV: - SvREFCNT_dec(LvTARG(sv)); - goto freescalar; - case SVt_PVGV: - gp_free((GV*)sv); - Safefree(GvNAME(sv)); - /* cannot decrease stash refcount yet, as we might recursively delete - ourselves when the refcnt drops to zero. Delay SvREFCNT_dec - of stash until current sv is completely gone. - -- JohnPC, 27 Mar 1998 */ - stash = GvSTASH(sv); - /* FALL THROUGH */ - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: - freescalar: - (void)SvOOK_off(sv); - /* FALL THROUGH */ - case SVt_PV: - case SVt_RV: - if (SvROK(sv)) { - if (SvWEAKREF(sv)) - sv_del_backref(sv); - else - SvREFCNT_dec(SvRV(sv)); + + if (append) + sv_catpvn(sv, (char *) buf, cnt); + else + sv_setpvn(sv, (char *) buf, cnt); + + if (i != EOF && /* joy */ + (!rslen || + SvCUR(sv) < rslen || + memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + { + append = -1; + /* + * If we're reading from a TTY and we get a short read, + * indicating that the user hit his EOF character, we need + * to notice it now, because if we try to read from the TTY + * again, the EOF condition will disappear. + * + * The comparison of cnt to sizeof(buf) is an optimization + * that prevents unnecessary calls to feof(). + * + * - jik 9/25/96 + */ + if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) + goto screamer2; } - else if (SvPVX(sv) && SvLEN(sv)) - Safefree(SvPVX(sv)); - break; -/* - case SVt_NV: - case SVt_IV: - case SVt_NULL: - break; -*/ } - switch (SvTYPE(sv)) { - case SVt_NULL: - break; - case SVt_IV: - del_XIV(SvANY(sv)); - break; - case SVt_NV: - del_XNV(SvANY(sv)); - break; - case SVt_RV: - del_XRV(SvANY(sv)); - break; - case SVt_PV: - del_XPV(SvANY(sv)); - break; - case SVt_PVIV: - del_XPVIV(SvANY(sv)); - break; - case SVt_PVNV: - del_XPVNV(SvANY(sv)); - break; - case SVt_PVMG: - del_XPVMG(SvANY(sv)); - break; - case SVt_PVLV: - del_XPVLV(SvANY(sv)); - break; - case SVt_PVAV: - del_XPVAV(SvANY(sv)); - break; - case SVt_PVHV: - del_XPVHV(SvANY(sv)); - break; - case SVt_PVCV: - del_XPVCV(SvANY(sv)); - break; - case SVt_PVGV: - del_XPVGV(SvANY(sv)); - /* code duplication for increased performance. */ - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - /* decrease refcount of the stash that owns this GV, if any */ - if (stash) - SvREFCNT_dec(stash); - return; /* not break, SvFLAGS reset already happened */ - case SVt_PVBM: - del_XPVBM(SvANY(sv)); - break; - case SVt_PVFM: - del_XPVFM(SvANY(sv)); - break; - case SVt_PVIO: - del_XPVIO(SvANY(sv)); - break; + 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') { + PerlIO_ungetc(fp,i); + break; + } + } } - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; -} -SV * -Perl_sv_newref(pTHX_ SV *sv) -{ - if (sv) - ATOMIC_INC(SvREFCNT(sv)); - return sv; + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } + +/* +=for apidoc sv_inc + +Auto-increment of the value in the SV. + +=cut +*/ + void -Perl_sv_free(pTHX_ SV *sv) +Perl_sv_inc(pTHX_ register SV *sv) { - dTHR; - int refcount_is_zero; + register char *d; + int flags; if (!sv) return; - if (SvREFCNT(sv) == 0) { - if (SvFLAGS(sv) & SVf_BREAK) - return; - if (PL_in_clean_all) /* All is fair */ - return; - if (SvREADONLY(sv) && SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = (~(U32)0)/2; - return; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + Perl_croak(aTHX_ PL_no_modify); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); } - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); + } + flags = SvFLAGS(sv); + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); + SvNVX(sv) += 1.0; return; } - ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); - if (!refcount_is_zero) + if (flags & SVp_IOK) { + 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; -#ifdef DEBUGGING - if (SvTEMP(sv)) { - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ WARN_DEBUGGING, - "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + } + if (!(flags & SVp_POK) || !*SvPVX(sv)) { + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); + SvNVX(sv) = 1.0; + (void)SvNOK_only(sv); return; } -#endif - if (SvREADONLY(sv) && SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = (~(U32)0)/2; + d = SvPVX(sv); + while (isALPHA(*d)) d++; + while (isDIGIT(*d)) d++; + if (*d) { + sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */ return; } - sv_clear(sv); - if (! SvREFCNT(sv)) - del_SV(sv); -} - -STRLEN -Perl_sv_len(pTHX_ register SV *sv) -{ - char *junk; - STRLEN len; - - if (!sv) - return 0; - - if (SvGMAGICAL(sv)) - len = mg_length(sv); + d--; + while (d >= SvPVX(sv)) { + if (isDIGIT(*d)) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + else { +#ifdef EBCDIC + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (*d != 'z' && *d != 'Z') { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; +#else + ++*d; + if (isALPHA(*d)) + return; + *(d--) -= 'z' - 'a' + 1; +#endif + } + } + /* oh,oh, the number grew */ + SvGROW(sv, SvCUR(sv) + 2); + SvCUR(sv)++; + for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--) + *d = d[-1]; + if (isDIGIT(d[1])) + *d = '1'; else - junk = SvPV(sv, len); - return len; + *d = d[1]; } -STRLEN -Perl_sv_len_utf8(pTHX_ register SV *sv) -{ - U8 *s; - U8 *send; - STRLEN len; +/* +=for apidoc sv_dec - if (!sv) - return 0; +Auto-decrement of the value in the SV. -#ifdef NOTYET - if (SvGMAGICAL(sv)) - len = mg_length(sv); - else -#endif - s = (U8*)SvPV(sv, len); - send = s + len; - len = 0; - while (s < send) { - s += UTF8SKIP(s); - len++; - } - return len; -} +=cut +*/ void -Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) +Perl_sv_dec(pTHX_ register SV *sv) { - U8 *start; - U8 *s; - U8 *send; - I32 uoffset = *offsetp; - STRLEN len; + int flags; if (!sv) return; - - start = s = (U8*)SvPV(sv, len); - send = s + len; - while (s < send && uoffset--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *offsetp = s - start; - if (lenp) { - I32 ulen = *lenp; - start = s; - while (s < send && ulen--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *lenp = s - start; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + Perl_croak(aTHX_ PL_no_modify); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); + } } - return; -} - -void -Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) -{ - U8 *s; - U8 *send; - STRLEN len; - - if (!sv) + flags = SvFLAGS(sv); + if (flags & SVp_NOK) { + SvNVX(sv) -= 1.0; + (void)SvNOK_only(sv); return; - - s = (U8*)SvPV(sv, len); - if (len < *offsetp) - Perl_croak(aTHX_ "panic: bad byte offset"); - send = s + *offsetp; - len = 0; - while (s < send) { - s += UTF8SKIP(s); - ++len; } - if (s != send) { - dTHR; - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); - --len; + if (flags & SVp_IOK) { + 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; } - *offsetp = len; - return; + if (!(flags & SVp_POK)) { + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); + SvNVX(sv) = -1.0; + (void)SvNOK_only(sv); + return; + } + sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ } -I32 -Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) +/* +=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 * +Perl_sv_mortalcopy(pTHX_ SV *oldstr) { - char *pv1; - STRLEN cur1; - char *pv2; - STRLEN cur2; + dTHR; + register SV *sv; - if (!str1) { - pv1 = ""; - cur1 = 0; - } - else - pv1 = SvPV(str1, cur1); + new_SV(sv); + sv_setsv(sv,oldstr); + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; + SvTEMP_on(sv); + return sv; +} - if (!str2) - return !cur1; - else - pv2 = SvPV(str2, cur2); +/* +=for apidoc sv_newmortal - if (cur1 != cur2) - return 0; +Creates a new SV which is mortal. The reference count of the SV is set to 1. - return memEQ(pv1, pv2, cur1); -} +=cut +*/ -I32 -Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) +SV * +Perl_sv_newmortal(pTHX) { - STRLEN cur1 = 0; - char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL; - STRLEN cur2 = 0; - char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL; - I32 retval; + dTHR; + register SV *sv; - if (!cur1) - return cur2 ? -1 : 0; + new_SV(sv); + SvFLAGS(sv) = SVs_TEMP; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; + return sv; +} - if (!cur2) - return 1; +/* +=for apidoc sv_2mortal - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); +Marks an SV as mortal. The SV will be destroyed when the current context +ends. - if (retval) - return retval < 0 ? -1 : 1; +=cut +*/ - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; -} +/* same thing without the copying */ -I32 -Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) +SV * +Perl_sv_2mortal(pTHX_ register SV *sv) { -#ifdef USE_LOCALE_COLLATE + dTHR; + if (!sv) + return sv; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) + return sv; + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = sv; + SvTEMP_on(sv); + return sv; +} - char *pv1, *pv2; - STRLEN len1, len2; - I32 retval; +/* +=for apidoc newSVpv - if (PL_collation_standard) - goto raw_compare; +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. - len1 = 0; - pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL; - len2 = 0; - pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL; +=cut +*/ - if (!pv1 || !len1) { - if (pv2 && len2) - return -1; - else - goto raw_compare; - } - else { - if (!pv2 || !len2) - return 1; - } +SV * +Perl_newSVpv(pTHX_ const char *s, STRLEN len) +{ + register SV *sv; - retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); + new_SV(sv); + if (!len) + len = strlen(s); + sv_setpvn(sv,s,len); + return sv; +} - if (retval) - return retval < 0 ? -1 : 1; +/* +=for apidoc newSVpvn - /* - * When the result of collation is equality, that doesn't mean - * that there are no differences -- some locales exclude some - * characters from consideration. So to avoid false equalities, - * we use the raw string as a tiebreaker. - */ +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. - raw_compare: - /* FALL THROUGH */ +=cut +*/ -#endif /* USE_LOCALE_COLLATE */ +SV * +Perl_newSVpvn(pTHX_ const char *s, STRLEN len) +{ + register SV *sv; - return sv_cmp(sv1, sv2); + new_SV(sv); + sv_setpvn(sv,s,len); + return sv; } -#ifdef USE_LOCALE_COLLATE -/* - * Any scalar variable may carry an 'o' magic that contains the - * scalar data of the variable transformed to such a format that - * a normal memory comparison can be used to compare the data - * according to the locale settings. - */ -char * -Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) +#if defined(PERL_IMPLICIT_CONTEXT) +SV * +Perl_newSVpvf_nocontext(const char* pat, ...) { - MAGIC *mg; + dTHX; + register SV *sv; + va_list args; + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + return sv; +} +#endif - mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; - if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { - char *s, *xf; - STRLEN len, xlen; +/* +=for apidoc newSVpvf - if (mg) - Safefree(mg->mg_ptr); - s = SvPV(sv, len); - if ((xf = mem_collxfrm(s, len, &xlen))) { - if (SvREADONLY(sv)) { - SAVEFREEPV(xf); - *nxp = xlen; - return xf + sizeof(PL_collation_ix); - } - if (! mg) { - sv_magic(sv, 0, 'o', 0, 0); - mg = mg_find(sv, 'o'); - assert(mg); - } - mg->mg_ptr = xf; - mg->mg_len = xlen; - } - else { - if (mg) { - mg->mg_ptr = NULL; - mg->mg_len = -1; - } - } - } - if (mg && mg->mg_ptr) { - *nxp = mg->mg_len; - return mg->mg_ptr + sizeof(PL_collation_ix); - } - else { - *nxp = 0; - return NULL; - } +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 = vnewSVpvf(pat, &args); + va_end(args); + return sv; } -#endif /* USE_LOCALE_COLLATE */ +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; +} -char * -Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) +/* +=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 * +Perl_newSVnv(pTHX_ NV n) { - dTHR; - char *rsptr; - STRLEN rslen; - register STDCHAR rslast; - register STDCHAR *bp; - register I32 cnt; - I32 i; + register SV *sv; - SV_CHECK_THINKFIRST(sv); - (void)SvUPGRADE(sv, SVt_PV); + new_SV(sv); + sv_setnv(sv,n); + return sv; +} - SvSCREAM_off(sv); +/* +=for apidoc newSViv - if (RsSNARF(PL_rs)) { - rsptr = NULL; - rslen = 0; - } - else if (RsRECORD(PL_rs)) { - I32 recsize, bytesread; - char *buffer; +Creates a new SV and copies an integer into it. The reference count for the +SV is set to 1. - /* Grab the size of the record we're getting */ - recsize = SvIV(SvRV(PL_rs)); - (void)SvPOK_only(sv); /* Validate pointer */ - buffer = SvGROW(sv, recsize + 1); - /* Go yank in */ -#ifdef VMS - /* VMS wants read instead of fread, because fread doesn't respect */ - /* RMS record boundaries. This is not necessarily a good thing to be */ - /* doing, but we've got no other real choice */ - bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); -#else - bytesread = PerlIO_read(fp, buffer, recsize); -#endif - SvCUR_set(sv, bytesread); - buffer[bytesread] = '\0'; - return(SvCUR(sv) ? SvPVX(sv) : Nullch); - } - else if (RsPARA(PL_rs)) { - rsptr = "\n\n"; - rslen = 2; - } - else - rsptr = SvPV(PL_rs, rslen); - rslast = rslen ? rsptr[rslen - 1] : '\0'; +=cut +*/ - if (RsPARA(PL_rs)) { /* have to do this both before and after */ - do { /* to make sure file boundaries work right */ - if (PerlIO_eof(fp)) - return 0; - i = PerlIO_getc(fp); - if (i != '\n') { - if (i == -1) - return 0; - PerlIO_ungetc(fp,i); - break; - } - } while (i != EOF); - } +SV * +Perl_newSViv(pTHX_ IV i) +{ + register SV *sv; - /* See if we know enough about I/O mechanism to cheat it ! */ + new_SV(sv); + sv_setiv(sv,i); + return sv; +} - /* This used to be #ifdef test - it is made run-time test for ease - of abstracting out stdio interface. One call should be cheap - enough here - and may even be a macro allowing compile - time optimization. - */ +/* +=for apidoc newRV_noinc - if (PerlIO_fast_gets(fp)) { +Creates an RV wrapper for an SV. The reference count for the original +SV is B incremented. - /* - * We're going to steal some values from the stdio struct - * and put EVERYTHING in the innermost loop into registers. - */ - register STDCHAR *ptr; - STRLEN bpx; - I32 shortbuffered; +=cut +*/ -#if defined(VMS) && defined(PERLIO_IS_STDIO) - /* An ungetc()d char is handled separately from the regular - * buffer, so we getc() it back out and stuff it in the buffer. - */ - i = PerlIO_getc(fp); - if (i == EOF) return 0; - *(--((*fp)->_ptr)) = (unsigned char) i; - (*fp)->_cnt++; -#endif +SV * +Perl_newRV_noinc(pTHX_ SV *tmpRef) +{ + dTHR; + register SV *sv; - /* Here is some breathtakingly efficient cheating */ + new_SV(sv); + sv_upgrade(sv, SVt_RV); + SvTEMP_off(tmpRef); + SvRV(sv) = tmpRef; + SvROK_on(sv); + return sv; +} - cnt = PerlIO_get_cnt(fp); /* get count into register */ - (void)SvPOK_only(sv); /* validate pointer */ - if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ - if (cnt > 80 && SvLEN(sv) > append) { - shortbuffered = cnt - SvLEN(sv) + append + 1; - cnt -= shortbuffered; - } - else { - shortbuffered = 0; - /* remember that cnt can be negative */ - SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1))); - } - } - else - shortbuffered = 0; - 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)); - 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))); - for (;;) { - screamer: - if (cnt > 0) { - if (rslen) { - while (cnt > 0) { /* this | eat */ - cnt--; - if ((*bp++ = *ptr++) == rslast) /* really | dust */ - goto thats_all_folks; /* screams | sed :-) */ - } - } - else { - Copy(ptr, bp, cnt, char); /* this | eat */ - bp += cnt; /* screams | dust */ - ptr += cnt; /* louder | sed :-) */ - cnt = 0; - } - } - - if (shortbuffered) { /* oh well, must extend */ - cnt = shortbuffered; - shortbuffered = 0; - bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); - SvGROW(sv, SvLEN(sv) + append + cnt + 2); - bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ - continue; - } +/* newRV_inc is #defined to newRV in sv.h */ +SV * +Perl_newRV(pTHX_ SV *tmpRef) +{ + return newRV_noinc(SvREFCNT_inc(tmpRef)); +} - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)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 - 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))); - 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)); +/* +=for apidoc newSVsv - if (i == EOF) /* all done for ever? */ - goto thats_really_all_folks; +Creates a new SV which is an exact duplicate of the original SV. - bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); - SvGROW(sv, bpx + cnt + 2); - bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ +=cut +*/ - *bp++ = i; /* store character from PerlIO_getc */ +/* make an exact duplicate of old */ - if (rslen && (STDCHAR)i == rslast) /* all done for now? */ - goto thats_all_folks; - } +SV * +Perl_newSVsv(pTHX_ register SV *old) +{ + dTHR; + register SV *sv; -thats_all_folks: - if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || - memNE((char*)bp - rslen, rsptr, rslen)) - goto screamer; /* go back to the fray */ -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)); - 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))); - *bp = '\0'; - SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: done, len=%ld, string=|%.*s|\n", - (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); + if (!old) + return Nullsv; + if (SvTYPE(old) == SVTYPEMASK) { + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); + return Nullsv; } - 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 + new_SV(sv); + if (SvTEMP(old)) { + SvTEMP_off(old); + sv_setsv(sv,old); + SvTEMP_on(old); + } + else + sv_setsv(sv,old); + return sv; +} -screamer2: - if (rslen) { - register STDCHAR *bpe = buf + sizeof(buf); - bp = buf; - while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) - ; /* keep reading */ - cnt = bp - buf; - } - else { - cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); - /* Accomodate broken VAXC compiler, which applies U8 cast to - * both args of ?: operator, causing EOF to change into 255 - */ - if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } - } +void +Perl_sv_reset(pTHX_ register char *s, HV *stash) +{ + register HE *entry; + register GV *gv; + register SV *sv; + register I32 i; + register PMOP *pm; + register I32 max; + char todo[PERL_UCHAR_MAX+1]; - if (append) - sv_catpvn(sv, (char *) buf, cnt); - else - sv_setpvn(sv, (char *) buf, cnt); + if (!stash) + return; - if (i != EOF && /* joy */ - (!rslen || - SvCUR(sv) < rslen || - memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) - { - append = -1; - /* - * If we're reading from a TTY and we get a short read, - * indicating that the user hit his EOF character, we need - * to notice it now, because if we try to read from the TTY - * again, the EOF condition will disappear. - * - * The comparison of cnt to sizeof(buf) is an optimization - * that prevents unnecessary calls to feof(). - * - * - jik 9/25/96 - */ - if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) - goto screamer2; + if (!*s) { /* reset ?? searches */ + for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { + pm->op_pmdynflags &= ~PMdf_USED; } + return; } - 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') { - PerlIO_ungetc(fp,i); - break; + /* reset variables */ + + if (!HvARRAY(stash)) + return; + + Zero(todo, 256, char); + while (*s) { + i = (unsigned char)*s; + if (s[1] == '-') { + s += 2; + } + max = (unsigned char)*s++; + for ( ; i <= max; i++) { + todo[i] = 1; + } + for (i = 0; i <= (I32) HvMAX(stash); i++) { + for (entry = HvARRAY(stash)[i]; + entry; + entry = HeNEXT(entry)) + { + if (!todo[(U8)*HeKEY(entry)]) + continue; + gv = (GV*)HeVAL(entry); + sv = GvSV(gv); + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + continue; + } + (void)SvOK_off(sv); + if (SvTYPE(sv) >= SVt_PV) { + SvCUR_set(sv, 0); + if (SvPVX(sv) != Nullch) + *SvPVX(sv) = '\0'; + SvTAINT(sv); + } + if (GvAV(gv)) { + av_clear(GvAV(gv)); + } + if (GvHV(gv) && !HvNAME(GvHV(gv))) { + hv_clear(GvHV(gv)); +#ifndef VMS /* VMS has no environ array */ + if (gv == PL_envgv) + environ[0] = Nullch; +#endif + } } } } +} -#ifdef WIN32 - win32_strip_return(sv); -#endif +IO* +Perl_sv_2io(pTHX_ SV *sv) +{ + IO* io; + GV* gv; + STRLEN n_a; - return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; + switch (SvTYPE(sv)) { + case SVt_PVIO: + io = (IO*)sv; + break; + case SVt_PVGV: + gv = (GV*)sv; + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); + break; + default: + if (!SvOK(sv)) + 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); + if (gv) + io = GvIO(gv); + else + io = 0; + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); + break; + } + return io; } - -void -Perl_sv_inc(pTHX_ register SV *sv) +CV * +Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { - register char *d; - int flags; + GV *gv; + CV *cv; + STRLEN n_a; if (!sv) - return; - if (SvGMAGICAL(sv)) - mg_get(sv); - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { + return *gvp = Nullgv, Nullcv; + switch (SvTYPE(sv)) { + case SVt_PVCV: + *st = CvSTASH(sv); + *gvp = Nullgv; + return (CV*)sv; + case SVt_PVHV: + case SVt_PVAV: + *gvp = Nullgv; + return Nullcv; + case SVt_PVGV: + gv = (GV*)sv; + *gvp = gv; + *st = GvESTASH(gv); + goto fix_gv; + + default: + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { dTHR; - if (PL_curcop != &PL_compiling) - Perl_croak(aTHX_ PL_no_modify); + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVCV) { + cv = (CV*)sv; + *gvp = Nullgv; + *st = CvSTASH(cv); + return cv; + } + else if(isGV(sv)) + gv = (GV*)sv; + else + Perl_croak(aTHX_ "Not a subroutine reference"); } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) - return; - i = (IV)SvRV(sv); - sv_unref(sv); - sv_setiv(sv, i); + else if (isGV(sv)) + gv = (GV*)sv; + else + gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); + *gvp = gv; + if (!gv) + return Nullcv; + *st = GvESTASH(gv); + fix_gv: + if (lref && !GvCVu(gv)) { + SV *tmpsv; + 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)) + Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); } + return GvCVu(gv); } - flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); - SvNVX(sv) += 1.0; - return; +} + +I32 +Perl_sv_true(pTHX_ register SV *sv) +{ + dTHR; + if (!sv) + return 0; + if (SvPOK(sv)) { + register XPV* tXpv; + if ((tXpv = (XPV*)SvANY(sv)) && + (tXpv->xpv_cur > 1 || + (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) + return 1; + else + return 0; } - if (flags & SVp_IOK) { - if (SvIsUV(sv)) { - if (SvUVX(sv) == UV_MAX) - sv_setnv(sv, (NV)UV_MAX + 1.0); + else { + if (SvIOK(sv)) + return SvIVX(sv) != 0; + else { + if (SvNOK(sv)) + return SvNVX(sv) != 0.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 sv_2bool(sv); } - return; } - if (!(flags & SVp_POK) || !*SvPVX(sv)) { - if ((flags & SVTYPEMASK) < SVt_PVNV) - sv_upgrade(sv, SVt_NV); - SvNVX(sv) = 1.0; - (void)SvNOK_only(sv); - return; +} + +IV +Perl_sv_iv(pTHX_ register SV *sv) +{ + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return (IV)SvUVX(sv); + return SvIVX(sv); } - d = SvPVX(sv); - while (isALPHA(*d)) d++; - while (isDIGIT(*d)) d++; - if (*d) { - sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */ - return; + return sv_2iv(sv); +} + +UV +Perl_sv_uv(pTHX_ register SV *sv) +{ + if (SvIOK(sv)) { + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); } - d--; - while (d >= SvPVX(sv)) { - if (isDIGIT(*d)) { - if (++*d <= '9') - return; - *(d--) = '0'; - } - else { -#ifdef EBCDIC - /* MKS: The original code here died if letters weren't consecutive. - * at least it didn't have to worry about non-C locales. The - * new code assumes that ('z'-'a')==('Z'-'A'), letters are - * arranged in order (although not consecutively) and that only - * [A-Za-z] are accepted by isALPHA in the C locale. - */ - if (*d != 'z' && *d != 'Z') { - do { ++*d; } while (!isALPHA(*d)); - return; - } - *(d--) -= 'z' - 'a'; -#else - ++*d; - if (isALPHA(*d)) - return; - *(d--) -= 'z' - 'a' + 1; -#endif - } + return sv_2uv(sv); +} + +NV +Perl_sv_nv(pTHX_ register SV *sv) +{ + if (SvNOK(sv)) + return SvNVX(sv); + return sv_2nv(sv); +} + +char * +Perl_sv_pv(pTHX_ SV *sv) +{ + STRLEN n_a; + + if (SvPOK(sv)) + return SvPVX(sv); + + return sv_2pv(sv, &n_a); +} + +char * +Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) +{ + if (SvPOK(sv)) { + *lp = SvCUR(sv); + return SvPVX(sv); } - /* oh,oh, the number grew */ - SvGROW(sv, SvCUR(sv) + 2); - SvCUR(sv)++; - for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--) - *d = d[-1]; - if (isDIGIT(d[1])) - *d = '1'; - else - *d = d[1]; + return sv_2pv(sv, lp); } -void -Perl_sv_dec(pTHX_ register SV *sv) +char * +Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { - int flags; + char *s; - if (!sv) - return; - if (SvGMAGICAL(sv)) - mg_get(sv); - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { + 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; - if (PL_curcop != &PL_compiling) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), + PL_op_name[PL_op->op_type]); } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) - return; - i = (IV)SvRV(sv); - sv_unref(sv); - sv_setiv(sv, i); + 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 */ + SvGROW(sv, len + 1); + Move(s,SvPVX(sv),len,char); + SvCUR_set(sv, len); + *SvEND(sv) = '\0'; } - } - flags = SvFLAGS(sv); - if (flags & SVp_NOK) { - SvNVX(sv) -= 1.0; - (void)SvNOK_only(sv); - return; - } - if (flags & SVp_IOK) { - 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); - } + if (!SvPOK(sv)) { + SvPOK_on(sv); /* validate pointer */ + SvTAINT(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX(sv))); } - return; - } - if (!(flags & SVp_POK)) { - if ((flags & SVTYPEMASK) < SVt_PVNV) - sv_upgrade(sv, SVt_NV); - SvNVX(sv) = -1.0; - (void)SvNOK_only(sv); - return; } - sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ + return SvPVX(sv); } -/* 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 * -Perl_sv_mortalcopy(pTHX_ SV *oldstr) +char * +Perl_sv_pvbyte(pTHX_ SV *sv) { - dTHR; - register SV *sv; - - new_SV(sv); - sv_setsv(sv,oldstr); - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; - SvTEMP_on(sv); - return sv; + return sv_pv(sv); } -SV * -Perl_sv_newmortal(pTHX) +char * +Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) { - dTHR; - register SV *sv; - - new_SV(sv); - SvFLAGS(sv) = SVs_TEMP; - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; - return sv; + return sv_pvn(sv,lp); } -/* same thing without the copying */ - -SV * -Perl_sv_2mortal(pTHX_ register SV *sv) +char * +Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) { - dTHR; - if (!sv) - return sv; - if (SvREADONLY(sv) && SvIMMORTAL(sv)) - return sv; - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; - SvTEMP_on(sv); - return sv; + return sv_pvn_force(sv,lp); } -SV * -Perl_newSVpv(pTHX_ const char *s, STRLEN len) +char * +Perl_sv_pvutf8(pTHX_ SV *sv) { - register SV *sv; - - new_SV(sv); - if (!len) - len = strlen(s); - sv_setpvn(sv,s,len); - return sv; + sv_utf8_upgrade(sv); + return sv_pv(sv); } -SV * -Perl_newSVpvn(pTHX_ const char *s, STRLEN len) +char * +Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) { - register SV *sv; - - new_SV(sv); - sv_setpvn(sv,s,len); - return sv; + sv_utf8_upgrade(sv); + return sv_pvn(sv,lp); } -#if defined(PERL_IMPLICIT_CONTEXT) -SV * -Perl_newSVpvf_nocontext(const char* pat, ...) +char * +Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) { - dTHX; - register SV *sv; - va_list args; - va_start(args, pat); - sv = vnewSVpvf(pat, &args); - va_end(args); - return sv; + sv_utf8_upgrade(sv); + return sv_pvn_force(sv,lp); } -#endif -SV * -Perl_newSVpvf(pTHX_ const char* pat, ...) +char * +Perl_sv_reftype(pTHX_ SV *sv, int ob) { - register SV *sv; - va_list args; - va_start(args, pat); - sv = vnewSVpvf(pat, &args); - va_end(args); - return sv; + if (ob && SvOBJECT(sv)) + return HvNAME(SvSTASH(sv)); + else { + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_RV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVMG: + case SVt_PVBM: + if (SvROK(sv)) + return "REF"; + else + return "SCALAR"; + case SVt_PVLV: return "LVALUE"; + case SVt_PVAV: return "ARRAY"; + case SVt_PVHV: return "HASH"; + case SVt_PVCV: return "CODE"; + case SVt_PVGV: return "GLOB"; + case SVt_PVFM: return "FORMAT"; + default: return "UNKNOWN"; + } + } } -SV * -Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +/* +=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 +Perl_sv_isobject(pTHX_ SV *sv) { - register SV *sv; - new_SV(sv); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); - return sv; + if (!sv) + return 0; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvROK(sv)) + return 0; + sv = (SV*)SvRV(sv); + if (!SvOBJECT(sv)) + return 0; + return 1; } -SV * -Perl_newSVnv(pTHX_ NV n) -{ - register SV *sv; +/* +=for apidoc sv_isa - new_SV(sv); - sv_setnv(sv,n); - return sv; -} +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. -SV * -Perl_newSViv(pTHX_ IV i) +=cut +*/ + +int +Perl_sv_isa(pTHX_ SV *sv, const char *name) { - register SV *sv; + if (!sv) + return 0; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (!SvROK(sv)) + return 0; + sv = (SV*)SvRV(sv); + if (!SvOBJECT(sv)) + return 0; - new_SV(sv); - sv_setiv(sv,i); - return sv; + return strEQ(HvNAME(SvSTASH(sv)), name); } -SV * -Perl_newRV_noinc(pTHX_ SV *tmpRef) +/* +=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* +Perl_newSVrv(pTHX_ SV *rv, const char *classname) { dTHR; - register SV *sv; + SV *sv; new_SV(sv); - sv_upgrade(sv, SVt_RV); - SvTEMP_off(tmpRef); - SvRV(sv) = tmpRef; - SvROK_on(sv); - return sv; -} -SV * -Perl_newRV(pTHX_ SV *tmpRef) -{ - return newRV_noinc(SvREFCNT_inc(tmpRef)); -} + SV_CHECK_THINKFIRST(rv); + SvAMAGIC_off(rv); -/* make an exact duplicate of old */ + if (SvTYPE(rv) < SVt_RV) + sv_upgrade(rv, SVt_RV); -SV * -Perl_newSVsv(pTHX_ register SV *old) -{ - dTHR; - register SV *sv; + (void)SvOK_off(rv); + SvRV(rv) = sv; + SvROK_on(rv); - if (!old) - return Nullsv; - if (SvTYPE(old) == SVTYPEMASK) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); - return Nullsv; - } - new_SV(sv); - if (SvTEMP(old)) { - SvTEMP_off(old); - sv_setsv(sv,old); - SvTEMP_on(old); + if (classname) { + HV* stash = gv_stashpv(classname, TRUE); + (void)sv_bless(rv, stash); } - else - sv_setsv(sv,old); return sv; } -void -Perl_sv_reset(pTHX_ register char *s, HV *stash) -{ - register HE *entry; - register GV *gv; - register SV *sv; - register I32 i; - register PMOP *pm; - register I32 max; - char todo[PERL_UCHAR_MAX+1]; +/* +=for apidoc sv_setref_pv - if (!stash) - return; +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. - if (!*s) { /* reset ?? searches */ - for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmdynflags &= ~PMdf_USED; - } - return; - } +Do not use with other Perl types such as HV, AV, SV, CV, because those +objects will become corrupted by the pointer copy process. - /* reset variables */ +Note that C copies the string while this copies the pointer. - if (!HvARRAY(stash)) - return; +=cut +*/ - Zero(todo, 256, char); - while (*s) { - i = (unsigned char)*s; - if (s[1] == '-') { - s += 2; - } - max = (unsigned char)*s++; - for ( ; i <= max; i++) { - todo[i] = 1; - } - for (i = 0; i <= (I32) HvMAX(stash); i++) { - for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) - { - if (!todo[(U8)*HeKEY(entry)]) - continue; - gv = (GV*)HeVAL(entry); - sv = GvSV(gv); - if (SvTHINKFIRST(sv)) { - if (!SvREADONLY(sv) && SvROK(sv)) - sv_unref(sv); - continue; - } - (void)SvOK_off(sv); - if (SvTYPE(sv) >= SVt_PV) { - SvCUR_set(sv, 0); - if (SvPVX(sv) != Nullch) - *SvPVX(sv) = '\0'; - SvTAINT(sv); - } - if (GvAV(gv)) { - av_clear(GvAV(gv)); - } - if (GvHV(gv) && !HvNAME(GvHV(gv))) { - hv_clear(GvHV(gv)); -#ifndef VMS /* VMS has no environ array */ - if (gv == PL_envgv) - environ[0] = Nullch; -#endif - } - } - } +SV* +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), PTR2IV(pv)); + return rv; } -IO* -Perl_sv_2io(pTHX_ SV *sv) +/* +=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* +Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) { - IO* io; - GV* gv; - STRLEN n_a; + sv_setiv(newSVrv(rv,classname), iv); + return rv; +} - switch (SvTYPE(sv)) { - case SVt_PVIO: - io = (IO*)sv; - break; - case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); - break; - default: - if (!SvOK(sv)) - 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); - if (gv) - io = GvIO(gv); - else - io = 0; - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); - break; - } - return io; +/* +=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* +Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) +{ + sv_setnv(newSVrv(rv,classname), nv); + return rv; } -CV * -Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) +/* +=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* +Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) { - GV *gv; - CV *cv; - STRLEN n_a; + sv_setpvn(newSVrv(rv,classname), pv, n); + return rv; +} - if (!sv) - return *gvp = Nullgv, Nullcv; - switch (SvTYPE(sv)) { - case SVt_PVCV: - *st = CvSTASH(sv); - *gvp = Nullgv; - return (CV*)sv; - case SVt_PVHV: - case SVt_PVAV: - *gvp = Nullgv; - return Nullcv; - case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; +/* +=for apidoc sv_bless - default: - if (SvGMAGICAL(sv)) - mg_get(sv); - if (SvROK(sv)) { - dTHR; - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ - tryAMAGICunDEREF(to_cv); +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. - sv = SvRV(sv); - if (SvTYPE(sv) == SVt_PVCV) { - cv = (CV*)sv; - *gvp = Nullgv; - *st = CvSTASH(cv); - return cv; - } - else if(isGV(sv)) - gv = (GV*)sv; - else - Perl_croak(aTHX_ "Not a subroutine reference"); - } - else if (isGV(sv)) - gv = (GV*)sv; - else - gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV); - *gvp = gv; - if (!gv) - return Nullcv; - *st = GvESTASH(gv); - fix_gv: - if (lref && !GvCVu(gv)) { - SV *tmpsv; - 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)) - Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); +=cut +*/ + +SV* +Perl_sv_bless(pTHX_ SV *sv, HV *stash) +{ + dTHR; + SV *tmpRef; + if (!SvROK(sv)) + Perl_croak(aTHX_ "Can't bless non-reference value"); + tmpRef = SvRV(sv); + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(tmpRef)) + Perl_croak(aTHX_ PL_no_modify); + if (SvOBJECT(tmpRef)) { + if (SvTYPE(tmpRef) != SVt_PVIO) + --PL_sv_objcount; + SvREFCNT_dec(SvSTASH(tmpRef)); } - return GvCVu(gv); } + SvOBJECT_on(tmpRef); + if (SvTYPE(tmpRef) != SVt_PVIO) + ++PL_sv_objcount; + (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); + + if (Gv_AMG(stash)) + SvAMAGIC_on(sv); + else + SvAMAGIC_off(sv); + + return sv; } -I32 -Perl_sv_true(pTHX_ register SV *sv) +STATIC void +S_sv_unglob(pTHX_ SV *sv) { - dTHR; - if (!sv) - return 0; - if (SvPOK(sv)) { - register XPV* tXpv; - if ((tXpv = (XPV*)SvANY(sv)) && - (*tXpv->xpv_pv > '0' || - tXpv->xpv_cur > 1 || - (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) - return 1; - else - return 0; - } - else { - if (SvIOK(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOK(sv)) - return SvNVX(sv) != 0.0; - else - return sv_2bool(sv); - } + void *xpvmg; + + assert(SvTYPE(sv) == SVt_PVGV); + SvFAKE_off(sv); + if (GvGP(sv)) + gp_free((GV*)sv); + if (GvSTASH(sv)) { + SvREFCNT_dec(GvSTASH(sv)); + GvSTASH(sv) = Nullhv; } + sv_unmagic(sv, '*'); + Safefree(GvNAME(sv)); + GvMULTI_off(sv); + + /* 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; } -IV -Perl_sv_iv(pTHX_ register SV *sv) +/* +=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 +Perl_sv_unref(pTHX_ SV *sv) { - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); + SV* rv = SvRV(sv); + + if (SvWEAKREF(sv)) { + sv_del_backref(sv); + SvWEAKREF_off(sv); + SvRV(sv) = 0; + return; } - return sv_2iv(sv); + SvRV(sv) = 0; + SvROK_off(sv); + if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) + SvREFCNT_dec(rv); + else + sv_2mortal(rv); /* Schedule for freeing later */ } -UV -Perl_sv_uv(pTHX_ register SV *sv) +void +Perl_sv_taint(pTHX_ SV *sv) { - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); + sv_magic((sv), Nullsv, 't', Nullch, 0); +} + +void +Perl_sv_untaint(pTHX_ SV *sv) +{ + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + MAGIC *mg = mg_find(sv, 't'); + if (mg) + mg->mg_len &= ~1; } - return sv_2uv(sv); } -NV -Perl_sv_nv(pTHX_ register SV *sv) +bool +Perl_sv_tainted(pTHX_ SV *sv) { - if (SvNOK(sv)) - return SvNVX(sv); - return sv_2nv(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)) + return TRUE; + } + return FALSE; } -char * -Perl_sv_pv(pTHX_ SV *sv) +/* +=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 +Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { - STRLEN n_a; + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - if (SvPOK(sv)) - return SvPVX(sv); + sv_setpvn(sv, ptr, ebuf - ptr); +} - return sv_2pv(sv, &n_a); + +/* +=for apidoc sv_setpviv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) +{ + char buf[TYPE_CHARS(UV)]; + char *ebuf; + char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + + sv_setpvn(sv, ptr, ebuf - ptr); + SvSETMAGIC(sv); } -char * -Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) +#if defined(PERL_IMPLICIT_CONTEXT) +void +Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) { - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv(sv, lp); + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvf(sv, pat, &args); + va_end(args); } -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) + +void +Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) { - char *s; + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvf_mg(sv, pat, &args); + va_end(args); +} +#endif - 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; - 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 */ - SvGROW(sv, len + 1); - Move(s,SvPVX(sv),len,char); - SvCUR_set(sv, len); - *SvEND(sv) = '\0'; - } - 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))); - } - } - return SvPVX(sv); +/* +=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 +Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvf(sv, pat, &args); + va_end(args); } -char * -Perl_sv_reftype(pTHX_ SV *sv, int ob) +void +Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) { - if (ob && SvOBJECT(sv)) - return HvNAME(SvSTASH(sv)); - else { - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVMG: - case SVt_PVBM: - if (SvROK(sv)) - return "REF"; - else - return "SCALAR"; - case SVt_PVLV: return "LVALUE"; - case SVt_PVAV: return "ARRAY"; - case SVt_PVHV: return "HASH"; - case SVt_PVCV: return "CODE"; - case SVt_PVGV: return "GLOB"; - case SVt_PVFM: return "FORMAT"; - default: return "UNKNOWN"; - } - } + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); } -int -Perl_sv_isobject(pTHX_ SV *sv) +/* +=for apidoc sv_setpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) { - if (!sv) - return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); - if (!SvROK(sv)) - return 0; - sv = (SV*)SvRV(sv); - if (!SvOBJECT(sv)) - return 0; - return 1; + va_list args; + va_start(args, pat); + sv_vsetpvf_mg(sv, pat, &args); + va_end(args); } -int -Perl_sv_isa(pTHX_ SV *sv, const char *name) +void +Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) { - if (!sv) - return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); - if (!SvROK(sv)) - return 0; - sv = (SV*)SvRV(sv); - if (!SvOBJECT(sv)) - return 0; + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); +} - return strEQ(HvNAME(SvSTASH(sv)), name); +#if defined(PERL_IMPLICIT_CONTEXT) +void +Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf(sv, pat, &args); + va_end(args); } -SV* -Perl_newSVrv(pTHX_ SV *rv, const char *classname) +void +Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) { - dTHR; - SV *sv; + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvf_mg(sv, pat, &args); + va_end(args); +} +#endif - new_SV(sv); +/* +=for apidoc sv_catpvf - SV_CHECK_THINKFIRST(rv); - SvAMAGIC_off(rv); +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. - if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); +=cut +*/ - (void)SvOK_off(rv); - SvRV(rv) = sv; - SvROK_on(rv); +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); +} - if (classname) { - HV* stash = gv_stashpv(classname, TRUE); - (void)sv_bless(rv, stash); - } - return sv; +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*)); } -SV* -Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) +/* +=for apidoc sv_catpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + +void +Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) { - if (!pv) { - sv_setsv(rv, &PL_sv_undef); - SvSETMAGIC(rv); - } - else - sv_setiv(newSVrv(rv,classname), (IV)pv); - return rv; + va_list args; + va_start(args, pat); + sv_vcatpvf_mg(sv, pat, &args); + va_end(args); } -SV* -Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) +void +Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) { - sv_setiv(newSVrv(rv,classname), iv); - return rv; + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); } -SV* -Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) +/* +=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_setnv(newSVrv(rv,classname), nv); - return rv; + sv_setpvn(sv, "", 0); + sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } -SV* -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_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; + } + } + + patend = (char*)pat + patlen; + 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; + STRLEN width = 0; + STRLEN zeros = 0; + bool has_precis = FALSE; + STRLEN precis = 0; + bool is_utf = FALSE; + + char esignbuf[4]; + U8 utf8buf[UTF8_MAXLEN]; + STRLEN esignlen = 0; + + char *eptr = Nullch; + STRLEN elen = 0; + /* Times 4: a decimal digit takes more than 3 binary digits. + * NV_DIG: mantissa takes than many decimal digits. + * Plus 32: Playing safe. */ + char ebuf[IV_DIG * 4 + NV_DIG + 32]; + /* large enough for "%#.#f" --chip */ + /* what about long double NVs? --jhi */ + + SV *vecsv; + U8 *vecstr = Null(U8*); + STRLEN veclen = 0; + char c; + int i; + unsigned base; + IV iv; + UV uv; + NV nv; + STRLEN have; + STRLEN need; + STRLEN gap; + char *dotstr = "."; + STRLEN dotstrlen = 1; + + for (q = p; q < patend && *q != '%'; ++q) ; + if (q > p) { + sv_catpvn(sv, p, q - p); + p = q; + } + if (q++ >= patend) + break; + + /* FLAGS */ + + while (*q) { + switch (*q) { + case ' ': + case '+': + plus = *q++; + continue; + + case '-': + left = TRUE; + q++; + continue; + + case '0': + fill = *q++; + continue; + + case '#': + alt = TRUE; + 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++]; + dotstr = SvPVx(vecsv,dotstrlen); + if (DO_UTF8(vecsv)) + is_utf = TRUE; + /* FALL THROUGH */ + + case 'v': + vectorize = TRUE; + q++; + if (args) + vecsv = va_arg(*args, SV*); + else if (svix < svmax) + vecsv = svargs[svix++]; + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + continue; + + default: + break; + } + break; + } + + /* WIDTH */ + + switch (*q) { + case '1': case '2': case '3': + case '4': case '5': case '6': + case '7': case '8': case '9': + width = 0; + while (isDIGIT(*q)) + width = width * 10 + (*q++ - '0'); + break; + + case '*': + if (args) + i = va_arg(*args, int); + else + i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + left |= (i < 0); + width = (i < 0) ? -i : i; + q++; + break; + } + + /* PRECISION */ -SV* -Perl_sv_bless(pTHX_ SV *sv, HV *stash) -{ - dTHR; - SV *tmpRef; - if (!SvROK(sv)) - Perl_croak(aTHX_ "Can't bless non-reference value"); - tmpRef = SvRV(sv); - if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { - if (SvREADONLY(tmpRef)) - Perl_croak(aTHX_ PL_no_modify); - if (SvOBJECT(tmpRef)) { - if (SvTYPE(tmpRef) != SVt_PVIO) - --PL_sv_objcount; - SvREFCNT_dec(SvSTASH(tmpRef)); + if (*q == '.') { + q++; + if (*q == '*') { + if (args) + i = va_arg(*args, int); + else + i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + precis = (i < 0) ? 0 : i; + q++; + } + else { + precis = 0; + while (isDIGIT(*q)) + precis = precis * 10 + (*q++ - '0'); + } + has_precis = TRUE; } - } - SvOBJECT_on(tmpRef); - if (SvTYPE(tmpRef) != SVt_PVIO) - ++PL_sv_objcount; - (void)SvUPGRADE(tmpRef, SVt_PVMG); - SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); - if (Gv_AMG(stash)) - SvAMAGIC_on(sv); - else - SvAMAGIC_off(sv); + /* SIZE */ - return sv; -} + switch (*q) { +#ifdef HAS_QUAD + case 'L': /* Ld */ + case 'q': /* qd */ + intsize = 'q'; + q++; + break; +#endif + case 'l': +#ifdef HAS_QUAD + if (*(q + 1) == 'l') { /* lld */ + intsize = 'q'; + q += 2; + break; + } +#endif + /* FALL THROUGH */ + case 'h': + /* FALL THROUGH */ + case 'V': + intsize = *q++; + break; + } -STATIC void -S_sv_unglob(pTHX_ SV *sv) -{ - assert(SvTYPE(sv) == SVt_PVGV); - SvFAKE_off(sv); - if (GvGP(sv)) - gp_free((GV*)sv); - if (GvSTASH(sv)) { - SvREFCNT_dec(GvSTASH(sv)); - GvSTASH(sv) = Nullhv; - } - sv_unmagic(sv, '*'); - Safefree(GvNAME(sv)); - GvMULTI_off(sv); - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= SVt_PVMG; -} + /* CONVERSION */ -void -Perl_sv_unref(pTHX_ SV *sv) -{ - SV* rv = SvRV(sv); + switch (c = *q++) { - 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)) - SvREFCNT_dec(rv); - else - sv_2mortal(rv); /* Schedule for freeing later */ -} + /* STRINGS */ -void -Perl_sv_taint(pTHX_ SV *sv) -{ - sv_magic((sv), Nullsv, 't', Nullch, 0); -} + case '%': + eptr = q - 1; + elen = 1; + goto string; -void -Perl_sv_untaint(pTHX_ SV *sv) -{ - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, 't'); - if (mg) - mg->mg_len &= ~1; - } -} + case 'c': + if (args) + uv = va_arg(*args, int); + else + uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { + eptr = (char*)utf8buf; + elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; + is_utf = TRUE; + } + else { + c = (char)uv; + eptr = &c; + elen = 1; + } + goto string; -bool -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)) - return TRUE; - } - return FALSE; -} + 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) { + argsv = svargs[svix++]; + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) { + if (has_precis && precis < elen) { + I32 p = precis; + sv_pos_u2b(argsv, &p, 0); /* sticks at end */ + precis = p; + } + if (width) { /* fudge width (can't fudge elen) */ + width += elen - sv_len_utf8(argsv); + } + is_utf = TRUE; + } + } + goto string; -void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + case '_': + /* + * The "%_" hack might have to be changed someday, + * if ISO or ANSI decide to use '_' for something. + * So we keep it hidden from users' code. + */ + if (!args) + goto unknown; + argsv = va_arg(*args,SV*); + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) + is_utf = TRUE; - sv_setpvn(sv, ptr, ebuf - ptr); -} + string: + vectorize = FALSE; + if (has_precis && elen > precis) + elen = precis; + break; + /* INTEGERS */ -void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + case 'p': + if (args) + uv = PTR2UV(va_arg(*args, void*)); + else + uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0; + base = 16; + goto integer; - sv_setpvn(sv, ptr, ebuf - ptr); - SvSETMAGIC(sv); -} + case 'D': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else + intsize = 'l'; +#endif + /* FALL THROUGH */ + case 'd': + case 'i': + if (vectorize) { + I32 ulen; + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + iv = (IV)utf8_to_uv(vecstr, &ulen); + 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; + switch (intsize) { + case 'h': iv = (short)iv; break; + default: iv = (int)iv; break; + case 'l': iv = (long)iv; break; + case 'V': break; +#ifdef HAS_QUAD + case 'q': iv = (Quad_t)iv; break; +#endif + } + } + if (iv >= 0) { + uv = iv; + if (plus) + esignbuf[esignlen++] = plus; + } + else { + uv = -iv; + esignbuf[esignlen++] = '-'; + } + base = 10; + goto integer; -#if defined(PERL_IMPLICIT_CONTEXT) -void -Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) -{ - dTHX; - va_list args; - va_start(args, pat); - sv_vsetpvf(sv, pat, &args); - va_end(args); -} + case 'U': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else + intsize = 'l'; +#endif + /* FALL THROUGH */ + case 'u': + base = 10; + goto uns_integer; + case 'b': + base = 2; + goto uns_integer; -void -Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) -{ - dTHX; - va_list args; - va_start(args, pat); - sv_vsetpvf_mg(sv, pat, &args); - va_end(args); -} + case 'O': +#ifdef IV_IS_QUAD + intsize = 'q'; +#else + intsize = 'l'; #endif + /* FALL THROUGH */ + case 'o': + base = 8; + goto uns_integer; -void -Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) -{ - va_list args; - va_start(args, pat); - sv_vsetpvf(sv, pat, &args); - va_end(args); -} + case 'X': + case 'x': + base = 16; -void -Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) -{ - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); -} + uns_integer: + if (vectorize) { + I32 ulen; + vector: + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + uv = utf8_to_uv(vecstr, &ulen); + 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; + switch (intsize) { + case 'h': uv = (unsigned short)uv; break; + default: uv = (unsigned)uv; break; + case 'l': uv = (unsigned long)uv; break; + case 'V': break; +#ifdef HAS_QUAD + case 'q': uv = (Quad_t)uv; break; +#endif + } + } -void -Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) -{ - va_list args; - va_start(args, pat); - sv_vsetpvf_mg(sv, pat, &args); - va_end(args); -} + integer: + eptr = ebuf + sizeof ebuf; + switch (base) { + unsigned dig; + case 16: + if (!uv) + alt = FALSE; + p = (char*)((c == 'X') + ? "0123456789ABCDEF" : "0123456789abcdef"); + do { + dig = uv & 15; + *--eptr = p[dig]; + } while (uv >>= 4); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'x' or 'X' */ + } + break; + case 8: + do { + dig = uv & 7; + *--eptr = '0' + dig; + } while (uv >>= 3); + if (alt && *eptr != '0') + *--eptr = '0'; + break; + case 2: + do { + dig = uv & 1; + *--eptr = '0' + dig; + } while (uv >>= 1); + if (alt) { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = 'b'; + } + break; + default: /* it had better be ten or less */ +#if defined(PERL_Y2KWARN) + if (ckWARN(WARN_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; + } while (uv /= base); + break; + } + elen = (ebuf + sizeof ebuf) - eptr; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; + } + break; -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); -} + /* FLOATING POINT */ -#if defined(PERL_IMPLICIT_CONTEXT) -void -Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) -{ - dTHX; - va_list args; - va_start(args, pat); - sv_vcatpvf(sv, pat, &args); - va_end(args); -} + case 'F': + c = 'f'; /* maybe %F isn't supported here */ + /* FALL THROUGH */ + case 'e': case 'E': + case 'f': + case 'g': case 'G': -void -Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) -{ - dTHX; - va_list args; - va_start(args, pat); - sv_vcatpvf_mg(sv, pat, &args); - va_end(args); -} -#endif + /* This is evil, but floating point is even more evil */ -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); -} + vectorize = FALSE; + if (args) + nv = va_arg(*args, NV); + else + nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0; -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*)); -} + need = 0; + if (c != 'e' && c != 'E') { + i = PERL_INT_MIN; + (void)frexp(nv, &i); + if (i == PERL_INT_MIN) + Perl_die(aTHX_ "panic: frexp"); + if (i > 0) + need = BIT_DIGITS(i); + } + need += has_precis ? precis : 6; /* known default */ + if (need < width) + need = width; -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); -} + need += 20; /* fudge factor */ + if (PL_efloatsize < need) { + Safefree(PL_efloatbuf); + PL_efloatsize = need + 20; /* more fudge */ + New(906, PL_efloatbuf, PL_efloatsize, char); + PL_efloatbuf[0] = '\0'; + } -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); -} + eptr = ebuf + sizeof ebuf; + *--eptr = '\0'; + *--eptr = c; +#ifdef USE_LONG_DOUBLE + { + char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3; + while (p >= PERL_PRIfldbl) { *--eptr = *p--; } + } +#endif + if (has_precis) { + base = precis; + do { *--eptr = '0' + (base % 10); } while (base /= 10); + *--eptr = '.'; + } + if (width) { + base = width; + do { *--eptr = '0' + (base % 10); } while (base /= 10); + } + if (fill == '0') + *--eptr = fill; + if (left) + *--eptr = '-'; + if (plus) + *--eptr = plus; + if (alt) + *--eptr = '#'; + *--eptr = '%'; -void -Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) -{ - sv_setpvn(sv, "", 0); - sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale); -} + { + RESTORE_NUMERIC_STANDARD(); + (void)sprintf(PL_efloatbuf, eptr, nv); + RESTORE_NUMERIC_LOCAL(); + } -void -Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) -{ - dTHR; - char *p; - char *q; - char *patend; - STRLEN origlen; - I32 svix = 0; - static char nullstr[] = "(null)"; + eptr = PL_efloatbuf; + elen = strlen(PL_efloatbuf); + break; - /* no matter what, this is a string now */ - (void)SvPV_force(sv, origlen); + /* SPECIAL */ - /* special-case "", "%s", and "%_" */ - if (patlen == 0) - return; - if (patlen == 2 && pat[0] == '%') { - switch (pat[1]) { - case 's': + case 'n': + vectorize = FALSE; + i = SvCUR(sv) - origlen; if (args) { - char *s = va_arg(*args, char*); - sv_catpv(sv, s ? s : nullstr); + switch (intsize) { + case 'h': *(va_arg(*args, short*)) = i; break; + 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_catsv(sv, *svargs); - return; - case '_': - if (args) { - sv_catsv(sv, va_arg(*args, SV*)); - return; - } - /* See comment on '_' below */ - break; - } - } + sv_setuv(svargs[svix++], (UV)i); + continue; /* not "break" */ - patend = (char*)pat + patlen; - for (p = (char*)pat; p < patend; p = q) { - bool alt = FALSE; - bool left = FALSE; - char fill = ' '; - char plus = 0; - char intsize = 0; - STRLEN width = 0; - STRLEN zeros = 0; - bool has_precis = FALSE; - STRLEN precis = 0; + /* UNKNOWN */ - char esignbuf[4]; - U8 utf8buf[10]; - STRLEN esignlen = 0; + 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(); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", + (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); + if (c) { + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03"UVof"\"", + (UV)c & 0xFF); + } else + sv_catpv(msg, "end of string"); + Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */ + } - char *eptr = Nullch; - STRLEN elen = 0; - /* Times 4: a decimal digit takes more than 3 binary digits. - * NV_DIG: mantissa takes than many decimal digits. - * Plus 32: Playing safe. */ - char ebuf[IV_DIG * 4 + NV_DIG + 32]; - /* large enough for "%#.#f" --chip */ - /* what about long double NVs? --jhi */ - char c; - int i; - unsigned base; - IV iv; - UV uv; - NV nv; - STRLEN have; - STRLEN need; - STRLEN gap; + /* output mangled stuff ... */ + if (c == '\0') + --q; + eptr = p; + elen = q - p; - for (q = p; q < patend && *q != '%'; ++q) ; - if (q > p) { - sv_catpvn(sv, p, q - p); - p = q; + /* ... right here, because formatting flags should not apply */ + SvGROW(sv, SvCUR(sv) + elen + 1); + p = SvEND(sv); + memcpy(p, eptr, elen); + p += elen; + *p = '\0'; + SvCUR(sv) = p - SvPVX(sv); + continue; /* not "break" */ } - if (q++ >= patend) - break; - - /* FLAGS */ - - while (*q) { - switch (*q) { - case ' ': - case '+': - plus = *q++; - continue; - - case '-': - left = TRUE; - q++; - continue; - - case '0': - fill = *q++; - continue; - case '#': - alt = TRUE; - q++; - continue; + have = esignlen + zeros + elen; + need = (have > width ? have : width); + gap = need - have; - default: - break; - } - break; + SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); + p = SvEND(sv); + if (esignlen && fill == '0') { + for (i = 0; i < esignlen; i++) + *p++ = esignbuf[i]; } - - /* WIDTH */ - - switch (*q) { - case '1': case '2': case '3': - case '4': case '5': case '6': - case '7': case '8': case '9': - width = 0; - while (isDIGIT(*q)) - width = width * 10 + (*q++ - '0'); - break; - - case '*': - if (args) - i = va_arg(*args, int); + if (gap && !left) { + memset(p, fill, gap); + p += gap; + } + if (esignlen && fill != '0') { + for (i = 0; i < esignlen; i++) + *p++ = esignbuf[i]; + } + if (zeros) { + for (i = zeros; i; i--) + *p++ = '0'; + } + if (elen) { + memcpy(p, eptr, elen); + p += elen; + } + if (gap && left) { + memset(p, ' ', gap); + p += gap; + } + if (vectorize) { + if (veclen) { + memcpy(p, dotstr, dotstrlen); + p += dotstrlen; + } else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - left |= (i < 0); - width = (i < 0) ? -i : i; - q++; - break; + 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; } + } +} - /* PRECISION */ +#if defined(USE_ITHREADS) - if (*q == '.') { - q++; - if (*q == '*') { - if (args) - i = va_arg(*args, int); - else - i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - precis = (i < 0) ? 0 : i; - q++; - } - else { - precis = 0; - while (isDIGIT(*q)) - precis = precis * 10 + (*q++ - '0'); - } - has_precis = TRUE; - } +#if defined(USE_THREADS) +# include "error: USE_THREADS and USE_ITHREADS are incompatible" +#endif - /* SIZE */ +#ifndef OpREFCNT_inc +# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) +#endif - switch (*q) { - case 'l': -#ifdef HAS_QUAD - if (*(q + 1) == 'l') { /* lld */ - intsize = 'q'; - q += 2; - break; - } - case 'L': /* Ld */ - case 'q': /* qd */ - intsize = 'q'; - q++; - break; +#ifndef GpREFCNT_inc +# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) #endif - case 'h': - /* FALL THROUGH */ - case 'V': - intsize = *q++; - break; - } - /* CONVERSION */ - switch (c = *q++) { +#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; +} - /* STRINGS */ +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; +} - case '%': - eptr = q - 1; - elen = 1; - goto string; +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; +} - case 'c': - if (IN_UTF8) { - if (args) - uv = va_arg(*args, int); - else - uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; +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); +} - eptr = (char*)utf8buf; - elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; - goto string; +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; } - if (args) - c = va_arg(*args, int); else - c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - eptr = &c; - elen = 1; - goto string; + entp = &ent->next; + } + } +} - case 's': - if (args) { - eptr = va_arg(*args, char*); - if (eptr) - elen = strlen(eptr); - else { - eptr = nullstr; - elen = sizeof nullstr - 1; - } - } - else if (svix < svmax) { - eptr = SvPVx(svargs[svix++], elen); - if (IN_UTF8) { - if (has_precis && precis < elen) { - I32 p = precis; - sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ - precis = p; - } - if (width) { /* fudge width (can't fudge elen) */ - width += elen - sv_len_utf8(svargs[svix - 1]); - } - } - } - goto string; +#ifdef DEBUGGING +char *PL_watch_pvx; +#endif - case '_': - /* - * The "%_" hack might have to be changed someday, - * if ISO or ANSI decide to use '_' for something. - * So we keep it hidden from users' code. - */ - if (!args) - goto unknown; - eptr = SvPVx(va_arg(*args, SV*), elen); +SV * +Perl_sv_dup(pTHX_ SV *sstr) +{ + U32 sflags; + int dtype; + int stype; + SV *dstr; - string: - if (has_precis && elen > precis) - elen = precis; - break; + 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; - /* INTEGERS */ + /* create anew and remember what it is */ + new_SV(dstr); + ptr_table_store(PL_ptr_table, sstr, dstr); - case 'p': - if (args) - uv = (UV)va_arg(*args, void*); - else - uv = (svix < svmax) ? (UV)svargs[svix++] : 0; - base = 16; - goto integer; + /* clone */ + SvFLAGS(dstr) = SvFLAGS(sstr); + SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ + SvREFCNT(dstr) = 0; /* must be before any other dups! */ - case 'D': -#ifdef IV_IS_QUAD - /* nothing */ -#else - intsize = 'l'; -#endif - /* FALL THROUGH */ - case 'd': - case 'i': - if (args) { - switch (intsize) { - case 'h': iv = (short)va_arg(*args, int); break; -#ifdef IV_IS_QUAD - default: iv = va_arg(*args, IV); break; -#else - default: iv = va_arg(*args, int); break; -#endif - 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; +#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 { - iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - switch (intsize) { - case 'h': iv = (short)iv; break; -#ifdef IV_IS_QUAD - default: break; -#else - default: iv = (int)iv; break; -#endif - case 'l': iv = (long)iv; break; - case 'V': break; -#ifdef HAS_QUAD - case 'q': iv = (Quad_t)iv; break; -#endif - } + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++); } - if (iv >= 0) { - uv = iv; - if (plus) - esignbuf[esignlen++] = plus; + items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + while (items-- > 0) { + *dst_ary++ = &PL_sv_undef; } - else { - uv = -iv; - esignbuf[esignlen++] = '-'; + } + 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)) { + HE *entry; + STRLEN i = 0; + XPVHV *dxhv = (XPVHV*)SvANY(dstr); + XPVHV *sxhv = (XPVHV*)SvANY(sstr); + Newz(0, dxhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); + while (i <= sxhv->xhv_max) { + ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], + !!HvSHAREKEYS(sstr)); + ++i; } - base = 10; - goto integer; + 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; + } - case 'U': -#ifdef IV_IS_QUAD - /* nothing */ -#else - intsize = 'l'; -#endif - /* FALL THROUGH */ - case 'u': - base = 10; - goto uns_integer; + if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) + ++PL_sv_objcount; - case 'b': - base = 2; - goto uns_integer; + return dstr; +} - case 'O': -#ifdef IV_IS_QUAD - /* nothing */ -#else - intsize = 'l'; -#endif - /* FALL THROUGH */ - case 'o': - base = 8; - goto uns_integer; +PERL_CONTEXT * +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) +{ + PERL_CONTEXT *ncxs; - case 'X': - case 'x': - base = 16; + if (!cxs) + return (PERL_CONTEXT*)NULL; - uns_integer: - if (args) { - switch (intsize) { - case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; -#ifdef UV_IS_QUAD - default: uv = va_arg(*args, UV); break; -#else - default: uv = va_arg(*args, unsigned); break; -#endif - 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; - switch (intsize) { - case 'h': uv = (unsigned short)uv; break; -#ifdef UV_IS_QUAD - default: break; -#else - default: uv = (unsigned)uv; break; -#endif - case 'l': uv = (unsigned long)uv; break; - case 'V': break; -#ifdef HAS_QUAD - case 'q': uv = (Quad_t)uv; break; -#endif - } - } + /* look for it in the table first */ + ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); + if (ncxs) + return ncxs; - integer: - eptr = ebuf + sizeof ebuf; - switch (base) { - unsigned dig; - case 16: - if (!uv) - alt = FALSE; - p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; - do { - dig = uv & 15; - *--eptr = p[dig]; - } while (uv >>= 4); - if (alt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'x' or 'X' */ - } + /* 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 8: - do { - dig = uv & 7; - *--eptr = '0' + dig; - } while (uv >>= 3); - if (alt && *eptr != '0') - *--eptr = '0'; + 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 2: - do { - dig = uv & 1; - *--eptr = '0' + dig; - } while (uv >>= 1); - if (alt && *eptr != '0') - *--eptr = '0'; + 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.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; - default: /* it had better be ten or less */ - do { - dig = uv % base; - *--eptr = '0' + dig; - } while (uv /= base); + 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; } - elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis) { - if (precis > elen) - zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') - elen = 0; - } - break; + } + --ix; + } + return ncxs; +} - /* FLOATING POINT */ +PERL_SI * +Perl_si_dup(pTHX_ PERL_SI *si) +{ + PERL_SI *nsi; - case 'F': - c = 'f'; /* maybe %F isn't supported here */ - /* FALL THROUGH */ - case 'e': case 'E': - case 'f': - case 'g': case 'G': + if (!si) + return (PERL_SI*)NULL; - /* This is evil, but floating point is even more evil */ + /* look for it in the table first */ + nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); + if (nsi) + return nsi; - if (args) - nv = va_arg(*args, NV); - else - nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0; + /* create anew and remember what it is */ + Newz(56, nsi, 1, PERL_SI); + ptr_table_store(PL_ptr_table, si, nsi); - need = 0; - if (c != 'e' && c != 'E') { - i = PERL_INT_MIN; - (void)frexp(nv, &i); - if (i == PERL_INT_MIN) - Perl_die(aTHX_ "panic: frexp"); - if (i > 0) - need = BIT_DIGITS(i); - } - need += has_precis ? precis : 6; /* known default */ - if (need < width) - need = width; + 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; - need += 20; /* fudge factor */ - if (PL_efloatsize < need) { - Safefree(PL_efloatbuf); - PL_efloatsize = need + 20; /* more fudge */ - New(906, PL_efloatbuf, PL_efloatsize, char); - } + return nsi; +} - eptr = ebuf + sizeof ebuf; - *--eptr = '\0'; - *--eptr = c; -#ifdef USE_LONG_DOUBLE - { - char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3; - while (p >= PERL_PRIfldbl) { *--eptr = *p--; } - } -#endif - if (has_precis) { - base = precis; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - *--eptr = '.'; - } - if (width) { - base = width; - do { *--eptr = '0' + (base % 10); } while (base /= 10); - } - if (fill == '0') - *--eptr = fill; - if (left) - *--eptr = '-'; - if (plus) - *--eptr = plus; - if (alt) - *--eptr = '#'; - *--eptr = '%'; +#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) - { - RESTORE_NUMERIC_STANDARD(); - (void)sprintf(PL_efloatbuf, eptr, nv); - RESTORE_NUMERIC_LOCAL(); - } +/* 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) - eptr = PL_efloatbuf; - elen = strlen(PL_efloatbuf); +void * +Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +{ + void *ret; -#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 */ + 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*); + + 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_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) = any_dup(ptr, proto_perl); + 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(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(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"); + } + } - /* SPECIAL */ + return nss; +} - case 'n': - i = SvCUR(sv) - origlen; - if (args) { - switch (intsize) { - case 'h': *(va_arg(*args, short*)) = i; break; -#ifdef IV_IS_QUAD - default: *(va_arg(*args, IV*)) = i; break; -#else - default: *(va_arg(*args, int*)) = i; break; +#ifdef PERL_OBJECT +#include "XSUB.h" #endif - 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; + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)proto_perl; #endif - } - } - else if (svix < svmax) - sv_setuv(svargs[svix++], (UV)i); - continue; /* not "break" */ - /* UNKNOWN */ +#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; + SV *sv; + SV **svp; +# ifdef PERL_OBJECT + CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, + ipD, ipS, ipP); + PERL_SET_INTERP(pPerl); +# else /* !PERL_OBJECT */ + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_INTERP(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; + SV *sv; + SV **svp; + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + PERL_SET_INTERP(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_root = NULL; + PL_xrv_root = NULL; + PL_xpv_root = NULL; + PL_xpviv_root = NULL; + PL_xpvnv_root = NULL; + PL_xpvcv_root = NULL; + PL_xpvav_root = NULL; + PL_xpvhv_root = NULL; + PL_xpvmg_root = NULL; + PL_xpvlv_root = NULL; + PL_xpvbm_root = NULL; + PL_he_root = NULL; + PL_nice_chunk = NULL; + PL_nice_chunk_size = 0; + PL_sv_count = 0; + PL_sv_objcount = 0; + PL_sv_root = Nullsv; + PL_sv_arenaroot = Nullsv; + + PL_debug = proto_perl->Idebug; + + /* create SV map for pointer relocation */ + PL_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); - default: - unknown: - if (!args && ckWARN(WARN_PRINTF) && - (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { - SV *msg = sv_newmortal(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", - (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); - if (c) { -#ifdef UV_IS_QUAD - if (isPRINT(c)) - Perl_sv_catpvf(aTHX_ msg, - "\"%%%c\"", c & 0xFF); - else - Perl_sv_catpvf(aTHX_ msg, - "\"%%\\%03" PERL_PRIo64 "\"", - (UV)c & 0xFF); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_no, SVt_PVNV); #else - Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? - "\"%%%c\"" : "\"%%\\%03o\"", - c & 0xFF); + SvANY(&PL_sv_no) = new_XPVNV(); #endif - } else - sv_catpv(msg, "end of string"); - Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ - } + 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); - /* output mangled stuff ... */ - if (c == '\0') - --q; - eptr = p; - elen = q - p; +#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 - /* ... right here, because formatting flags should not apply */ - SvGROW(sv, SvCUR(sv) + elen + 1); - p = SvEND(sv); - memcpy(p, eptr, elen); - p += elen; - *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); - continue; /* not "break" */ - } + /* 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 = OpREFCNT_inc(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 - have = esignlen + zeros + elen; - need = (have > width ? have : width); - gap = need - have; + /* 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 - SvGROW(sv, SvCUR(sv) + need + 1); - p = SvEND(sv); - if (esignlen && fill == '0') { - for (i = 0; i < esignlen; i++) - *p++ = esignbuf[i]; - } - if (gap && !left) { - memset(p, fill, gap); - p += gap; - } - if (esignlen && fill != '0') { - for (i = 0; i < esignlen; i++) - *p++ = esignbuf[i]; - } - if (zeros) { - for (i = zeros; i; i--) - *p++ = '0'; - } - if (elen) { - memcpy(p, eptr, elen); - p += elen; + 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]); } - if (gap && left) { - memset(p, ' ', gap); - p += gap; + } + 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; } - *p = '\0'; - SvCUR(sv) = p - SvPVX(sv); + + /* 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(); } + + 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 -#define NO_XSLOCKS #include "XSUB.h" #endif +#endif /* USE_ITHREADS */ + static void do_report_used(pTHXo_ SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { - /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ - PerlIO_printf(PerlIO_stderr(), "****\n"); + PerlIO_printf(Perl_debug_log, "****\n"); sv_dump(sv); } } @@ -5293,7 +8003,7 @@ do_clean_objs(pTHXo_ SV *sv) static void do_clean_named_objs(pTHXo_ SV *sv) { - if (SvTYPE(sv) == SVt_PVGV) { + if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || GvAV(sv) && SvOBJECT(GvAV(sv)) || GvHV(sv) && SvOBJECT(GvHV(sv)) || @@ -5310,7 +8020,7 @@ do_clean_named_objs(pTHXo_ SV *sv) static void do_clean_all(pTHXo_ SV *sv) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); }