X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=f5a979a1c326d19a28e2ab73291334913c97024c;hb=aebf16e7cdbc86ec766bcfc2294cc17a0e67dc15;hp=8668d1cd7a65c9824affc2d14d1f733f006b6fa7;hpb=8206a063cdc1c193b12df1a45cb3a0ee430b5077;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 8668d1c..f5a979a 100644 --- a/sv.c +++ b/sv.c @@ -40,6 +40,12 @@ # define FAST_SV_GETS #endif +#ifdef PERL_OBJECT +#define FCALL this->*f +#define VTBL this->*vtbl + +#else /* !PERL_OBJECT */ + static IV asIV _((SV* sv)); static UV asUV _((SV* sv)); static SV *more_sv _((void)); @@ -59,20 +65,34 @@ 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 { \ + LOCK_SV_MUTEX; \ (p) = (SV*)safemalloc(sizeof(SV)); \ reg_add(p); \ + UNLOCK_SV_MUTEX; \ } while (0) #define del_SV(p) \ do { \ + LOCK_SV_MUTEX; \ reg_remove(p); \ - free((char*)(p)); \ + Safefree((char*)(p)); \ + UNLOCK_SV_MUTEX; \ } while (0) static SV **registry; @@ -107,8 +127,7 @@ SV* sv; I32 oldsize = regsize; regsize = regsize ? ((regsize << 2) + 1) : 2037; - registry = (SV**)safemalloc(regsize * sizeof(SV*)); - memzero(registry, regsize * sizeof(SV*)); + Newz(707, registry, regsize, SV*); if (oldreg) { I32 i; @@ -154,7 +173,7 @@ U32 size; U32 flags; { if (!(flags & SVf_FAKE)) - free(ptr); + Safefree(ptr); } #else /* ! PURIFY */ @@ -171,32 +190,36 @@ U32 flags; --sv_count; \ } while (0) +/* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ do { \ - MUTEX_LOCK(&sv_mutex); \ (p) = sv_root; \ sv_root = (SV*)SvANY(p); \ ++sv_count; \ - MUTEX_UNLOCK(&sv_mutex); \ } while (0) -#define new_SV(p) \ - if (sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv() +#define new_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv(); \ + UNLOCK_SV_MUTEX; \ + } while (0) #ifdef DEBUGGING -#define del_SV(p) \ - if (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p) +#define del_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (debug & 32768) \ + del_sv(p); \ + else \ + plant_SV(p); \ + UNLOCK_SV_MUTEX; \ + } while (0) -static void -del_sv(p) -SV* p; +STATIC void +del_sv(SV *p) { if (debug & 32768) { SV* sva; @@ -224,10 +247,7 @@ SV* p; #endif /* DEBUGGING */ void -sv_add_arena(ptr, size, flags) -char* ptr; -U32 size; -U32 flags; +sv_add_arena(char *ptr, U32 size, U32 flags) { SV* sva = (SV*)ptr; register SV* sv; @@ -253,8 +273,9 @@ U32 flags; SvFLAGS(sv) = SVTYPEMASK; } -static SV* -more_sv() +/* sv_mutex must be held while calling more_sv() */ +STATIC SV* +more_sv(void) { register SV* sv; @@ -271,9 +292,8 @@ more_sv() return sv; } -static void -visit(f) -SVFUNC f; +STATIC void +visit(SVFUNC f) { SV* sva; SV* sv; @@ -283,16 +303,15 @@ SVFUNC f; svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) - (*f)(sv); + (FCALL)(sv); } } } #endif /* PURIFY */ -static void -do_report_used(sv) -SV* sv; +STATIC void +do_report_used(SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ @@ -302,14 +321,13 @@ SV* sv; } void -sv_report_used() +sv_report_used(void) { - visit(do_report_used); + visit(FUNC_NAME_TO_PTR(do_report_used)); } -static void -do_clean_objs(sv) -SV* sv; +STATIC void +do_clean_objs(SV *sv) { SV* rv; @@ -324,49 +342,54 @@ SV* sv; } #ifndef DISABLE_DESTRUCTOR_KLUDGE -static void -do_clean_named_objs(sv) -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); + } + else if (GvSV(sv)) + do_clean_objs(GvSV(sv)); + } } #endif -static bool in_clean_objs = FALSE; - void -sv_clean_objs() +sv_clean_objs(void) { in_clean_objs = TRUE; #ifndef DISABLE_DESTRUCTOR_KLUDGE - visit(do_clean_named_objs); + visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); #endif - visit(do_clean_objs); + visit(FUNC_NAME_TO_PTR(do_clean_objs)); in_clean_objs = FALSE; } -static void -do_clean_all(sv) -SV* sv; +STATIC void +do_clean_all(SV *sv) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } -static bool in_clean_all = FALSE; - void -sv_clean_all() +sv_clean_all(void) { in_clean_all = TRUE; - visit(do_clean_all); + visit(FUNC_NAME_TO_PTR(do_clean_all)); in_clean_all = FALSE; } void -sv_free_arenas() +sv_free_arenas(void) { SV* sva; SV* svanext; @@ -383,12 +406,16 @@ sv_free_arenas() Safefree((void *)sva); } + if (nice_chunk) + Safefree(nice_chunk); + nice_chunk = Nullch; + nice_chunk_size = 0; sv_arenaroot = 0; sv_root = 0; } -static XPVIV* -new_xiv() +STATIC XPVIV* +new_xiv(void) { IV** xiv; if (xiv_root) { @@ -402,21 +429,21 @@ new_xiv() return more_xiv(); } -static void -del_xiv(p) -XPVIV* p; +STATIC void +del_xiv(XPVIV *p) { IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); *xiv = (IV *)xiv_root; xiv_root = xiv; } -static XPVIV* -more_xiv() +STATIC XPVIV* +more_xiv(void) { register IV** xiv; register IV** xivend; - XPV* ptr = (XPV*)safemalloc(1008); + XPV* ptr; + New(705, ptr, 1008/sizeof(XPV), XPV); ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ xiv_arenaroot = ptr; /* to keep Purify happy */ @@ -432,8 +459,8 @@ more_xiv() return new_xiv(); } -static XPVNV* -new_xnv() +STATIC XPVNV* +new_xnv(void) { double* xnv; if (xnv_root) { @@ -444,21 +471,20 @@ new_xnv() return more_xnv(); } -static void -del_xnv(p) -XPVNV* p; +STATIC void +del_xnv(XPVNV *p) { double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); *(double**)xnv = xnv_root; xnv_root = xnv; } -static XPVNV* -more_xnv() +STATIC XPVNV* +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; @@ -470,8 +496,8 @@ more_xnv() return new_xnv(); } -static XRV* -new_xrv() +STATIC XRV* +new_xrv(void) { XRV* xrv; if (xrv_root) { @@ -482,20 +508,19 @@ new_xrv() return more_xrv(); } -static void -del_xrv(p) -XRV* p; +STATIC void +del_xrv(XRV *p) { p->xrv_rv = (SV*)xrv_root; xrv_root = p; } -static XRV* -more_xrv() +STATIC XRV* +more_xrv(void) { register XRV* xrv; register XRV* xrvend; - xrv_root = (XRV*)safemalloc(1008); + New(712, xrv_root, 1008/sizeof(XRV), XRV); xrv = xrv_root; xrvend = &xrv[1008 / sizeof(XRV) - 1]; while (xrv < xrvend) { @@ -506,8 +531,8 @@ more_xrv() return new_xrv(); } -static XPV* -new_xpv() +STATIC XPV* +new_xpv(void) { XPV* xpv; if (xpv_root) { @@ -518,20 +543,19 @@ new_xpv() return more_xpv(); } -static void -del_xpv(p) -XPV* p; +STATIC void +del_xpv(XPV *p) { p->xpv_pv = (char*)xpv_root; xpv_root = p; } -static XPV* -more_xpv() +STATIC XPV* +more_xpv(void) { register XPV* xpv; register XPV* xpvend; - xpv_root = (XPV*)safemalloc(1008); + New(713, xpv_root, 1008/sizeof(XPV), XPV); xpv = xpv_root; xpvend = &xpv[1008 / sizeof(XPV) - 1]; while (xpv < xpvend) { @@ -544,73 +568,85 @@ more_xpv() #ifdef PURIFY #define new_XIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XIV(p) free((char*)p) +#define del_XIV(p) Safefree((char*)p) #else #define new_XIV() (void*)new_xiv() -#define del_XIV(p) del_xiv(p) +#define del_XIV(p) del_xiv((XPVIV*) p) #endif #ifdef PURIFY #define new_XNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XNV(p) free((char*)p) +#define del_XNV(p) Safefree((char*)p) #else #define new_XNV() (void*)new_xnv() -#define del_XNV(p) del_xnv(p) +#define del_XNV(p) del_xnv((XPVNV*) p) #endif #ifdef PURIFY #define new_XRV() (void*)safemalloc(sizeof(XRV)) -#define del_XRV(p) free((char*)p) +#define del_XRV(p) Safefree((char*)p) #else #define new_XRV() (void*)new_xrv() -#define del_XRV(p) del_xrv(p) +#define del_XRV(p) del_xrv((XRV*) p) #endif #ifdef PURIFY #define new_XPV() (void*)safemalloc(sizeof(XPV)) -#define del_XPV(p) free((char*)p) +#define del_XPV(p) Safefree((char*)p) #else #define new_XPV() (void*)new_xpv() -#define del_XPV(p) del_xpv(p) +#define del_XPV(p) del_xpv((XPV *)p) #endif -#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) free((char*)p) - -#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) free((char*)p) - -#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) free((char*)p) - -#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) free((char*)p) - -#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) free((char*)p) - -#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) free((char*)p) - -#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) free((char*)p) - -#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) free((char*)p) - -#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) free((char*)p) - -#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) free((char*)p) - -#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) free((char*)p) +#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(sv, mt) -register SV* sv; -U32 mt; +sv_upgrade(register SV *sv, U32 mt) { char* pv; U32 cur; @@ -790,7 +826,7 @@ 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; @@ -883,11 +919,10 @@ U32 mt; return TRUE; } -#ifdef DEBUGGING char * -sv_peek(sv) -register SV *sv; +sv_peek(SV *sv) { +#ifdef DEBUGGING SV *t = sv_newmortal(); STRLEN prevlen; int unref = 0; @@ -955,7 +990,7 @@ register SV *sv; case SVt_NULL: sv_catpv(t, "UNDEF"); - return tokenbuf; + goto finish; case SVt_IV: sv_catpv(t, "IV"); break; @@ -1029,12 +1064,13 @@ register SV *sv; sv_catpv(t, ")"); } return SvPV(t, na); +#else /* DEBUGGING */ + return ""; +#endif /* DEBUGGING */ } -#endif int -sv_backoff(sv) -register SV *sv; +sv_backoff(register SV *sv) { assert(SvOOK(sv)); if (SvIVX(sv)) { @@ -1049,12 +1085,10 @@ register SV *sv; } char * -sv_grow(sv,newlen) -register SV *sv; #ifndef DOSISH -register I32 newlen; +sv_grow(register SV *sv, register I32 newlen) #else -unsigned long newlen; +sv_grow(SV* sv, unsigned long newlen) #endif { register char *s; @@ -1076,6 +1110,10 @@ 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); @@ -1091,11 +1129,9 @@ unsigned long newlen; } void -sv_setiv(sv,i) -register SV *sv; -IV i; +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); @@ -1131,9 +1167,14 @@ IV i; } void -sv_setuv(sv,u) -register SV *sv; -UV u; +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) sv_setiv(sv, u); @@ -1142,17 +1183,21 @@ UV u; } void -sv_setnv(sv,num) -register SV *sv; -double num; +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: @@ -1187,9 +1232,15 @@ double num; SvTAINT(sv); } -static void -not_a_number(sv) -SV *sv; +void +sv_setnv_mg(register SV *sv, double num) +{ + sv_setnv(sv,num); + SvSETMAGIC(sv); +} + +STATIC void +not_a_number(SV *sv) { dTHR; char tmpbuf[64]; @@ -1244,8 +1295,7 @@ SV *sv; } IV -sv_2iv(sv) -register SV *sv; +sv_2iv(register SV *sv) { if (!sv) return 0; @@ -1262,9 +1312,11 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { - dTHR; /* just for localizing */ - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (!localizing) + warn(warn_uninit); + } return 0; } } @@ -1325,8 +1377,7 @@ register SV *sv; } UV -sv_2uv(sv) -register SV *sv; +sv_2uv(register SV *sv) { if (!sv) return 0; @@ -1339,9 +1390,11 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { - dTHR; /* just for localizing */ - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (!localizing) + warn(warn_uninit); + } return 0; } } @@ -1385,9 +1438,11 @@ register SV *sv; SvUVX(sv) = asUV(sv); } else { - dTHR; /* just for localizing */ - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (!localizing) + warn(warn_uninit); + } return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", @@ -1396,8 +1451,7 @@ register SV *sv; } double -sv_2nv(sv) -register SV *sv; +sv_2nv(register SV *sv) { if (!sv) return 0.0; @@ -1414,9 +1468,11 @@ register SV *sv; if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { - dTHR; /* just for localizing */ - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (!localizing) + warn(warn_uninit); + } return 0; } } @@ -1478,9 +1534,8 @@ register SV *sv; return SvNVX(sv); } -static IV -asIV(sv) -SV *sv; +STATIC IV +asIV(SV *sv) { I32 numtype = looks_like_number(sv); double d; @@ -1497,14 +1552,15 @@ SV *sv; return (IV) U_V(d); } -static UV -asUV(sv) -SV *sv; +STATIC UV +asUV(SV *sv) { I32 numtype = looks_like_number(sv); +#ifdef HAS_STRTOUL if (numtype == 1) - return atol(SvPVX(sv)); + return strtoul(SvPVX(sv), Null(char**), 10); +#endif if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); @@ -1512,8 +1568,7 @@ SV *sv; } I32 -looks_like_number(sv) -SV *sv; +looks_like_number(SV *sv) { register char *s; register char *send; @@ -1592,13 +1647,12 @@ SV *sv; } char * -sv_2pv(sv, lp) -register SV *sv; -STRLEN *lp; +sv_2pv(register SV *sv, STRLEN *lp) { register char *s; int olderrno; SV *tsv; + char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ if (!sv) { *lp = 0; @@ -1611,20 +1665,22 @@ STRLEN *lp; return SvPVX(sv); } if (SvIOKp(sv)) { - (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } if (SvNOKp(sv)) { SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } if (!SvROK(sv)) { - dTHR; /* just for localizing */ - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + dTHR; + if (!localizing) + warn(warn_uninit); + } *lp = 0; return ""; } @@ -1655,7 +1711,7 @@ STRLEN *lp; 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; } @@ -1673,12 +1729,12 @@ STRLEN *lp; if (SvREADONLY(sv)) { if (SvNOKp(sv)) { SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } if (SvIOKp(sv)) { - (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } @@ -1688,8 +1744,7 @@ STRLEN *lp; 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); @@ -1717,12 +1772,17 @@ STRLEN *lp; #endif } else if (SvIOKp(sv)) { + U32 oldIOK = SvIOK(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); olderrno = errno; /* some Xenix systems wipe out errno here */ - sv_setpvf(sv, "%Vd", SvIVX(sv)); + sv_setpviv(sv, SvIVX(sv)); errno = olderrno; s = SvEND(sv); + if (oldIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); } else { dTHR; @@ -1743,7 +1803,7 @@ STRLEN *lp; tokensaveref: if (!tsv) - tsv = newSVpv(tokenbuf, 0); + tsv = newSVpv(tmpbuf, 0); sv_2mortal(tsv); *lp = SvCUR(tsv); return SvPVX(tsv); @@ -1758,8 +1818,8 @@ STRLEN *lp; len = SvCUR(tsv); } else { - t = tokenbuf; - len = strlen(tokenbuf); + t = tmpbuf; + len = strlen(tmpbuf); } #ifdef FIXNEGATIVEZERO if (len == 2 && t[0] == '-' && t[1] == '0') { @@ -1779,8 +1839,7 @@ STRLEN *lp; /* This function is only called on magical items */ bool -sv_2bool(sv) -register SV *sv; +sv_2bool(register SV *sv) { if (SvGMAGICAL(sv)) mg_get(sv); @@ -1826,9 +1885,7 @@ register SV *sv; */ void -sv_setsv(dstr,sstr) -SV *dstr; -register SV *sstr; +sv_setsv(SV *dstr, register SV *sstr) { dTHR; register U32 sflags; @@ -1837,7 +1894,7 @@ register SV *sstr; if (sstr == dstr) return; - sv_check_thinkfirst(dstr); + SV_CHECK_THINKFIRST(dstr); if (!sstr) sstr = &sv_undef; stype = SvTYPE(sstr); @@ -1857,8 +1914,11 @@ register SV *sstr; switch (stype) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: if (dtype != SVt_IV && dtype < SVt_PVIV) { if (dtype < SVt_IV) @@ -1905,11 +1965,6 @@ register SV *sstr; if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; - - case SVt_PVLV: - sv_upgrade(dstr, SVt_PVLV); - break; - case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1929,13 +1984,13 @@ 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 + else if (curstackinfo->si_type == SI_SORT && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); @@ -1960,8 +2015,10 @@ 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); @@ -2022,19 +2079,29 @@ 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 && + if (curstackinfo->si_type == SI_SORT && 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 (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); @@ -2104,6 +2171,7 @@ register SV *sstr; */ if (SvTEMP(sstr) && /* slated for free anyway? */ + SvREFCNT(sstr) == 1 && /* and no other references to it? */ !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ @@ -2157,20 +2225,30 @@ register SV *sstr; SvIVX(dstr) = SvIVX(sstr); } else { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (dowarn) + warn("Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } void -sv_setpvn(sv,ptr,len) -register SV *sv; -register const char *ptr; -register STRLEN len; +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; @@ -2179,24 +2257,31 @@ 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_setpv(sv,ptr) -register SV *sv; -register const char *ptr; +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; @@ -2206,8 +2291,9 @@ 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); @@ -2216,14 +2302,17 @@ register const char *ptr; } void -sv_usepvn(sv,ptr,len) -register SV *sv; -register char *ptr; -register STRLEN len; +sv_setpv_mg(register SV *sv, register const char *ptr) { - sv_check_thinkfirst(sv); - if (!SvUPGRADE(sv, SVt_PV)) - return; + sv_setpv(sv,ptr); + SvSETMAGIC(sv); +} + +void +sv_usepvn(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; @@ -2239,31 +2328,35 @@ register STRLEN len; SvTAINT(sv); } -static void -sv_check_thinkfirst(sv) -register SV *sv; +void +sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - dTHR; - if (curcop != &compiling) - croak(no_modify); - } - if (SvROK(sv)) - sv_unref(sv); + sv_usepvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +STATIC void +sv_check_thinkfirst(register SV *sv) +{ + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling) + croak(no_modify); } + if (SvROK(sv)) + sv_unref(sv); } void -sv_chop(sv,ptr) /* like set but assuming ptr is in sv */ -register SV *sv; -register char *ptr; +sv_chop(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); + SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -2280,10 +2373,7 @@ register char *ptr; } void -sv_catpvn(sv,ptr,len) -register SV *sv; -register char *ptr; -register STRLEN len; +sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) { STRLEN tlen; char *junk; @@ -2300,9 +2390,14 @@ register STRLEN len; } void -sv_catsv(dstr,sstr) -SV *dstr; -register SV *sstr; +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; STRLEN len; @@ -2313,9 +2408,14 @@ register SV *sstr; } void -sv_catpv(sv,ptr) -register SV *sv; -register char *ptr; +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; STRLEN tlen; @@ -2334,14 +2434,15 @@ 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(len) -#endif -STRLEN len; +newSV(STRLEN len) { register SV *sv; @@ -2359,12 +2460,7 @@ STRLEN len; /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ void -sv_magic(sv, obj, how, name, namlen) -register SV *sv; -SV *obj; -int how; -char *name; -I32 namlen; +sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) { MAGIC* mg; @@ -2381,14 +2477,13 @@ I32 namlen; } } else { - if (!SvUPGRADE(sv, SVt_PVMG)) - return; + (void)SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#') + if (!obj || obj == sv || how == '#' || how == 'r') mg->mg_obj = obj; else { dTHR; @@ -2400,10 +2495,8 @@ I32 namlen; if (name) if (namlen >= 0) mg->mg_ptr = savepvn(name, namlen); - else if (namlen == HEf_SVKEY) { - dTHR; /* just for SvREFCNT_inc */ + else if (namlen == HEf_SVKEY) mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); - } switch (how) { case 0: @@ -2468,6 +2561,9 @@ I32 namlen; case 'q': mg->mg_virtual = &vtbl_packelem; break; + case 'r': + mg->mg_virtual = &vtbl_regexp; + break; case 'S': mg->mg_virtual = &vtbl_sig; break; @@ -2514,9 +2610,7 @@ I32 namlen; } int -sv_unmagic(sv, type) -SV* sv; -int type; +sv_unmagic(SV *sv, int type) { MAGIC* mg; MAGIC** mgp; @@ -2527,8 +2621,8 @@ int type; if (mg->mg_type == type) { MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - (*vtbl->svt_free)(sv, mg); + if (vtbl && (vtbl->svt_free != NULL)) + (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2550,22 +2644,24 @@ int type; } void -sv_insert(bigstr,offset,len,little,littlelen) -SV *bigstr; -STRLEN offset; -STRLEN len; -char *little; -STRLEN littlelen; +sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) { register char *big; register char *mid; register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + 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 */ @@ -2633,12 +2729,10 @@ STRLEN littlelen; /* make sv point to what nstr did */ void -sv_replace(sv,nsv) -register SV *sv; -register SV *nsv; +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)) { @@ -2661,73 +2755,63 @@ register SV *nsv; } void -sv_clear(sv) -register SV *sv; +sv_clear(register SV *sv) { + HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { dTHR; if (defstash) { /* Still have a symbol table? */ - dTHR; - dSP; + djSP; GV* destructor; + SV tmpref; - ENTER; - SAVEFREESV(SvSTASH(sv)); - - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); - if (destructor) { - SV ref; - - Zero(&ref, 1, SV); - sv_upgrade(&ref, SVt_RV); - SvRV(&ref) = SvREFCNT_inc(sv); - SvROK_on(&ref); - SvREFCNT(&ref) = 1; /* Fake, but otherwise - creating+destructing a ref - leads to disaster. */ - - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(&ref); - PUTBACK; - perl_call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); - del_XRV(SvANY(&ref)); - SvREFCNT(sv)--; - } + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; - LEAVE; + do { + stash = SvSTASH(sv); + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { + ENTER; + PUSHSTACK(SI_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 */ } if (SvREFCNT(sv)) { - SV *ret; - if ( perldb - && (ret = perl_get_sv("DB::ret", FALSE)) - && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) { - /* Debugger is prone to dangling references. */ - SvRV(ret) = 0; - SvROK_off(ret); - SvREFCNT(sv) = 0; - } - else { if (in_clean_objs) croak("DESTROY created new reference to dead object"); /* DESTROY gave object new lease on life */ return; - } } } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) mg_free(sv); + stash = NULL; switch (SvTYPE(sv)) { case SVt_PVIO: if (IoIFP(sv) != PerlIO_stdin() && @@ -2753,6 +2837,11 @@ register SV *sv; 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: @@ -2814,7 +2903,13 @@ 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; @@ -2830,18 +2925,18 @@ register SV *sv; } SV * -sv_newref(sv) -SV* sv; +sv_newref(SV *sv) { if (sv) - SvREFCNT(sv)++; + ATOMIC_INC(SvREFCNT(sv)); return sv; } void -sv_free(sv) -SV *sv; +sv_free(SV *sv) { + int refcount_is_zero; + if (!sv) return; if (SvREADONLY(sv)) { @@ -2856,7 +2951,8 @@ SV *sv; 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)) { @@ -2870,8 +2966,7 @@ SV *sv; } STRLEN -sv_len(sv) -register SV *sv; +sv_len(register SV *sv) { char *junk; STRLEN len; @@ -2880,16 +2975,14 @@ register SV *sv; return 0; if (SvGMAGICAL(sv)) - len = mg_len(sv); + len = mg_length(sv); else junk = SvPV(sv, len); return len; } I32 -sv_eq(str1,str2) -register SV *str1; -register SV *str2; +sv_eq(register SV *str1, register SV *str2) { char *pv1; STRLEN cur1; @@ -2915,14 +3008,12 @@ register SV *str2; } I32 -sv_cmp(str1, str2) -register SV *str1; -register SV *str2; +sv_cmp(register SV *str1, register SV *str2) { STRLEN cur1 = 0; - char *pv1 = str1 ? SvPV(str1, cur1) : NULL; + char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL; STRLEN cur2 = 0; - char *pv2 = str2 ? SvPV(str2, cur2) : NULL; + char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL; I32 retval; if (!cur1) @@ -2943,9 +3034,7 @@ register SV *str2; } I32 -sv_cmp_locale(sv1, sv2) -register SV *sv1; -register SV *sv2; +sv_cmp_locale(register SV *sv1, register SV *sv2) { #ifdef USE_LOCALE_COLLATE @@ -2957,9 +3046,9 @@ register SV *sv2; goto raw_compare; len1 = 0; - pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL; + pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL; len2 = 0; - pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL; + pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL; if (!pv1 || !len1) { if (pv2 && len2) @@ -3000,13 +3089,11 @@ register SV *sv2; * according to the locale settings. */ char * -sv_collxfrm(sv, nxp) - SV *sv; - STRLEN *nxp; +sv_collxfrm(SV *sv, STRLEN *nxp) { MAGIC *mg; - mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL; + mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { char *s, *xf; STRLEN len, xlen; @@ -3018,7 +3105,7 @@ sv_collxfrm(sv, nxp) if (SvREADONLY(sv)) { SAVEFREEPV(xf); *nxp = xlen; - return xf; + return xf + sizeof(collation_ix); } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); @@ -3048,11 +3135,9 @@ sv_collxfrm(sv, nxp) #endif /* USE_LOCALE_COLLATE */ char * -sv_gets(sv,fp,append) -register SV *sv; -register PerlIO *fp; -I32 append; +sv_gets(register SV *sv, register PerlIO *fp, I32 append) { + dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -3060,9 +3145,8 @@ 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)) { @@ -3223,8 +3307,8 @@ thats_really_all_folks: *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: done, len=%d, string=|%.*s|\n", - SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); + "Screamer: done, len=%ld, string=|%.*s|\n", + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv))); } else { @@ -3284,13 +3368,16 @@ screamer2: } } +#ifdef WIN32 + win32_strip_return(sv); +#endif + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } void -sv_inc(sv) -register SV *sv; +sv_inc(register SV *sv) { register char *d; int flags; @@ -3368,8 +3455,7 @@ register SV *sv; } void -sv_dec(sv) -register SV *sv; +sv_dec(register SV *sv) { int flags; @@ -3421,8 +3507,8 @@ register SV *sv; * hopefully we won't free it until it has been assigned to a * permanent location. */ -static void -sv_mortalgrow() +STATIC void +sv_mortalgrow(void) { dTHR; tmps_max += (tmps_max < 512) ? 128 : 512; @@ -3430,8 +3516,7 @@ sv_mortalgrow() } SV * -sv_mortalcopy(oldstr) -SV *oldstr; +sv_mortalcopy(SV *oldstr) { dTHR; register SV *sv; @@ -3449,7 +3534,7 @@ SV *oldstr; } SV * -sv_newmortal() +sv_newmortal(void) { dTHR; register SV *sv; @@ -3467,8 +3552,7 @@ sv_newmortal() /* same thing without the copying */ SV * -sv_2mortal(sv) -register SV *sv; +sv_2mortal(register SV *sv) { dTHR; if (!sv) @@ -3483,9 +3567,7 @@ register SV *sv; } SV * -newSVpv(s,len) -char *s; -STRLEN len; +newSVpv(char *s, STRLEN len) { register SV *sv; @@ -3499,16 +3581,21 @@ 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; @@ -3517,11 +3604,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; @@ -3529,8 +3612,7 @@ va_dcl SV * -newSVnv(n) -double n; +newSVnv(double n) { register SV *sv; @@ -3543,8 +3625,7 @@ double n; } SV * -newSViv(i) -IV i; +newSViv(IV i) { register SV *sv; @@ -3557,8 +3638,7 @@ IV i; } SV * -newRV(ref) -SV *ref; +newRV(SV *tmpRef) { dTHR; register SV *sv; @@ -3568,30 +3648,28 @@ SV *ref; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); - SvTEMP_off(ref); - SvRV(sv) = SvREFCNT_inc(ref); + SvTEMP_off(tmpRef); + SvRV(sv) = SvREFCNT_inc(tmpRef); SvROK_on(sv); return sv; } -#ifdef CRIPPLED_CC + + SV * -newRV_noinc(ref) -SV *ref; +Perl_newRV_noinc(SV *tmpRef) { register SV *sv; - sv = newRV(ref); - SvREFCNT_dec(ref); + sv = newRV(tmpRef); + SvREFCNT_dec(tmpRef); return sv; } -#endif /* CRIPPLED_CC */ /* make an exact duplicate of old */ SV * -newSVsv(old) -register SV *old; +newSVsv(register SV *old) { register SV *sv; @@ -3616,9 +3694,7 @@ register SV *old; } void -sv_reset(s,stash) -register char *s; -HV *stash; +sv_reset(register char *s, HV *stash) { register HE *entry; register GV *gv; @@ -3628,9 +3704,12 @@ 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; } @@ -3681,8 +3760,7 @@ HV *stash; } IO* -sv_2io(sv) -SV *sv; +sv_2io(SV *sv) { IO* io; GV* gv; @@ -3715,11 +3793,7 @@ SV *sv; } CV * -sv_2cv(sv, st, gvp, lref) -SV *sv; -HV **st; -GV **gvp; -I32 lref; +sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) { GV *gv; CV *cv; @@ -3778,21 +3852,18 @@ I32 lref; } } -#ifndef SvTRUE I32 -SvTRUE(sv) -register SV *sv; +sv_true(register SV *sv) { + dTHR; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); if (SvPOK(sv)) { - register XPV* Xpv; - if ((Xpv = (XPV*)SvANY(sv)) && - (*Xpv->xpv_pv > '0' || - Xpv->xpv_cur > 1 || - (Xpv->xpv_cur && *Xpv->xpv_pv != '0'))) + 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; @@ -3808,46 +3879,33 @@ register SV *sv; } } } -#endif /* !SvTRUE */ -#ifndef SvIV IV -SvIV(sv) -register SV *sv; +sv_iv(register SV *sv) { if (SvIOK(sv)) return SvIVX(sv); return sv_2iv(sv); } -#endif /* !SvIV */ -#ifndef SvUV UV -SvUV(sv) -register SV *sv; +sv_uv(register SV *sv) { if (SvIOK(sv)) return SvUVX(sv); return sv_2uv(sv); } -#endif /* !SvUV */ -#ifndef SvNV double -SvNV(sv) -register SV *sv; +sv_nv(register SV *sv) { if (SvNOK(sv)) return SvNVX(sv); return sv_2nv(sv); } -#endif /* !SvNV */ -#ifdef CRIPPLED_CC char * -sv_pvn(sv, lp) -SV *sv; -STRLEN *lp; +sv_pvn(SV *sv, STRLEN *lp) { if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -3855,12 +3913,9 @@ STRLEN *lp; } return sv_2pv(sv, lp); } -#endif char * -sv_pvn_force(sv, lp) -SV *sv; -STRLEN *lp; +sv_pvn_force(SV *sv, STRLEN *lp) { char *s; @@ -3910,9 +3965,7 @@ STRLEN *lp; } char * -sv_reftype(sv, ob) -SV* sv; -int ob; +sv_reftype(SV *sv, int ob) { if (ob && SvOBJECT(sv)) return HvNAME(SvSTASH(sv)); @@ -3936,15 +3989,14 @@ int ob; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; - case SVt_PVFM: return "FORMLINE"; + case SVt_PVFM: return "FORMAT"; default: return "UNKNOWN"; } } } int -sv_isobject(sv) -SV *sv; +sv_isobject(SV *sv) { if (!sv) return 0; @@ -3959,9 +4011,7 @@ SV *sv; } int -sv_isa(sv, name) -SV *sv; -char *name; +sv_isa(SV *sv, char *name) { if (!sv) return 0; @@ -3977,9 +4027,7 @@ char *name; } SV* -newSVrv(rv, classname) -SV *rv; -char *classname; +newSVrv(SV *rv, char *classname) { dTHR; SV *sv; @@ -3988,7 +4036,16 @@ char *classname; SvANY(sv) = 0; SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; - sv_upgrade(rv, SVt_RV); + + SV_CHECK_THINKFIRST(rv); +#ifdef OVERLOAD + SvAMAGIC_off(rv); +#endif /* OVERLOAD */ + + if (SvTYPE(rv) < SVt_RV) + sv_upgrade(rv, SVt_RV); + + (void)SvOK_off(rv); SvRV(rv) = SvREFCNT_inc(sv); SvROK_on(rv); @@ -4000,76 +4057,60 @@ char *classname; } SV* -sv_setref_pv(rv, classname, pv) -SV *rv; -char *classname; -void* pv; +sv_setref_pv(SV *rv, char *classname, void *pv) { - if (!pv) + if (!pv) { sv_setsv(rv, &sv_undef); + SvSETMAGIC(rv); + } else sv_setiv(newSVrv(rv,classname), (IV)pv); return rv; } SV* -sv_setref_iv(rv, classname, iv) -SV *rv; -char *classname; -IV iv; +sv_setref_iv(SV *rv, char *classname, IV iv) { sv_setiv(newSVrv(rv,classname), iv); return rv; } SV* -sv_setref_nv(rv, classname, nv) -SV *rv; -char *classname; -double nv; +sv_setref_nv(SV *rv, char *classname, double nv) { sv_setnv(newSVrv(rv,classname), nv); return rv; } SV* -sv_setref_pvn(rv, classname, pv, n) -SV *rv; -char *classname; -char* pv; -I32 n; +sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n) { sv_setpvn(newSVrv(rv,classname), pv, n); return rv; } SV* -sv_bless3(sv,stash,zaptilde) -SV* sv; -HV* stash; -bool zaptilde; +sv_bless(SV *sv, HV *stash) { dTHR; - SV *ref; + SV *tmpRef; if (!SvROK(sv)) croak("Can't bless non-reference value"); - ref = SvRV(sv); - if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) { - if (SvREADONLY(ref)) + tmpRef = SvRV(sv); + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(tmpRef)) croak(no_modify); - if (SvOBJECT(ref)) { - if (SvTYPE(ref) != SVt_PVIO) + if (SvOBJECT(tmpRef)) { + if (SvTYPE(tmpRef) != SVt_PVIO) --sv_objcount; - if (zaptilde && SvRMAGICAL(ref)) - sv_unmagic(ref, '~'); /* stop cross-class pointer forgery */ - SvREFCNT_dec(SvSTASH(ref)); + SvREFCNT_dec(SvSTASH(tmpRef)); } } - SvOBJECT_on(ref); - if (SvTYPE(ref) != SVt_PVIO) + SvOBJECT_on(tmpRef); + if (SvTYPE(tmpRef) != SVt_PVIO) ++sv_objcount; - (void)SvUPGRADE(ref, SVt_PVMG); - SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); + (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); #ifdef OVERLOAD if (Gv_AMG(stash)) @@ -4081,22 +4122,17 @@ bool zaptilde; return sv; } -SV* -sv_bless(sv,stash) -SV* sv; -HV* stash; -{ - return sv_bless3(sv, stash, FALSE); -} - -static void -sv_unglob(sv) -SV* sv; +STATIC void +sv_unglob(SV *sv) { assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); if (GvGP(sv)) gp_free((GV*)sv); + if (GvSTASH(sv)) { + SvREFCNT_dec(GvSTASH(sv)); + GvSTASH(sv) = Nullhv; + } sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); GvMULTI_off(sv); @@ -4105,8 +4141,7 @@ SV* sv; } void -sv_unref(sv) -SV* sv; +sv_unref(SV *sv) { SV* rv = SvRV(sv); @@ -4119,15 +4154,13 @@ SV* sv; } void -sv_taint(sv) -SV *sv; +sv_taint(SV *sv) { sv_magic((sv), Nullsv, 't', Nullch, 0); } void -sv_untaint(sv) -SV *sv; +sv_untaint(SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); @@ -4137,8 +4170,7 @@ SV *sv; } bool -sv_tainted(sv) -SV *sv; +sv_tainted(SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); @@ -4148,73 +4180,95 @@ SV *sv; return FALSE; } -#ifdef I_STDARG +void +sv_setpviv(SV *sv, IV iv) +{ + STRLEN len; + char buf[TYPE_DIGITS(UV)]; + char *ptr = buf + sizeof(buf); + int sign; + UV uv; + char *p; + + sv_setpvn(sv, "", 0); + if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (uv % 10); + } while (uv /= 10); + len = (buf + sizeof(buf)) - ptr; + /* taking advantage of SvCUR(sv) == 0 */ + SvGROW(sv, sign + len + 1); + p = SvPVX(sv); + if (sign) + *p++ = '-'; + memcpy(p, ptr, len); + p += len; + *p = '\0'; + SvCUR(sv) = p - SvPVX(sv); +} + + +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 -sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) - SV *sv; - const char *pat; - STRLEN patlen; - va_list *args; - SV **svargs; - I32 svmax; - bool *used_locale; +sv_vsetpvfn(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); } void -sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) - SV *sv; - const char *pat; - STRLEN patlen; - va_list *args; - SV **svargs; - I32 svmax; - bool *used_locale; +sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { dTHR; char *p; @@ -4514,6 +4568,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) switch (base) { unsigned dig; case 16: + if (!uv) + alt = FALSE; p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; do { dig = uv & 15; @@ -4540,8 +4596,12 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) 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 */ @@ -4594,6 +4654,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) } if (fill == '0') *--eptr = fill; + if (left) + *--eptr = '-'; if (plus) *--eptr = plus; if (alt) @@ -4649,17 +4711,28 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) sv_catpv(msg, "end of string"); warn("%_", msg); /* yes, this is reentrant */ } - /* output mangled stuff */ + + /* output mangled stuff ... */ + if (c == '\0') + --q; eptr = p; elen = q - p; - break; + + /* ... 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" */ } have = esignlen + zeros + elen; need = (have > width ? have : width); gap = need - have; - SvGROW(sv, SvLEN(sv) + need); + SvGROW(sv, SvCUR(sv) + need + 1); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) @@ -4690,11 +4763,10 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) } } -#ifdef DEBUGGING void -sv_dump(sv) -SV* sv; +sv_dump(SV *sv) { +#ifdef DEBUGGING SV *d = sv_newmortal(); char *s; U32 flags; @@ -4765,6 +4837,10 @@ SV* sv; sv_catpv(d, " ),"); } } + case SVt_PVBM: + if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); + if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); + break; } if (*(SvEND(d) - 1) == ',') @@ -4864,7 +4940,7 @@ 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); @@ -4919,7 +4995,8 @@ 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)); @@ -4953,11 +5030,5 @@ SV* sv; PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } +#endif /* DEBUGGING */ } -#else -void -sv_dump(sv) -SV* sv; -{ -} -#endif