X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=278ad8b7811f8fff9b4620de7fde25703724f0b1;hb=a176fa2a176313dc1a9b9594d080f47292ff4070;hp=6513e2255910122e7e4d61f39c2f4644e7d1f76a;hpb=76e3520e1f6b7df33cd381a2cf4f1fce3d69c8a4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 6513e22..278ad8b 100644 --- a/sv.c +++ b/sv.c @@ -65,42 +65,48 @@ static void sv_mortalgrow _((void)); static void sv_unglob _((SV* sv)); static void sv_check_thinkfirst _((SV *sv)); +#ifndef PURIFY +static void *my_safemalloc(MEM_SIZE size); +#endif + typedef void (*SVFUNC) _((SV*)); #define VTBL *vtbl #define FCALL *f #endif /* PERL_OBJECT */ +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv) + #ifdef PURIFY #define new_SV(p) \ do { \ - MUTEX_LOCK(&sv_mutex); \ + LOCK_SV_MUTEX; \ (p) = (SV*)safemalloc(sizeof(SV)); \ reg_add(p); \ - MUTEX_UNLOCK(&sv_mutex); \ + UNLOCK_SV_MUTEX; \ } while (0) #define del_SV(p) \ do { \ - MUTEX_LOCK(&sv_mutex); \ + LOCK_SV_MUTEX; \ reg_remove(p); \ Safefree((char*)(p)); \ - MUTEX_UNLOCK(&sv_mutex); \ + UNLOCK_SV_MUTEX; \ } while (0) static SV **registry; -static I32 regsize; +static I32 registry_size; #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) #define REG_REPLACE(sv,a,b) \ do { \ void* p = sv->sv_any; \ - I32 h = REGHASH(sv, regsize); \ + I32 h = REGHASH(sv, registry_size); \ I32 i = h; \ while (registry[i] != (a)) { \ - if (++i >= regsize) \ + if (++i >= registry_size) \ i = 0; \ if (i == h) \ die("SV registry bug"); \ @@ -115,14 +121,13 @@ static void reg_add(sv) SV* sv; { - if (sv_count >= (regsize >> 1)) + if (PL_sv_count >= (registry_size >> 1)) { SV **oldreg = registry; - I32 oldsize = regsize; + I32 oldsize = registry_size; - regsize = regsize ? ((regsize << 2) + 1) : 2037; - registry = (SV**)safemalloc(regsize * sizeof(SV*)); - memzero(registry, regsize * sizeof(SV*)); + registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; + Newz(707, registry, registry_size, SV*); if (oldreg) { I32 i; @@ -137,7 +142,7 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } static void @@ -145,7 +150,7 @@ reg_remove(sv) SV* sv; { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } static void @@ -154,9 +159,9 @@ SVFUNC f; { I32 i; - for (i = 0; i < regsize; ++i) { + for (i = 0; i < registry_size; ++i) { SV* sv = registry[i]; - if (sv) + if (sv && SvTYPE(sv) != SVTYPEMASK) (*f)(sv); } } @@ -179,49 +184,49 @@ U32 flags; #define plant_SV(p) \ do { \ - SvANY(p) = (void *)sv_root; \ + SvANY(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ - sv_root = (p); \ - --sv_count; \ + PL_sv_root = (p); \ + --PL_sv_count; \ } while (0) /* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ do { \ - (p) = sv_root; \ - sv_root = (SV*)SvANY(p); \ - ++sv_count; \ + (p) = PL_sv_root; \ + PL_sv_root = (SV*)SvANY(p); \ + ++PL_sv_count; \ } while (0) -#define new_SV(p) do { \ - MUTEX_LOCK(&sv_mutex); \ - if (sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv(); \ - MUTEX_UNLOCK(&sv_mutex); \ +#define new_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv(); \ + UNLOCK_SV_MUTEX; \ } while (0) #ifdef DEBUGGING -#define del_SV(p) do { \ - MUTEX_LOCK(&sv_mutex); \ - if (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p); \ - MUTEX_UNLOCK(&sv_mutex); \ +#define del_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (PL_debug & 32768) \ + del_sv(p); \ + else \ + plant_SV(p); \ + UNLOCK_SV_MUTEX; \ } while (0) STATIC void del_sv(SV *p) { - if (debug & 32768) { + if (PL_debug & 32768) { SV* sva; SV* sv; SV* svend; int ok = 0; - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { sv = sva + 1; svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) @@ -250,12 +255,12 @@ sv_add_arena(char *ptr, U32 size, U32 flags) Zero(sva, size, char); /* The first SV in an arena isn't an SV. */ - SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */ + SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ SvFLAGS(sva) = flags; /* FAKE if not to be freed */ - sv_arenaroot = sva; - sv_root = sva + 1; + PL_sv_arenaroot = sva; + PL_sv_root = sva + 1; svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; @@ -274,9 +279,9 @@ more_sv(void) { register SV* sv; - if (nice_chunk) { - sv_add_arena(nice_chunk, nice_chunk_size, 0); - nice_chunk = Nullch; + if (PL_nice_chunk) { + sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); + PL_nice_chunk = Nullch; } else { char *chunk; /* must use New here to match call to */ @@ -294,7 +299,7 @@ visit(SVFUNC f) SV* sv; register SV* svend; - for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) @@ -318,7 +323,7 @@ do_report_used(SV *sv) void sv_report_used(void) { - visit(do_report_used); + visit(FUNC_NAME_TO_PTR(do_report_used)); } STATIC void @@ -340,40 +345,46 @@ do_clean_objs(SV *sv) STATIC void do_clean_named_objs(SV *sv) { - if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) - do_clean_objs(GvSV(sv)); + if (SvTYPE(sv) == SVt_PVGV) { + if ( SvOBJECT(GvSV(sv)) || + GvAV(sv) && SvOBJECT(GvAV(sv)) || + GvHV(sv) && SvOBJECT(GvHV(sv)) || + GvIO(sv) && SvOBJECT(GvIO(sv)) || + GvCV(sv) && SvOBJECT(GvCV(sv)) ) + { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) + SvREFCNT_dec(sv); + } + } } #endif -static bool in_clean_objs = FALSE; - void sv_clean_objs(void) { - in_clean_objs = TRUE; + PL_in_clean_objs = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_objs)); #ifndef DISABLE_DESTRUCTOR_KLUDGE - visit(do_clean_named_objs); + /* some barnacles may yet remain, clinging to typeglobs */ + visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); #endif - visit(do_clean_objs); - in_clean_objs = FALSE; + PL_in_clean_objs = FALSE; } STATIC void do_clean_all(SV *sv) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } -static bool in_clean_all = FALSE; - void sv_clean_all(void) { - in_clean_all = TRUE; - visit(do_clean_all); - in_clean_all = FALSE; + PL_in_clean_all = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_all)); + PL_in_clean_all = FALSE; } void @@ -385,7 +396,7 @@ sv_free_arenas(void) /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ - for (sva = sv_arenaroot; sva; sva = svanext) { + for (sva = PL_sv_arenaroot; sva; sva = svanext) { svanext = (SV*) SvANY(sva); while (svanext && SvFAKE(svanext)) svanext = (SV*) SvANY(svanext); @@ -394,21 +405,25 @@ sv_free_arenas(void) Safefree((void *)sva); } - sv_arenaroot = 0; - sv_root = 0; + if (PL_nice_chunk) + Safefree(PL_nice_chunk); + PL_nice_chunk = Nullch; + PL_nice_chunk_size = 0; + PL_sv_arenaroot = 0; + PL_sv_root = 0; } STATIC XPVIV* new_xiv(void) { - IV** xiv; - if (xiv_root) { - xiv = xiv_root; + IV* xiv; + if (PL_xiv_root) { + xiv = PL_xiv_root; /* * See comment in more_xiv() -- RAM. */ - xiv_root = (IV**)*xiv; - return (XPVIV*)((char*)xiv - sizeof(XPV)); + PL_xiv_root = *(IV**)xiv; + return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } return more_xiv(); } @@ -416,29 +431,30 @@ new_xiv(void) STATIC void del_xiv(XPVIV *p) { - IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); - *xiv = (IV *)xiv_root; - xiv_root = xiv; + IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); + *(IV**)xiv = PL_xiv_root; + PL_xiv_root = xiv; } STATIC XPVIV* more_xiv(void) { - register IV** xiv; - register IV** xivend; - XPV* ptr = (XPV*)safemalloc(1008); - ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ - xiv_arenaroot = ptr; /* to keep Purify happy */ - - xiv = (IV**) ptr; - xivend = &xiv[1008 / sizeof(IV *) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */ - xiv_root = xiv; + register IV* xiv; + register IV* xivend; + XPV* ptr; + New(705, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ + PL_xiv_arenaroot = ptr; /* to keep Purify happy */ + + xiv = (IV*) ptr; + xivend = &xiv[1008 / sizeof(IV) - 1]; + xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ + PL_xiv_root = xiv; while (xiv < xivend) { - *xiv = (IV *)(xiv + 1); + *(IV**)xiv = (IV *)(xiv + 1); xiv++; } - *xiv = 0; + *(IV**)xiv = 0; return new_xiv(); } @@ -446,10 +462,10 @@ STATIC XPVNV* new_xnv(void) { double* xnv; - if (xnv_root) { - xnv = xnv_root; - xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - sizeof(XPVIV)); + if (PL_xnv_root) { + xnv = PL_xnv_root; + PL_xnv_root = *(double**)xnv; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } return more_xnv(); } @@ -457,9 +473,9 @@ new_xnv(void) STATIC void del_xnv(XPVNV *p) { - double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); - *(double**)xnv = xnv_root; - xnv_root = xnv; + double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + *(double**)xnv = PL_xnv_root; + PL_xnv_root = xnv; } STATIC XPVNV* @@ -467,10 +483,10 @@ more_xnv(void) { register double* xnv; register double* xnvend; - xnv = (double*)safemalloc(1008); + New(711, xnv, 1008/sizeof(double), double); xnvend = &xnv[1008 / sizeof(double) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ - xnv_root = xnv; + PL_xnv_root = xnv; while (xnv < xnvend) { *(double**)xnv = (double*)(xnv + 1); xnv++; @@ -483,9 +499,9 @@ STATIC XRV* new_xrv(void) { XRV* xrv; - if (xrv_root) { - xrv = xrv_root; - xrv_root = (XRV*)xrv->xrv_rv; + if (PL_xrv_root) { + xrv = PL_xrv_root; + PL_xrv_root = (XRV*)xrv->xrv_rv; return xrv; } return more_xrv(); @@ -494,8 +510,8 @@ new_xrv(void) STATIC void del_xrv(XRV *p) { - p->xrv_rv = (SV*)xrv_root; - xrv_root = p; + p->xrv_rv = (SV*)PL_xrv_root; + PL_xrv_root = p; } STATIC XRV* @@ -503,8 +519,8 @@ more_xrv(void) { register XRV* xrv; register XRV* xrvend; - xrv_root = (XRV*)safemalloc(1008); - xrv = xrv_root; + New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); + xrv = PL_xrv_root; xrvend = &xrv[1008 / sizeof(XRV) - 1]; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); @@ -518,9 +534,9 @@ STATIC XPV* new_xpv(void) { XPV* xpv; - if (xpv_root) { - xpv = xpv_root; - xpv_root = (XPV*)xpv->xpv_pv; + if (PL_xpv_root) { + xpv = PL_xpv_root; + PL_xpv_root = (XPV*)xpv->xpv_pv; return xpv; } return more_xpv(); @@ -529,8 +545,8 @@ new_xpv(void) STATIC void del_xpv(XPV *p) { - p->xpv_pv = (char*)xpv_root; - xpv_root = p; + p->xpv_pv = (char*)PL_xpv_root; + PL_xpv_root = p; } STATIC XPV* @@ -538,8 +554,8 @@ more_xpv(void) { register XPV* xpv; register XPV* xpvend; - xpv_root = (XPV*)safemalloc(1008); - xpv = xpv_root; + New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); + xpv = PL_xpv_root; xpvend = &xpv[1008 / sizeof(XPV) - 1]; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); @@ -581,38 +597,52 @@ more_xpv(void) #define del_XPV(p) del_xpv((XPV *)p) #endif -#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) Safefree((char*)p) - -#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) Safefree((char*)p) - -#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) Safefree((char*)p) - -#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) Safefree((char*)p) - -#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) Safefree((char*)p) - -#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) Safefree((char*)p) - -#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) Safefree((char*)p) - -#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) Safefree((char*)p) - -#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) Safefree((char*)p) - -#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) Safefree((char*)p) - -#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) Safefree((char*)p) +#ifdef PURIFY +# define my_safemalloc(s) safemalloc(s) +# define my_safefree(s) free(s) +#else +STATIC void* +my_safemalloc(MEM_SIZE size) +{ + char *p; + New(717, p, size, char); + return (void*)p; +} +# define my_safefree(s) Safefree(s) +#endif + +#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) my_safefree((char*)p) + +#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree((char*)p) + +#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree((char*)p) + +#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) my_safefree((char*)p) + +#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree((char*)p) + +#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree((char*)p) + +#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) my_safefree((char*)p) + +#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree((char*)p) + +#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) my_safefree((char*)p) + +#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM)) +#define del_XPVFM(p) my_safefree((char*)p) + +#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO)) +#define del_XPVIO(p) my_safefree((char*)p) bool sv_upgrade(register SV *sv, U32 mt) @@ -795,7 +825,7 @@ sv_upgrade(register SV *sv, U32 mt) Safefree(pv); SvPVX(sv) = 0; AvMAX(sv) = -1; - AvFILL(sv) = -1; + AvFILLp(sv) = -1; SvIVX(sv) = 0; SvNVX(sv) = 0.0; SvMAGIC(sv) = magic; @@ -888,10 +918,10 @@ sv_upgrade(register SV *sv, U32 mt) return TRUE; } -#ifdef DEBUGGING char * sv_peek(SV *sv) { +#ifdef DEBUGGING SV *t = sv_newmortal(); STRLEN prevlen; int unref = 0; @@ -906,15 +936,15 @@ sv_peek(SV *sv) sv_catpv(t, "WILD"); goto finish; } - else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) { - if (sv == &sv_undef) { + else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) { + if (sv == &PL_sv_undef) { sv_catpv(t, "SV_UNDEF"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| SVs_GMG|SVs_SMG|SVs_RMG)) && SvREADONLY(sv)) goto finish; } - else if (sv == &sv_no) { + else if (sv == &PL_sv_no) { sv_catpv(t, "SV_NO"); if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| SVs_GMG|SVs_SMG|SVs_RMG)) && @@ -1032,9 +1062,11 @@ sv_peek(SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, na); + return SvPV(t, PL_na); +#else /* DEBUGGING */ + return ""; +#endif /* DEBUGGING */ } -#endif int sv_backoff(register SV *sv) @@ -1077,12 +1109,24 @@ sv_grow(SV* sv, unsigned long newlen) s = SvPVX(sv); if (newlen > SvLEN(sv)) newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ +#ifdef HAS_64K_LIMIT + if (newlen >= 0x10000) + newlen = 0xFFFF; +#endif } else s = SvPVX(sv); if (newlen > SvLEN(sv)) { /* need more room? */ - if (SvLEN(sv) && s) + if (SvLEN(sv) && s) { +#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) + STRLEN l = malloced_size((void*)SvPVX(sv)); + if (newlen <= l) { + SvLEN_set(sv, l); + return s; + } else +#endif Renew(s,newlen,char); + } else New(703,s,newlen,char); SvPV_set(sv, s); @@ -1094,7 +1138,7 @@ sv_grow(SV* sv, unsigned long newlen) void sv_setiv(register SV *sv, IV i) { - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { case SVt_NULL: sv_upgrade(sv, SVt_IV); @@ -1121,7 +1165,7 @@ sv_setiv(register SV *sv, IV i) { dTHR; croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), - op_desc[op->op_type]); + op_desc[PL_op->op_type]); } } (void)SvIOK_only(sv); /* validate number */ @@ -1130,6 +1174,13 @@ sv_setiv(register SV *sv, IV i) } void +sv_setiv_mg(register SV *sv, IV i) +{ + sv_setiv(sv,i); + SvSETMAGIC(sv); +} + +void sv_setuv(register SV *sv, UV u) { if (u <= IV_MAX) @@ -1139,27 +1190,27 @@ sv_setuv(register SV *sv, UV u) } void +sv_setuv_mg(register SV *sv, UV u) +{ + sv_setuv(sv,u); + SvSETMAGIC(sv); +} + +void sv_setnv(register SV *sv, double num) { - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: sv_upgrade(sv, SVt_NV); break; - case SVt_NV: case SVt_RV: case SVt_PV: case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); - /* FALL THROUGH */ - case SVt_PVNV: - case SVt_PVMG: - case SVt_PVBM: - case SVt_PVLV: - if (SvOOK(sv)) - (void)SvOOK_off(sv); break; + case SVt_PVGV: if (SvFAKE(sv)) { sv_unglob(sv); @@ -1174,7 +1225,7 @@ sv_setnv(register SV *sv, double num) { dTHR; croak("Can't coerce %s to number in %s", sv_reftype(sv,0), - op_name[op->op_type]); + op_name[PL_op->op_type]); } } SvNVX(sv) = num; @@ -1182,6 +1233,13 @@ sv_setnv(register SV *sv, double num) SvTAINT(sv); } +void +sv_setnv_mg(register SV *sv, double num) +{ + sv_setnv(sv,num); + SvSETMAGIC(sv); +} + STATIC void not_a_number(SV *sv) { @@ -1230,9 +1288,9 @@ not_a_number(SV *sv) } *d = '\0'; - if (op) + if (PL_op) warn("Argument \"%s\" isn't numeric in %s", tmpbuf, - op_name[op->op_type]); + op_name[PL_op->op_type]); else warn("Argument \"%s\" isn't numeric", tmpbuf); } @@ -1255,9 +1313,9 @@ sv_2iv(register SV *sv) if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) + if (!PL_localizing) warn(warn_uninit); } return 0; @@ -1281,7 +1339,7 @@ sv_2iv(register SV *sv) } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); - if (dowarn) + if (PL_dowarn) warn(warn_uninit); return 0; } @@ -1310,7 +1368,7 @@ sv_2iv(register SV *sv) } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; } @@ -1333,9 +1391,9 @@ sv_2uv(register SV *sv) if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) + if (!PL_localizing) warn(warn_uninit); } return 0; @@ -1356,7 +1414,7 @@ sv_2uv(register SV *sv) } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); - if (dowarn) + if (PL_dowarn) warn(warn_uninit); return 0; } @@ -1381,9 +1439,9 @@ sv_2uv(register SV *sv) SvUVX(sv) = asUV(sv); } else { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) + if (!PL_localizing) warn(warn_uninit); } return 0; @@ -1403,7 +1461,7 @@ sv_2nv(register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); @@ -1411,9 +1469,9 @@ sv_2nv(register SV *sv) if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) + if (!PL_localizing) warn(warn_uninit); } return 0; @@ -1430,14 +1488,14 @@ sv_2nv(register SV *sv) } if (SvREADONLY(sv)) { if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) return (double)SvIVX(sv); - if (dowarn) + if (PL_dowarn) warn(warn_uninit); return 0.0; } @@ -1459,14 +1517,14 @@ sv_2nv(register SV *sv) SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0.0; } @@ -1485,7 +1543,7 @@ asIV(SV *sv) if (numtype == 1) return atol(SvPVX(sv)); - if (!numtype && dowarn) + if (!numtype && PL_dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); @@ -1504,7 +1562,7 @@ asUV(SV *sv) if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif - if (!numtype && dowarn) + if (!numtype && PL_dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); @@ -1619,9 +1677,9 @@ sv_2pv(register SV *sv, STRLEN *lp) goto tokensave; } if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) + if (!PL_localizing) warn(warn_uninit); } *lp = 0; @@ -1639,7 +1697,54 @@ sv_2pv(register SV *sv, STRLEN *lp) 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: @@ -1647,14 +1752,13 @@ sv_2pv(register SV *sv, STRLEN *lp) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: - case SVt_PVMG: s = "SCALAR"; break; + case SVt_PVBM: s = "SCALAR"; break; case SVt_PVLV: s = "LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMATLINE"; break; + case SVt_PVFM: s = "FORMAT"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } @@ -1681,14 +1785,13 @@ sv_2pv(register SV *sv, STRLEN *lp) tsv = Nullsv; goto tokensave; } - if (dowarn) + if (PL_dowarn) warn(warn_uninit); *lp = 0; return ""; } } - if (!SvUPGRADE(sv, SVt_PV)) - return 0; + (void)SvUPGRADE(sv, SVt_PV); if (SvNOKp(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -1730,7 +1833,7 @@ sv_2pv(register SV *sv, STRLEN *lp) } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); *lp = 0; return ""; @@ -1838,9 +1941,9 @@ sv_setsv(SV *dstr, register SV *sstr) if (sstr == dstr) return; - sv_check_thinkfirst(dstr); + SV_CHECK_THINKFIRST(dstr); if (!sstr) - sstr = &sv_undef; + sstr = &PL_sv_undef; stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -1858,26 +1961,53 @@ sv_setsv(SV *dstr, register SV *sstr) switch (stype) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + undef_sstr: + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: - if (dtype != SVt_IV && dtype < SVt_PVIV) { - if (dtype < SVt_IV) + if (SvIOK(sstr)) { + switch (dtype) { + case SVt_NULL: sv_upgrade(dstr, SVt_IV); - else if (dtype == SVt_NV) + break; + case SVt_NV: sv_upgrade(dstr, SVt_PVNV); - else + break; + case SVt_RV: + case SVt_PV: sv_upgrade(dstr, SVt_PVIV); + break; + } + (void)SvIOK_only(dstr); + SvIVX(dstr) = SvIVX(sstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_NV: - if (dtype != SVt_NV && dtype < SVt_PVNV) { - if (dtype < SVt_NV) + if (SvNOK(sstr)) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: sv_upgrade(dstr, SVt_NV); - else + break; + case SVt_RV: + case SVt_PV: + case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); + break; + } + SvNVX(dstr) = SvNVX(sstr); + (void)SvNOK_only(dstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_RV: if (dtype < SVt_RV) sv_upgrade(dstr, SVt_RV); @@ -1885,7 +2015,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -1906,14 +2036,13 @@ sv_setsv(SV *dstr, register SV *sstr) if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; - case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVIO: - if (op) + if (PL_op) croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), - op_name[op->op_type]); + op_name[PL_op->op_type]); else croak("Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -1926,14 +2055,14 @@ sv_setsv(SV *dstr, register SV *sstr) STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); sv_magic(dstr, dstr, '*', name, len); - GvSTASH(dstr) = GvSTASH(sstr); + GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } /* ahem, death to those who redefine active sort subs */ - else if (curstack == sortstack - && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) + else if (PL_curstackinfo->si_type == PERLSI_SORT + && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); @@ -1941,7 +2070,7 @@ sv_setsv(SV *dstr, register SV *sstr) gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -1957,8 +2086,10 @@ sv_setsv(SV *dstr, register SV *sstr) goto glob_assign; } } - if (dtype < stype) - sv_upgrade(dstr, stype); + if (stype == SVt_PVLV) + SvUPGRADE(dstr, SVt_PVNV); + else + SvUPGRADE(dstr, stype); } sflags = SvFLAGS(sstr); @@ -1978,7 +2109,7 @@ sv_setsv(SV *dstr, register SV *sstr) Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); GvSV(dstr) = NEWSV(72,0); - GvLINE(dstr) = curcop->cop_line; + GvLINE(dstr) = PL_curcop->cop_line; GvEGV(dstr) = (GV*)dstr; } GvMULTI_on(dstr); @@ -1989,7 +2120,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_AV_on(dstr); break; case SVt_PVHV: @@ -1998,7 +2129,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: @@ -2007,7 +2138,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = Nullcv; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - sub_generation++; + PL_sub_generation++; } SAVESPTR(GvCV(dstr)); } @@ -2019,19 +2150,29 @@ sv_setsv(SV *dstr, register SV *sstr) if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { + SV *const_sv = cv_const_sv(cv); + bool const_changed = TRUE; + if(const_sv) + const_changed = sv_cmp(const_sv, + op_const_sv(CvSTART((CV*)sref), + Nullcv)); /* ahem, death to those who redefine * active sort subs */ - if (curstack == sortstack && - sortcop == CvSTART(cv)) + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) croak( "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if (cv_const_sv(cv)) - warn("Constant subroutine %s redefined", - GvENAME((GV*)dstr)); - else if (dowarn) - warn("Subroutine %s redefined", - GvENAME((GV*)dstr)); + if (PL_dowarn || (const_changed && const_sv)) { + if (!(CvGV(cv) && GvSTASH(CvGV(cv)) + && HvNAME(GvSTASH(CvGV(cv))) + && strEQ(HvNAME(GvSTASH(CvGV(cv))), + "autouse"))) + warn(const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2039,9 +2180,9 @@ sv_setsv(SV *dstr, register SV *sstr) GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - sub_generation++; + PL_sub_generation++; } - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_CV_on(dstr); break; case SVt_PVIO: @@ -2057,7 +2198,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_SV_on(dstr); break; } @@ -2155,17 +2296,30 @@ sv_setsv(SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); } else { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (PL_dowarn) + warn("Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } void +sv_setsv_mg(SV *dstr, register SV *sstr) +{ + sv_setsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) { + register char *dptr; assert(len >= 0); /* STRLEN is probably unsigned, so this may elicit a warning, but it won't hurt. */ - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -2174,22 +2328,31 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); } - else if (!sv_upgrade(sv, SVt_PV)) - return; + else + sv_upgrade(sv, SVt_PV); + SvGROW(sv, len + 1); - Move(ptr,SvPVX(sv),len,char); + dptr = SvPVX(sv); + Move(ptr,dptr,len,char); + dptr[len] = '\0'; SvCUR_set(sv, len); - *SvEND(sv) = '\0'; (void)SvPOK_only(sv); /* validate pointer */ SvTAINT(sv); } void +sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len) +{ + sv_setpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void sv_setpv(register SV *sv, register const char *ptr) { register STRLEN len; - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -2199,8 +2362,9 @@ sv_setpv(register SV *sv, register const char *ptr) if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); } - else if (!sv_upgrade(sv, SVt_PV)) - return; + else + sv_upgrade(sv, SVt_PV); + SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); SvCUR_set(sv, len); @@ -2209,15 +2373,22 @@ sv_setpv(register SV *sv, register const char *ptr) } void +sv_setpv_mg(register SV *sv, register const char *ptr) +{ + sv_setpv(sv,ptr); + SvSETMAGIC(sv); +} + +void sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) { - sv_check_thinkfirst(sv); - if (!SvUPGRADE(sv, SVt_PV)) - return; + SV_CHECK_THINKFIRST(sv); + (void)SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); return; } + (void)SvOOK_off(sv); if (SvPVX(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); @@ -2229,18 +2400,23 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) SvTAINT(sv); } +void +sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) +{ + sv_usepvn(sv,ptr,len); + SvSETMAGIC(sv); +} + STATIC void sv_check_thinkfirst(register SV *sv) { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - dTHR; - if (curcop != &compiling) - croak(no_modify); - } - if (SvROK(sv)) - sv_unref(sv); + if (SvREADONLY(sv)) { + dTHR; + if (PL_curcop != &PL_compiling) + croak(no_modify); } + if (SvROK(sv)) + sv_unref(sv); } void @@ -2252,7 +2428,7 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in if (!ptr || !SvPOKp(sv)) return; - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -2286,6 +2462,13 @@ sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) } void +sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len) +{ + sv_catpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void sv_catsv(SV *dstr, register SV *sstr) { char *s; @@ -2297,6 +2480,13 @@ sv_catsv(SV *dstr, register SV *sstr) } void +sv_catsv_mg(SV *dstr, register SV *sstr) +{ + sv_catsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void sv_catpv(register SV *sv, register char *ptr) { register STRLEN len; @@ -2316,14 +2506,15 @@ sv_catpv(register SV *sv, register char *ptr) SvTAINT(sv); } +void +sv_catpv_mg(register SV *sv, register char *ptr) +{ + sv_catpv(sv,ptr); + SvSETMAGIC(sv); +} + SV * -#ifdef LEAKTEST -newSV(x,len) -I32 x; -#else newSV(STRLEN len) -#endif - { register SV *sv; @@ -2347,19 +2538,18 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling && !strchr("gBf", how)) + if (PL_curcop != &PL_compiling && !strchr("gBf", how)) croak(no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { if (how == 't') - mg->mg_length |= 1; + mg->mg_len |= 1; return; } } else { - if (!SvUPGRADE(sv, SVt_PVMG)) - return; + (void)SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -2373,7 +2563,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) mg->mg_flags |= MGf_REFCOUNTED; } mg->mg_type = how; - mg->mg_length = namlen; + mg->mg_len = namlen; if (name) if (namlen >= 0) mg->mg_ptr = savepvn(name, namlen); @@ -2454,7 +2644,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) break; case 't': mg->mg_virtual = &vtbl_taint; - mg->mg_length = 1; + mg->mg_len = 1; break; case 'U': mg->mg_virtual = &vtbl_uvar; @@ -2506,9 +2696,9 @@ sv_unmagic(SV *sv, int type) if (vtbl && (vtbl->svt_free != NULL)) (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') - if (mg->mg_length >= 0) + if (mg->mg_len >= 0) Safefree(mg->mg_ptr); - else if (mg->mg_length == HEf_SVKEY) + else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -2533,10 +2723,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } i = littlelen - len; if (i > 0) { /* string might grow */ @@ -2607,7 +2804,7 @@ void sv_replace(register SV *sv, register SV *nsv) { U32 refcnt = SvREFCNT(sv); - sv_check_thinkfirst(sv); + SV_CHECK_THINKFIRST(sv); if (SvREFCNT(nsv) != 1) warn("Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { @@ -2632,51 +2829,53 @@ sv_replace(register SV *sv, register SV *nsv) void sv_clear(register SV *sv) { + HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { dTHR; - if (defstash) { /* Still have a symbol table? */ + if (PL_defstash) { /* Still have a symbol table? */ djSP; GV* destructor; + SV tmpref; - ENTER; - SAVEFREESV(SvSTASH(sv)); - - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); - if (destructor) { - SV tmpRef; - - Zero(&tmpRef, 1, SV); - sv_upgrade(&tmpRef, SVt_RV); - SvRV(&tmpRef) = SvREFCNT_inc(sv); - SvROK_on(&tmpRef); - SvREFCNT(&tmpRef) = 1; /* Fake, but otherwise - creating+destructing a ref - leads to disaster. */ - - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(&tmpRef); - PUTBACK; - perl_call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); - del_XRV(SvANY(&tmpRef)); - SvREFCNT(sv)--; - } + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; - LEAVE; + do { + stash = SvSTASH(sv); + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + SvRV(&tmpref) = SvREFCNT_inc(sv); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(&tmpref); + PUTBACK; + perl_call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); + SvREFCNT(sv)--; + POPSTACK; + LEAVE; + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + del_XRV(SvANY(&tmpref)); } - else - SvREFCNT_dec(SvSTASH(sv)); + if (SvOBJECT(sv)) { + SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ if (SvTYPE(sv) != SVt_PVIO) - --sv_objcount; /* XXX Might want something more general */ + --PL_sv_objcount; /* XXX Might want something more general */ } if (SvREFCNT(sv)) { - if (in_clean_objs) + if (PL_in_clean_objs) croak("DESTROY created new reference to dead object"); /* DESTROY gave object new lease on life */ return; @@ -2684,6 +2883,7 @@ sv_clear(register SV *sv) } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) mg_free(sv); + stash = NULL; switch (SvTYPE(sv)) { case SVt_PVIO: if (IoIFP(sv) != PerlIO_stdin() && @@ -2706,11 +2906,18 @@ sv_clear(register SV *sv) case SVt_PVAV: av_undef((AV*)sv); break; + case SVt_PVLV: + SvREFCNT_dec(LvTARG(sv)); + goto freescalar; case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); + /* cannot decrease stash refcount yet, as we might recursively delete + ourselves when the refcnt drops to zero. Delay SvREFCNT_dec + of stash until current sv is completely gone. + -- JohnPC, 27 Mar 1998 */ + stash = GvSTASH(sv); /* FALL THROUGH */ - case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -2770,7 +2977,13 @@ sv_clear(register SV *sv) break; case SVt_PVGV: del_XPVGV(SvANY(sv)); - break; + /* code duplication for increased performance. */ + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + /* decrease refcount of the stash that owns this GV, if any */ + if (stash) + SvREFCNT_dec(stash); + return; /* not break, SvFLAGS reset already happened */ case SVt_PVBM: del_XPVBM(SvANY(sv)); break; @@ -2789,35 +3002,44 @@ SV * sv_newref(SV *sv) { if (sv) - SvREFCNT(sv)++; + ATOMIC_INC(SvREFCNT(sv)); return sv; } void sv_free(SV *sv) { + int refcount_is_zero; + if (!sv) return; - if (SvREADONLY(sv)) { - if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) - return; - } if (SvREFCNT(sv) == 0) { if (SvFLAGS(sv) & SVf_BREAK) return; - if (in_clean_all) /* All is fair */ + if (PL_in_clean_all) /* All is fair */ return; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } warn("Attempt to free unreferenced scalar"); return; } - if (--SvREFCNT(sv) > 0) + ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); + if (!refcount_is_zero) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); + warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); return; } #endif + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } sv_clear(sv); if (! SvREFCNT(sv)) del_SV(sv); @@ -2833,12 +3055,91 @@ sv_len(register SV *sv) return 0; if (SvGMAGICAL(sv)) - len = mg_len(sv); + len = mg_length(sv); else junk = SvPV(sv, len); return len; } +STRLEN +sv_len_utf8(register SV *sv) +{ + unsigned char *s; + unsigned char *send; + STRLEN len; + + if (!sv) + return 0; + +#ifdef NOTYET + if (SvGMAGICAL(sv)) + len = mg_length(sv); + else +#endif + s = SvPV(sv, len); + send = s + len; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + len++; + } + return len; +} + +void +sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) +{ + unsigned char *start; + unsigned char *s; + unsigned char *send; + I32 uoffset = *offsetp; + STRLEN len; + + if (!sv) + return; + + start = s = SvPV(sv, len); + send = s + len; + while (s < send && uoffset--) + s += UTF8SKIP(s); + *offsetp = s - start; + if (lenp) { + I32 ulen = *lenp; + start = s; + while (s < send && ulen--) + s += UTF8SKIP(s); + *lenp = s - start; + } + return; +} + +void +sv_pos_b2u(register SV *sv, I32* offsetp) +{ + unsigned char *s; + unsigned char *send; + STRLEN len; + + if (!sv) + return; + + s = SvPV(sv, len); + if (len < *offsetp) + croak("panic: bad byte offset"); + send = s + *offsetp; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + ++len; + } + if (s != send) { + warn("Malformed UTF-8 character"); + --len; + } + *offsetp = len; + return; +} + I32 sv_eq(register SV *str1, register SV *str2) { @@ -2900,7 +3201,7 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) STRLEN len1, len2; I32 retval; - if (collation_standard) + if (PL_collation_standard) goto raw_compare; len1 = 0; @@ -2952,7 +3253,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) MAGIC *mg; mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; - if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { + if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { char *s, *xf; STRLEN len, xlen; @@ -2963,7 +3264,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) if (SvREADONLY(sv)) { SAVEFREEPV(xf); *nxp = xlen; - return xf + sizeof(collation_ix); + return xf + sizeof(PL_collation_ix); } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); @@ -2971,18 +3272,18 @@ sv_collxfrm(SV *sv, STRLEN *nxp) assert(mg); } mg->mg_ptr = xf; - mg->mg_length = xlen; + mg->mg_len = xlen; } else { if (mg) { mg->mg_ptr = NULL; - mg->mg_length = -1; + mg->mg_len = -1; } } } if (mg && mg->mg_ptr) { - *nxp = mg->mg_length; - return mg->mg_ptr + sizeof(collation_ix); + *nxp = mg->mg_len; + return mg->mg_ptr + sizeof(PL_collation_ix); } else { *nxp = 0; @@ -3003,24 +3304,44 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) register I32 cnt; I32 i; - sv_check_thinkfirst(sv); - if (!SvUPGRADE(sv, SVt_PV)) - return 0; + SV_CHECK_THINKFIRST(sv); + (void)SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); - if (RsSNARF(rs)) { + if (RsSNARF(PL_rs)) { rsptr = NULL; rslen = 0; } - else if (RsPARA(rs)) { + else if (RsRECORD(PL_rs)) { + I32 recsize, bytesread; + char *buffer; + + /* Grab the size of the record we're getting */ + recsize = SvIV(SvRV(PL_rs)); + (void)SvPOK_only(sv); /* Validate pointer */ + buffer = SvGROW(sv, recsize + 1); + /* Go yank in */ +#ifdef VMS + /* VMS wants read instead of fread, because fread doesn't respect */ + /* RMS record boundaries. This is not necessarily a good thing to be */ + /* doing, but we've got no other real choice */ + bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); +#else + bytesread = PerlIO_read(fp, buffer, recsize); +#endif + SvCUR_set(sv, bytesread); + buffer[bytesread] = '\0'; + return(SvCUR(sv) ? SvPVX(sv) : Nullch); + } + else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } else - rsptr = SvPV(rs, rslen); + rsptr = SvPV(PL_rs, rslen); rslast = rslen ? rsptr[rslen - 1] : '\0'; - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ if (PerlIO_eof(fp)) return 0; @@ -3217,7 +3538,7 @@ screamer2: } } - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ i = PerlIO_getc(fp); if (i != '\n') { @@ -3246,14 +3567,17 @@ sv_inc(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) { + IV i; #ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; #endif /* OVERLOAD */ - sv_unref(sv); + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } if (SvGMAGICAL(sv)) @@ -3323,14 +3647,17 @@ sv_dec(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) { + IV i; #ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; #endif /* OVERLOAD */ - sv_unref(sv); + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } if (SvGMAGICAL(sv)) @@ -3370,8 +3697,8 @@ STATIC void sv_mortalgrow(void) { dTHR; - tmps_max += (tmps_max < 512) ? 128 : 512; - Renew(tmps_stack, tmps_max, SV*); + PL_tmps_max += (PL_tmps_max < 512) ? 128 : 512; + Renew(PL_tmps_stack, PL_tmps_max, SV*); } SV * @@ -3385,9 +3712,9 @@ sv_mortalcopy(SV *oldstr) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv_setsv(sv,oldstr); - if (++tmps_ix >= tmps_max) + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } @@ -3402,9 +3729,9 @@ sv_newmortal(void) SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; - if (++tmps_ix >= tmps_max) + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; return sv; } @@ -3416,11 +3743,11 @@ sv_2mortal(register SV *sv) dTHR; if (!sv) return sv; - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (++tmps_ix >= tmps_max) + if (SvREADONLY(sv) && SvIMMORTAL(sv)) + return sv; + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } @@ -3440,16 +3767,21 @@ newSVpv(char *s, STRLEN len) return sv; } -#ifdef I_STDARG SV * -newSVpvf(const char* pat, ...) -#else -/*VARARGS0*/ +newSVpvn(char *s, STRLEN len) +{ + register SV *sv; + + new_SV(sv); + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + sv_setpvn(sv,s,len); + return sv; +} + SV * -newSVpvf(pat, va_alist) -const char *pat; -va_dcl -#endif +newSVpvf(const char* pat, ...) { register SV *sv; va_list args; @@ -3458,11 +3790,7 @@ va_dcl SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); return sv; @@ -3496,7 +3824,7 @@ newSViv(IV i) } SV * -newRV(SV *tmpRef) +newRV_noinc(SV *tmpRef) { dTHR; register SV *sv; @@ -3507,21 +3835,15 @@ newRV(SV *tmpRef) SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); SvTEMP_off(tmpRef); - SvRV(sv) = SvREFCNT_inc(tmpRef); + SvRV(sv) = tmpRef; SvROK_on(sv); return sv; } - - SV * -Perl_newRV_noinc(SV *tmpRef) +newRV(SV *tmpRef) { - register SV *sv; - - sv = newRV(tmpRef); - SvREFCNT_dec(tmpRef); - return sv; + return newRV_noinc(SvREFCNT_inc(tmpRef)); } /* make an exact duplicate of old */ @@ -3562,9 +3884,12 @@ sv_reset(register char *s, HV *stash) register I32 max; char todo[256]; + if (!stash) + return; + if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -3605,7 +3930,7 @@ sv_reset(register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef VMS /* VMS has no environ array */ - if (gv == envgv) + if (gv == PL_envgv) environ[0] = Nullch; #endif } @@ -3635,13 +3960,13 @@ sv_2io(SV *sv) croak(no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); + gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,na)); + croak("Bad filehandle: %s", SvPV(sv,PL_na)); break; } return io; @@ -3684,7 +4009,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV); + gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -3701,7 +4026,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - croak("Unable to create sub named \"%s\"", SvPV(sv,na)); + croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na)); } return GvCVu(gv); } @@ -3713,8 +4038,6 @@ sv_true(register SV *sv) dTHR; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && @@ -3778,7 +4101,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } @@ -3795,7 +4118,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) else { dTHR; croak("Can't coerce %s to string in %s", sv_reftype(sv,0), - op_name[op->op_type]); + op_name[PL_op->op_type]); } } else @@ -3846,7 +4169,7 @@ sv_reftype(SV *sv, int ob) case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; - case SVt_PVFM: return "FORMLINE"; + case SVt_PVFM: return "FORMAT"; default: return "UNKNOWN"; } } @@ -3894,7 +4217,7 @@ newSVrv(SV *rv, char *classname) SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; - sv_check_thinkfirst(rv); + SV_CHECK_THINKFIRST(rv); #ifdef OVERLOAD SvAMAGIC_off(rv); #endif /* OVERLOAD */ @@ -3916,8 +4239,10 @@ newSVrv(SV *rv, char *classname) SV* sv_setref_pv(SV *rv, char *classname, void *pv) { - if (!pv) - sv_setsv(rv, &sv_undef); + if (!pv) { + sv_setsv(rv, &PL_sv_undef); + SvSETMAGIC(rv); + } else sv_setiv(newSVrv(rv,classname), (IV)pv); return rv; @@ -3957,13 +4282,13 @@ sv_bless(SV *sv, HV *stash) croak(no_modify); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) - --sv_objcount; + --PL_sv_objcount; SvREFCNT_dec(SvSTASH(tmpRef)); } } SvOBJECT_on(tmpRef); if (SvTYPE(tmpRef) != SVt_PVIO) - ++sv_objcount; + ++PL_sv_objcount; (void)SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); @@ -3984,6 +4309,10 @@ sv_unglob(SV *sv) 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); @@ -4016,7 +4345,7 @@ sv_untaint(SV *sv) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); if (mg) - mg->mg_length &= ~1; + mg->mg_len &= ~1; } } @@ -4025,7 +4354,7 @@ sv_tainted(SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); - if (mg && ((mg->mg_length & 1) || (mg->mg_length & 2) && mg->mg_obj == sv)) + if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) return TRUE; } return FALSE; @@ -4064,48 +4393,51 @@ sv_setpviv(SV *sv, IV iv) SvCUR(sv) = p - SvPVX(sv); } -#ifdef I_STDARG + +void +sv_setpviv_mg(SV *sv, IV iv) +{ + sv_setpviv(sv,iv); + SvSETMAGIC(sv); +} + void sv_setpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + va_end(args); +} + + void -sv_setpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif +sv_setpvf_mg(SV *sv, const char* pat, ...) { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); + SvSETMAGIC(sv); } -#ifdef I_STDARG void sv_catpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + va_end(args); +} + void -sv_catpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif +sv_catpvf_mg(SV *sv, const char* pat, ...) { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); + SvSETMAGIC(sv); } void @@ -4165,6 +4497,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, STRLEN precis = 0; char esignbuf[4]; + char utf8buf[10]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -4293,6 +4626,16 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto string; case 'c': + if (IN_UTF8) { + if (args) + uv = va_arg(*args, int); + else + uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + + eptr = utf8buf; + elen = uv_to_utf8(eptr, uv) - utf8buf; + goto string; + } if (args) c = va_arg(*args, int); else @@ -4311,8 +4654,19 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, elen = sizeof nullstr - 1; } } - else if (svix < svmax) + else if (svix < svmax) { eptr = SvPVx(svargs[svix++], elen); + if (IN_UTF8) { + if (has_precis && precis < elen) { + I32 p = precis; + sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ + precis = p; + } + if (width) { /* fudge width (can't fudge elen) */ + width += elen - sv_len_utf8(svargs[svix - 1]); + } + } + } goto string; case '_': @@ -4416,6 +4770,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, switch (base) { unsigned dig; case 16: + if (!uv) + alt = FALSE; p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; do { dig = uv & 15; @@ -4442,8 +4798,12 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, break; } elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis && precis > elen) - zeros = precis - elen; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; + } break; /* FLOATING POINT */ @@ -4541,11 +4901,11 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: unknown: - if (!args && dowarn && - (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { + if (!args && PL_dowarn && + (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", - (op->op_type == OP_PRTF) ? "printf" : "sprintf"); + (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); if (c) sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", c & 0xFF); @@ -4605,10 +4965,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, } } -#ifdef DEBUGGING void sv_dump(SV *sv) { +#ifdef DEBUGGING SV *d = sv_newmortal(); char *s; U32 flags; @@ -4782,7 +5142,7 @@ sv_dump(SV *sv) case SVt_PVAV: PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv)); PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); flags = AvFLAGS(sv); @@ -4807,7 +5167,7 @@ sv_dump(SV *sv) break; case SVt_PVCV: if (SvPOK(sv)) - PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); + PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); /* FALL THROUGH */ case SVt_PVFM: PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); @@ -4837,7 +5197,8 @@ sv_dump(SV *sv) case SVt_PVGV: PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", + SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)"); PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); @@ -4871,14 +5232,5 @@ sv_dump(SV *sv) PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } +#endif /* DEBUGGING */ } -#else -void -sv_dump(SV *sv) -{ -} -#endif - - - -