X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=9f5e5059ca20707a3e3e344dd75215fa2b4843b9;hb=c6ecf61fd8db79f1fc1b90463b6c61a4267ab923;hp=f97c5646bfe0473cf77ae13b708d6aec5755623d;hpb=16d20bd98cd29be76029ebf04027a7edd34d817b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f97c564..9f5e505 100644 --- a/sv.c +++ b/sv.c @@ -14,6 +14,13 @@ #include "EXTERN.h" #include "perl.h" +#ifdef OVR_DBL_DIG +/* Use an overridden DBL_DIG */ +# ifdef DBL_DIG +# undef DBL_DIG +# endif +# define DBL_DIG OVR_DBL_DIG +#else /* The following is all to get DBL_DIG, in order to pick a nice default value for printing floating point numbers in Gconvert. (see config.h) @@ -27,13 +34,17 @@ #ifndef HAS_DBL_DIG #define DBL_DIG 15 /* A guess that works lots of places */ #endif +#endif + +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__) +# define FAST_SV_GETS +#endif static SV *more_sv _((void)); static XPVIV *more_xiv _((void)); static XPVNV *more_xnv _((void)); static XPV *more_xpv _((void)); static XRV *more_xrv _((void)); -static SV *new_sv _((void)); static XPVIV *new_xiv _((void)); static XPVNV *new_xnv _((void)); static XPV *new_xpv _((void)); @@ -43,58 +54,153 @@ static void del_xnv _((XPVNV* p)); static void del_xpv _((XPV* p)); static void del_xrv _((XRV* p)); static void sv_mortalgrow _((void)); - static void sv_unglob _((SV* sv)); +typedef void (*SVFUNC) _((SV*)); + #ifdef PURIFY -#define new_SV() sv = (SV*)safemalloc(sizeof(SV)) -#define del_SV(p) free((char*)p) +#define new_SV(p) \ + do { \ + (p) = (SV*)safemalloc(sizeof(SV)); \ + reg_add(p); \ + } while (0) -#else +#define del_SV(p) \ + do { \ + reg_remove(p); \ + free((char*)(p)); \ + } while (0) + +static SV **registry; +static I32 regsize; + +#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) + +#define REG_REPLACE(sv,a,b) \ + do { \ + void* p = sv->sv_any; \ + I32 h = REGHASH(sv, regsize); \ + I32 i = h; \ + while (registry[i] != (a)) { \ + if (++i >= regsize) \ + i = 0; \ + if (i == h) \ + die("SV registry bug"); \ + } \ + registry[i] = (b); \ + } while (0) + +#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) +#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) -#define new_SV() \ - if (sv_root) { \ - sv = sv_root; \ - sv_root = (SV*)SvANY(sv); \ - ++sv_count; \ - } \ - else \ - sv = more_sv(); +static void +reg_add(sv) +SV* sv; +{ + if (sv_count >= (regsize >> 1)) + { + SV **oldreg = registry; + I32 oldsize = regsize; -static SV* -new_sv() + regsize = regsize ? ((regsize << 2) + 1) : 2037; + registry = (SV**)safemalloc(regsize * sizeof(SV*)); + memzero(registry, regsize * sizeof(SV*)); + + if (oldreg) { + I32 i; + + for (i = 0; i < oldsize; ++i) { + SV* oldsv = oldreg[i]; + if (oldsv) + REG_ADD(oldsv); + } + Safefree(oldreg); + } + } + + REG_ADD(sv); + ++sv_count; +} + +static void +reg_remove(sv) +SV* sv; { - SV* sv; - if (sv_root) { - sv = sv_root; - sv_root = (SV*)SvANY(sv); - ++sv_count; - return sv; + REG_REMOVE(sv); + --sv_count; +} + +static void +visit(f) +SVFUNC f; +{ + I32 i; + + for (i = 0; i < regsize; ++i) { + SV* sv = registry[i]; + if (sv) + (*f)(sv); } - return more_sv(); } +void +sv_add_arena(ptr, size, flags) +char* ptr; +U32 size; +U32 flags; +{ + if (!(flags & SVf_FAKE)) + free(ptr); +} + +#else /* ! PURIFY */ + +/* + * "A time to plant, and a time to uproot what was planted..." + */ + +#define plant_SV(p) \ + do { \ + SvANY(p) = (void *)sv_root; \ + SvFLAGS(p) = SVTYPEMASK; \ + sv_root = (p); \ + --sv_count; \ + } while (0) + +#define uproot_SV(p) \ + do { \ + (p) = sv_root; \ + sv_root = (SV*)SvANY(p); \ + ++sv_count; \ + } while (0) + +#define new_SV(p) \ + if (sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv() + #ifdef DEBUGGING + #define del_SV(p) \ if (debug & 32768) \ del_sv(p); \ - else { \ - SvANY(p) = (void *)sv_root; \ - sv_root = p; \ - --sv_count; \ - } + else \ + plant_SV(p) static void del_sv(p) SV* p; { if (debug & 32768) { + SV* sva; SV* sv; SV* svend; int ok = 0; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(svend)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) ok = 1; } @@ -103,97 +209,169 @@ SV* p; return; } } - SvANY(p) = (void *) sv_root; - sv_root = p; - --sv_count; + plant_SV(p); } -#else -#define del_SV(p) \ - SvANY(p) = (void *)sv_root; \ - sv_root = p; \ - --sv_count; -#endif +#else /* ! DEBUGGING */ -static SV* -more_sv() +#define del_SV(p) plant_SV(p) + +#endif /* DEBUGGING */ + +void +sv_add_arena(ptr, size, flags) +char* ptr; +U32 size; +U32 flags; { + SV* sva = (SV*)ptr; register SV* sv; register SV* svend; - sv_root = (SV*)safemalloc(1012); - sv = sv_root; - Zero(sv, 1012, char); - svend = &sv[1008 / sizeof(SV) - 1]; + Zero(sva, size, char); + + /* The first SV in an arena isn't an SV. */ + SvANY(sva) = (void *) 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; + + svend = &sva[SvREFCNT(sva) - 1]; + sv = sva + 1; while (sv < svend) { SvANY(sv) = (void *)(SV*)(sv + 1); SvFLAGS(sv) = SVTYPEMASK; sv++; } SvANY(sv) = 0; - sv++; - SvANY(sv) = (void *) sv_arenaroot; - sv_arenaroot = sv_root; - return new_sv(); + SvFLAGS(sv) = SVTYPEMASK; } -#endif -void -sv_report_used() +static SV* +more_sv() { + register SV* sv; + + if (nice_chunk) { + sv_add_arena(nice_chunk, nice_chunk_size, 0); + nice_chunk = Nullch; + } + else { + char *chunk; /* must use New here to match call to */ + New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */ + sv_add_arena(chunk, 1008, 0); + } + uproot_SV(sv); + return sv; +} + +static void +visit(f) +SVFUNC f; +{ + SV* sva; SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; - while (sv < svend) { - if (SvTYPE(sv) != SVTYPEMASK) { - fprintf(stderr, "****\n"); - sv_dump(sv); - } - ++sv; + for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != SVTYPEMASK) + (*f)(sv); } } } +#endif /* PURIFY */ + +static void +do_report_used(sv) +SV* sv; +{ + if (SvTYPE(sv) != SVTYPEMASK) { + /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ + PerlIO_printf(PerlIO_stderr(), "****\n"); + sv_dump(sv); + } +} + void -sv_clean_objs() +sv_report_used() +{ + visit(do_report_used); +} + +static void +do_clean_objs(sv) +SV* sv; { - register SV* sv; - register SV* svend; SV* rv; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; - while (sv < svend) { - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), - sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - /* XXX Might want to check arrays, etc. */ - ++sv; - } + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); } + + /* XXX Might want to check arrays, etc. */ +} + +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void +do_clean_named_objs(sv) +SV* sv; +{ + if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) + do_clean_objs(GvSV(sv)); +} +#endif + +void +sv_clean_objs() +{ +#ifndef DISABLE_DESTRUCTOR_KLUDGE + visit(do_clean_named_objs); +#endif + visit(do_clean_objs); +} + +static void +do_clean_all(sv) +SV* sv; +{ + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); } +static int in_clean_all = 0; + void sv_clean_all() { - register SV* sv; - register SV* svend; + in_clean_all = 1; + visit(do_clean_all); + in_clean_all = 0; +} - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; - while (sv < svend) { - if (SvTYPE(sv) != SVTYPEMASK) { - DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); - } - ++sv; - } +void +sv_free_arenas() +{ + SV* sva; + SV* svanext; + + /* 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) { + svanext = (SV*) SvANY(sva); + while (svanext && SvFAKE(svanext)) + svanext = (SV*) SvANY(svanext); + + if (!SvFAKE(sva)) + Safefree((void *)sva); } } @@ -433,6 +611,9 @@ U32 mt; if (SvTYPE(sv) == mt) return TRUE; + if (mt < SVt_PVIV) + (void)SvOOK_off(sv); + switch (SvTYPE(sv)) { case SVt_NULL: pv = 0; @@ -481,7 +662,6 @@ U32 mt; stash = 0; break; case SVt_PV: - nv = 0.0; pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -496,7 +676,6 @@ U32 mt; mt = SVt_PVNV; break; case SVt_PVIV: - nv = 0.0; pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -507,7 +686,6 @@ U32 mt; del_XPVIV(SvANY(sv)); break; case SVt_PVNV: - nv = SvNVX(sv); pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -599,8 +777,8 @@ U32 mt; if (pv) Safefree(pv); SvPVX(sv) = 0; - AvMAX(sv) = 0; - AvFILL(sv) = 0; + AvMAX(sv) = -1; + AvFILL(sv) = -1; SvIVX(sv) = 0; SvNVX(sv) = 0.0; SvMAGIC(sv) = magic; @@ -649,6 +827,7 @@ U32 mt; GvNAME(sv) = 0; GvNAMELEN(sv) = 0; GvSTASH(sv) = 0; + GvFLAGS(sv) = 0; break; case SVt_PVBM: SvANY(sv) = new_XPVBM(); @@ -868,7 +1047,7 @@ unsigned long newlen; #ifdef MSDOS if (newlen >= 0x10000) { - fprintf(stderr, "Allocation too large: %lx\n", newlen); + PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ @@ -934,8 +1113,8 @@ IV i; croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), op_name[op->op_type]); } - SvIVX(sv) = i; (void)SvIOK_only(sv); /* validate number */ + SvIVX(sv) = i; SvTAINT(sv); } @@ -1018,7 +1197,7 @@ SV *sv; *d = '\0'; if (op) - warn("Argument \"%s\" isn't numeric for %s", tmpbuf, + warn("Argument \"%s\" isn't numeric in %s", tmpbuf, op_name[op->op_type]); else warn("Argument \"%s\" isn't numeric", tmpbuf); @@ -1087,6 +1266,7 @@ register SV *sv; break; } if (SvNOKp(sv)) { + (void)SvIOK_on(sv); if (SvNVX(sv) < 0.0) SvIVX(sv) = I_V(SvNVX(sv)); else @@ -1095,15 +1275,16 @@ register SV *sv; else if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !looks_like_number(sv)) not_a_number(sv); + (void)SvIOK_on(sv); SvIVX(sv) = (IV)atol(SvPVX(sv)); } else { - if (dowarn && !localizing) + if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; } (void)SvIOK_on(sv); - DEBUG_c(fprintf(stderr,"0x%lx 2iv(%ld)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } @@ -1156,7 +1337,7 @@ register SV *sv; sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); - DEBUG_c(fprintf(stderr,"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -1171,12 +1352,12 @@ register SV *sv; SvNVX(sv) = atof(SvPVX(sv)); } else { - if (dowarn && !localizing) + if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0.0; } SvNOK_on(sv); - DEBUG_c(fprintf(stderr,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } @@ -1302,7 +1483,7 @@ STRLEN *lp; while (*s) s++; } else { - if (dowarn && !localizing) + if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); *lp = 0; return ""; @@ -1311,7 +1492,7 @@ STRLEN *lp; *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); - DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); return SvPVX(sv); tokensave: @@ -1410,6 +1591,13 @@ register SV *sstr; stype = SvTYPE(sstr); dtype = SvTYPE(dstr); + if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) { + sv_unglob(dstr); /* so fake GLOB won't perpetuate */ + sv_setpvn(dstr, "", 0); + (void)SvPOK_only(dstr); + dtype = SvTYPE(dstr); + } + #ifdef OVERLOAD SvAMAGIC_off(dstr); #endif /* OVERLOAD */ @@ -1442,6 +1630,17 @@ register SV *sstr; case SVt_RV: if (dtype < SVt_RV) sv_upgrade(dstr, SVt_RV); + else if (dtype == SVt_PVGV && + SvTYPE(SvRV(sstr)) == SVt_PVGV) { + sstr = SvRV(sstr); + if (sstr == dstr) { + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_on(dstr); + GvMULTI_on(dstr); + return; + } + goto glob_assign; + } break; case SVt_PV: if (dtype < SVt_PV) @@ -1455,9 +1654,26 @@ 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: + case SVt_PVIO: + if (op) + croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), + op_name[op->op_type]); + else + croak("Bizarre copy of %s", sv_reftype(sstr, 0)); + break; + case SVt_PVGV: if (dtype <= SVt_PVGV) { - if (dtype < SVt_PVGV) { + glob_assign: + if (dtype != SVt_PVGV) { char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); @@ -1468,18 +1684,13 @@ register SV *sstr; SvFAKE_on(dstr); /* can coerce to non-glob */ } (void)SvOK_off(dstr); - if (!GvAV(sstr)) - gv_AVadd(sstr); - if (!GvHV(sstr)) - gv_HVadd(sstr); - if (!GvIO(sstr)) - gv_IOadd(sstr); - if (GvGP(dstr)) - gp_free(dstr); + GvINTRO_off(dstr); /* one-shot flag */ + gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ - SvMULTI_on(dstr); + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_on(dstr); + GvMULTI_on(dstr); return; } /* FALL THROUGH */ @@ -1498,20 +1709,20 @@ register SV *sstr; if (dtype == SVt_PVGV) { SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; - int intro = GvFLAGS(dstr) & GVf_INTRO; + int intro = GvINTRO(dstr); if (intro) { GP *gp; GvGP(dstr)->gp_refcnt--; + GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); GvGP(dstr) = gp; GvREFCNT(dstr) = 1; GvSV(dstr) = NEWSV(72,0); GvLINE(dstr) = curcop->cop_line; - GvEGV(dstr) = dstr; - GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ + GvEGV(dstr) = (GV*)dstr; } - SvMULTI_on(dstr); + GvMULTI_on(dstr); switch (SvTYPE(sref)) { case SVt_PVAV: if (intro) @@ -1519,6 +1730,8 @@ register SV *sstr; else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_AV_on(dstr); break; case SVt_PVHV: if (intro) @@ -1526,20 +1739,37 @@ register SV *sstr; else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: if (intro) SAVESPTR(GvCV(dstr)); else { CV* cv = GvCV(dstr); - dref = (SV*)cv; - if (dowarn && cv && sref != dref && - !GvCVGEN((GV*)dstr) && - (CvROOT(cv) || CvXSUB(cv)) ) - warn("Subroutine %s redefined", GvENAME((GV*)dstr)); + if (cv) { + dref = (SV*)cv; + if (dowarn && sref != dref && + !GvCVGEN((GV*)dstr) && + (CvROOT(cv) || CvXSUB(cv)) ) + warn("Subroutine %s redefined", + GvENAME((GV*)dstr)); + SvFAKE_on(cv); + } + } + if (GvCV(dstr) != (CV*)sref) { + GvCV(dstr) = (CV*)sref; + GvASSUMECV_on(dstr); } - GvFLAGS(dstr) |= GVf_IMPORTED; - GvCV(dstr) = (CV*)sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_CV_on(dstr); + break; + case SVt_PVIO: + if (intro) + SAVESPTR(GvIOp(dstr)); + else + dref = (SV*)GvIOp(dstr); + GvIOp(dstr) = (IO*)sref; break; default: if (intro) @@ -1547,6 +1777,8 @@ register SV *sstr; else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_SV_on(dstr); break; } if (dref) @@ -1557,6 +1789,7 @@ register SV *sstr; return; } if (SvPVX(dstr)) { + (void)SvOOK_off(dstr); /* backoff */ Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } @@ -1587,20 +1820,27 @@ register SV *sstr; * has to be allocated and SvPVX(sstr) has to be freed. */ - if (SvTEMP(sstr)) { /* slated for free anyway? */ + if (SvTEMP(sstr) && /* slated for free anyway? */ + !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ + { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ - (void)SvOOK_off(dstr); - Safefree(SvPVX(dstr)); + if (SvOOK(dstr)) { + SvFLAGS(dstr) &= ~SVf_OOK; + Safefree(SvPVX(dstr) - SvIVX(dstr)); + } + else + Safefree(SvPVX(dstr)); } + (void)SvPOK_only(dstr); SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); - (void)SvPOK_only(dstr); SvTEMP_off(dstr); + (void)SvOK_off(sstr); SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); - SvPOK_off(sstr); /* wipe out any weird flags */ - SvPVX(sstr) = 0; /* so sstr frees uneventfully */ + SvCUR_set(sstr, 0); + SvTEMP_off(sstr); } else { /* have to copy actual string */ STRLEN len = SvCUR(sstr); @@ -1645,7 +1885,8 @@ register SV *sv; register char *ptr; register STRLEN len; { - assert(len >= 0); + assert(len >= 0); /* STRLEN is probably unsigned, so this may + elicit a warning, but it won't hurt. */ if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); @@ -1656,7 +1897,11 @@ register STRLEN len; (void)SvOK_off(sv); return; } - if (!SvUPGRADE(sv, SVt_PV)) + if (SvTYPE(sv) >= SVt_PV) { + if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + sv_unglob(sv); + } + else if (!sv_upgrade(sv, SVt_PV)) return; SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len,char); @@ -1684,7 +1929,11 @@ register char *ptr; return; } len = strlen(ptr); - if (!SvUPGRADE(sv, SVt_PV)) + if (SvTYPE(sv) >= SVt_PV) { + if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + sv_unglob(sv); + } + else if (!sv_upgrade(sv, SVt_PV)) return; SvGROW(sv, len + 1); Move(ptr,SvPVX(sv),len+1,char); @@ -1763,6 +2012,8 @@ register STRLEN len; junk = SvPV_force(sv, tlen); SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len,char); SvCUR(sv) += len; *SvEND(sv) = '\0'; @@ -1797,6 +2048,8 @@ register char *ptr; junk = SvPV_force(sv, tlen); len = strlen(ptr); SvGROW(sv, tlen + len + 1); + if (ptr == junk) + ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR(sv) += len; (void)SvPOK_only(sv); /* validate pointer */ @@ -1814,7 +2067,7 @@ STRLEN len; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -1825,6 +2078,8 @@ STRLEN len; return sv; } +/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ + void sv_magic(sv, obj, how, name, namlen) register SV *sv; @@ -1837,7 +2092,7 @@ I32 namlen; if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) croak(no_modify); - if (SvMAGICAL(sv)) { + if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { if (how == 't') mg->mg_len |= 1; @@ -1860,8 +2115,12 @@ I32 namlen; } mg->mg_type = how; mg->mg_len = namlen; - if (name && namlen >= 0) - mg->mg_ptr = savepvn(name, namlen); + if (name) + if (namlen >= 0) + mg->mg_ptr = savepvn(name, namlen); + else if (namlen == HEf_SVKEY) + mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); + switch (how) { case 0: mg->mg_virtual = &vtbl_sv; @@ -1937,7 +2196,11 @@ I32 namlen; case '.': mg->mg_virtual = &vtbl_pos; break; - case '~': /* reserved for extensions but multiple extensions may clash */ + case '~': /* Reserved for use by extensions not perl internals. */ + /* Useful for attaching extension internal data to perl vars. */ + /* Note that multiple extensions may clash if magical scalars */ + /* etc holding private data from one are passed to another. */ + SvRMAGICAL_on(sv); break; default: croak("Don't know how to handle magic of type '%c'", how); @@ -1954,7 +2217,7 @@ int type; { MAGIC* mg; MAGIC** mgp; - if (!SvMAGICAL(sv)) + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &SvMAGIC(sv); for (mg = *mgp; mg; mg = *mgp) { @@ -1964,7 +2227,10 @@ int type; if (vtbl && vtbl->svt_free) (*vtbl->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') - Safefree(mg->mg_ptr); + if (mg->mg_len >= 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) + SvREFCNT_dec((SV*)mg->mg_ptr); if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); @@ -2091,6 +2357,7 @@ register SV *nsv; sv_clear(sv); StructCopy(nsv,sv,SV); SvREFCNT(sv) = refcnt; + SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ del_SV(nsv); } @@ -2115,7 +2382,6 @@ register SV *sv; Zero(&ref, 1, SV); sv_upgrade(&ref, SVt_RV); - SAVEI32(SvREFCNT(sv)); SvRV(&ref) = SvREFCNT_inc(sv); SvROK_on(&ref); @@ -2123,21 +2389,38 @@ register SV *sv; PUSHMARK(SP); PUSHs(&ref); PUTBACK; - perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL); + perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); del_XRV(SvANY(&ref)); + SvREFCNT(sv)--; } LEAVE; } + else + SvREFCNT_dec(SvSTASH(sv)); if (SvOBJECT(sv)) { 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 { + croak("panic: dangling references in DESTROY"); + } + } } - if (SvMAGICAL(sv)) + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) mg_free(sv); switch (SvTYPE(sv)) { case SVt_PVIO: + io_close((IO*)sv); Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); @@ -2155,7 +2438,7 @@ register SV *sv; av_undef((AV*)sv); break; case SVt_PVGV: - gp_free(sv); + gp_free((GV*)sv); Safefree(GvNAME(sv)); /* FALL THROUGH */ case SVt_PVLV: @@ -2169,7 +2452,7 @@ register SV *sv; case SVt_RV: if (SvROK(sv)) SvREFCNT_dec(SvRV(sv)); - else if (SvPVX(sv)) + else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); break; /* @@ -2255,6 +2538,8 @@ SV *sv; if (SvREFCNT(sv) == 0) { if (SvFLAGS(sv) & SVf_BREAK) return; + if (in_clean_all) /* All is fair */ + return; warn("Attempt to free unreferenced scalar"); return; } @@ -2312,7 +2597,7 @@ register SV *str2; if (cur1 != cur2) return 0; - return !bcmp(pv1, pv2, cur1); + return !memcmp(pv1, pv2, cur1); } I32 @@ -2364,17 +2649,14 @@ register SV *str2; char * sv_gets(sv,fp,append) register SV *sv; -register FILE *fp; +register PerlIO *fp; I32 append; { - register char *bp; /* we're going to steal some values */ -#ifdef USE_STDIO_PTR - register I32 cnt; /* from the stdio struct and put EVERYTHING */ - register STDCHAR *ptr; /* in the innermost loop into registers */ - STRLEN bpx; - I32 shortbuffered; -#endif - register I32 newline = rschar;/* (assuming >= 6 registers) */ + char *rsptr; + STRLEN rslen; + register STDCHAR rslast; + register STDCHAR *bp; + register I32 cnt; I32 i; if (SvTHINKFIRST(sv)) { @@ -2385,21 +2667,55 @@ I32 append; } if (!SvUPGRADE(sv, SVt_PV)) return 0; - if (rspara) { /* have to do this both before and after */ + + if (RsSNARF(rs)) { + rsptr = NULL; + rslen = 0; + } + else if (RsPARA(rs)) { + rsptr = "\n\n"; + rslen = 2; + } + else + rsptr = SvPV(rs, rslen); + rslast = rslen ? rsptr[rslen - 1] : '\0'; + + if (RsPARA(rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ - if (feof(fp)) + if (PerlIO_eof(fp)) return 0; - i = getc(fp); + i = PerlIO_getc(fp); if (i != '\n') { if (i == -1) return 0; - ungetc(i,fp); + PerlIO_ungetc(fp,i); break; } } while (i != EOF); } -#ifdef USE_STDIO_PTR /* Here is some breathtakingly efficient cheating */ - cnt = FILE_cnt(fp); /* get count into register */ + + /* See if we know enough about I/O mechanism to cheat it ! */ + + /* This used to be #ifdef test - it is made run-time test for ease + of abstracting out stdio interface. One call should be cheap + enough here - and may even be a macro allowing compile + time optimization. + */ + + if (PerlIO_fast_gets(fp)) { + + /* + * We're going to steal some values from the stdio struct + * and put EVERYTHING in the innermost loop into registers. + */ + register STDCHAR *ptr; + STRLEN bpx; + I32 shortbuffered; + + + /* Here is some breathtakingly efficient cheating */ + + cnt = PerlIO_get_cnt(fp); /* get count into register */ (void)SvPOK_only(sv); /* validate pointer */ if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ if (cnt > 80 && SvLEN(sv) > append) { @@ -2413,106 +2729,117 @@ I32 append; } else shortbuffered = 0; - bp = SvPVX(sv) + append; /* move these two too to registers */ - ptr = FILE_ptr(fp); + bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ + ptr = (STDCHAR*)PerlIO_get_ptr(fp); for (;;) { screamer: if (cnt > 0) { - while (--cnt >= 0) { /* this */ /* eat */ - if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ - goto thats_all_folks; /* screams */ /* sed :-) */ + if (rslen) { + while (cnt > 0) { /* this | eat */ + cnt--; + if ((*bp++ = *ptr++) == rslast) /* really | dust */ + goto thats_all_folks; /* screams | sed :-) */ + } + } + else { + memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */ + bp += cnt; /* screams | dust */ + ptr += cnt; /* louder | sed :-) */ + cnt = 0; } } if (shortbuffered) { /* oh well, must extend */ cnt = shortbuffered; shortbuffered = 0; - bpx = bp - SvPVX(sv); /* prepare for possible relocation */ + bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ SvCUR_set(sv, bpx); SvGROW(sv, SvLEN(sv) + append + cnt + 2); - bp = SvPVX(sv) + bpx; /* reconstitute our pointer */ + bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ continue; } - FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */ - FILE_ptr(fp) = ptr; - i = _filbuf(fp); /* get more characters */ - cnt = FILE_cnt(fp); - ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */ + PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ + /* This used to call 'filbuf' in stdio form, but as that behaves like getc + when cnt <= 0 we use PerlIO_getc here to avoid another abstraction. + This may also avoid issues with different named 'filbuf' equivalents + */ + i = PerlIO_getc(fp); /* get more characters */ + cnt = PerlIO_get_cnt(fp); + ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; - bpx = bp - SvPVX(sv); /* prepare for possible relocation */ + bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */ SvCUR_set(sv, bpx); SvGROW(sv, bpx + cnt + 2); - bp = SvPVX(sv) + bpx; /* reconstitute our pointer */ + bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ + + *bp++ = i; /* store character from PerlIO_getc */ - if (i == newline) { /* all done for now? */ - *bp++ = i; + if (rslen && (STDCHAR)i == rslast) /* all done for now? */ goto thats_all_folks; - } - *bp++ = i; /* now go back to screaming loop */ } thats_all_folks: - if (rslen > 1 && (bp - SvPVX(sv) < rslen || bcmp(bp - rslen, rs, rslen))) - goto screamer; /* go back to the fray */ + if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || + memcmp((char*)bp - rslen, rsptr, rslen)) + goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; - FILE_cnt(fp) = cnt; /* put these back or we're in trouble */ - FILE_ptr(fp) = ptr; + PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ *bp = '\0'; - SvCUR_set(sv, bp - SvPVX(sv)); /* set length */ - -#else /* !USE_STDIO_PTR */ /* The big, slow, and stupid way */ - + SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ + } + else { - char buf[8192]; - register char * bpe = buf + sizeof(buf) - 3; + /*The big, slow, and stupid way */ + STDCHAR buf[8192]; -screamer: - bp = buf; - while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ; +screamer2: + if (rslen) { + register STDCHAR *bpe = buf + sizeof(buf); + bp = buf; + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) + ; /* keep reading */ + cnt = bp - buf; + } + else { + cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); + i = cnt ? (U8)buf[cnt - 1] : EOF; + } if (append) - sv_catpvn(sv, buf, bp - buf); + sv_catpvn(sv, (char *) buf, cnt); else - sv_setpvn(sv, buf, bp - buf); - if (i != EOF /* joy */ - && - (i != newline - || - (rslen > 1 - && - (SvCUR(sv) < rslen - || - bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rs, rslen) - ) - ) - ) - ) + sv_setpvn(sv, (char *) buf, cnt); + + if (i != EOF && /* joy */ + (!rslen || + SvCUR(sv) < rslen || + memcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; - goto screamer; + goto screamer2; } } -#endif /* USE_STDIO_PTR */ - - if (rspara) { - while (i != EOF) { - i = getc(fp); + if (RsPARA(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') { - ungetc(i,fp); + PerlIO_ungetc(fp,i); break; } } } - return SvCUR(sv) - append ? SvPVX(sv) : Nullch; + + return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } + void sv_inc(sv) register SV *sv; @@ -2536,8 +2863,8 @@ register SV *sv; mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { - ++SvIVX(sv); (void)SvIOK_only(sv); + ++SvIVX(sv); return; } if (flags & SVp_NOK) { @@ -2546,7 +2873,8 @@ register SV *sv; return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { - sv_upgrade(sv, SVt_NV); + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = 1.0; (void)SvNOK_only(sv); return; @@ -2605,8 +2933,8 @@ register SV *sv; mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { - --SvIVX(sv); (void)SvIOK_only(sv); + --SvIVX(sv); return; } if (flags & SVp_NOK) { @@ -2615,7 +2943,8 @@ register SV *sv; return; } if (!(flags & SVp_POK)) { - sv_upgrade(sv, SVt_NV); + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = -1.0; (void)SvNOK_only(sv); return; @@ -2641,7 +2970,7 @@ SV *oldstr; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2658,7 +2987,7 @@ sv_newmortal() { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; @@ -2692,7 +3021,7 @@ STRLEN len; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2708,7 +3037,7 @@ double n; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2722,7 +3051,7 @@ IV i; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2736,7 +3065,7 @@ SV *ref; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2761,7 +3090,7 @@ register SV *old; warn("semi-panic: attempt to dup freed string"); return Nullsv; } - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2813,10 +3142,10 @@ HV *stash; for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; - entry = entry->hent_next) { - if (!todo[(U8)*entry->hent_key]) + entry = HeNEXT(entry)) { + if (!todo[(U8)*HeKEY(entry)]) continue; - gv = (GV*)entry->hent_val; + gv = (GV*)HeVAL(entry); sv = GvSV(gv); (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { @@ -2890,13 +3219,17 @@ I32 lref; *st = GvESTASH(gv); fix_gv: if (lref && !GvCV(gv)) { + SV *tmpsv; ENTER; - sv = NEWSV(704,0); - gv_efullname(sv, gv); + tmpsv = NEWSV(704,0); + gv_efullname(tmpsv, gv, Nullch); newSUB(start_subparse(), - newSVOP(OP_CONST, 0, sv), + newSVOP(OP_CONST, 0, tmpsv), + Nullop, Nullop); LEAVE; + if (!GvCV(gv)) + croak("Unable to create sub named \"%s\"", SvPV(sv,na)); } return GvCV(gv); } @@ -2986,13 +3319,17 @@ STRLEN *lp; } else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { - if (SvFAKE(sv)) + if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) { sv_unglob(sv); + s = SvPVX(sv); + *lp = SvCUR(sv); + } else croak("Can't coerce %s to string in %s", sv_reftype(sv,0), op_name[op->op_type]); } - s = sv_2pv(sv, lp); + else + s = sv_2pv(sv, lp); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; @@ -3007,7 +3344,7 @@ STRLEN *lp; if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); - DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", (unsigned long)sv,SvPVX(sv))); } } @@ -3080,7 +3417,7 @@ char *classname; { SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; @@ -3176,9 +3513,10 @@ SV* sv; assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); if (GvGP(sv)) - gp_free(sv); + gp_free((GV*)sv); sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); + GvMULTI_off(sv); SvFLAGS(sv) &= ~SVTYPEMASK; SvFLAGS(sv) |= SVt_PVMG; } @@ -3191,7 +3529,10 @@ SV* sv; SvRV(sv) = 0; SvROK_off(sv); - SvREFCNT_dec(rv); + if (SvREFCNT(rv) != 1 || SvREADONLY(rv)) + SvREFCNT_dec(rv); + else + sv_2mortal(rv); /* Schedule for freeing later */ } #ifdef DEBUGGING @@ -3205,7 +3546,7 @@ SV* sv; U32 type; if (!sv) { - fprintf(stderr, "SV = 0\n"); + PerlIO_printf(Perl_debug_log, "SV = 0\n"); return; } @@ -3234,76 +3575,93 @@ SV* sv; if (flags & SVf_READONLY) strcat(d, "READONLY,"); d += strlen(d); +#ifdef OVERLOAD + if (flags & SVf_AMAGIC) strcat(d, "OVERLOAD,"); +#endif /* OVERLOAD */ if (flags & SVp_IOK) strcat(d, "pIOK,"); if (flags & SVp_NOK) strcat(d, "pNOK,"); if (flags & SVp_POK) strcat(d, "pPOK,"); if (flags & SVp_SCREAM) strcat(d, "SCREAM,"); + + switch (type) { + case SVt_PVCV: + if (CvANON(sv)) strcat(d, "ANON,"); + if (CvCLONE(sv)) strcat(d, "CLONE,"); + if (CvCLONED(sv)) strcat(d, "CLONED,"); + break; + case SVt_PVGV: + if (GvMULTI(sv)) strcat(d, "MULTI,"); +#ifdef OVERLOAD + if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,"); +#endif /* OVERLOAD */ + } + d += strlen(d); if (d[-1] == ',') d--; *d++ = ')'; *d = '\0'; - fprintf(stderr, "SV = "); + PerlIO_printf(Perl_debug_log, "SV = "); switch (type) { case SVt_NULL: - fprintf(stderr,"NULL%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "NULL%s\n", tmpbuf); return; case SVt_IV: - fprintf(stderr,"IV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "IV%s\n", tmpbuf); break; case SVt_NV: - fprintf(stderr,"NV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "NV%s\n", tmpbuf); break; case SVt_RV: - fprintf(stderr,"RV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "RV%s\n", tmpbuf); break; case SVt_PV: - fprintf(stderr,"PV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PV%s\n", tmpbuf); break; case SVt_PVIV: - fprintf(stderr,"PVIV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVIV%s\n", tmpbuf); break; case SVt_PVNV: - fprintf(stderr,"PVNV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVNV%s\n", tmpbuf); break; case SVt_PVBM: - fprintf(stderr,"PVBM%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVBM%s\n", tmpbuf); break; case SVt_PVMG: - fprintf(stderr,"PVMG%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVMG%s\n", tmpbuf); break; case SVt_PVLV: - fprintf(stderr,"PVLV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVLV%s\n", tmpbuf); break; case SVt_PVAV: - fprintf(stderr,"PVAV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVAV%s\n", tmpbuf); break; case SVt_PVHV: - fprintf(stderr,"PVHV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVHV%s\n", tmpbuf); break; case SVt_PVCV: - fprintf(stderr,"PVCV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVCV%s\n", tmpbuf); break; case SVt_PVGV: - fprintf(stderr,"PVGV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVGV%s\n", tmpbuf); break; case SVt_PVFM: - fprintf(stderr,"PVFM%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVFM%s\n", tmpbuf); break; case SVt_PVIO: - fprintf(stderr,"PVIO%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVIO%s\n", tmpbuf); break; default: - fprintf(stderr,"UNKNOWN%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", tmpbuf); return; } if (type >= SVt_PVIV || type == SVt_IV) - fprintf(stderr, " IV = %ld\n", (long)SvIVX(sv)); + PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); if (type >= SVt_PVNV || type == SVt_NV) - fprintf(stderr, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); + PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); if (SvROK(sv)) { - fprintf(stderr, " RV = 0x%lx\n", (long)SvRV(sv)); + PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); return; } @@ -3311,99 +3669,112 @@ SV* sv; return; if (type <= SVt_PVLV) { if (SvPVX(sv)) - fprintf(stderr, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", + PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv)); else - fprintf(stderr, " PV = 0\n"); + PerlIO_printf(Perl_debug_log, " PV = 0\n"); } if (type >= SVt_PVMG) { if (SvMAGIC(sv)) { - fprintf(stderr, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); + PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); } if (SvSTASH(sv)) - fprintf(stderr, " STASH = %s\n", HvNAME(SvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); } switch (type) { case SVt_PVLV: - fprintf(stderr, " TYPE = %c\n", LvTYPE(sv)); - fprintf(stderr, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); - fprintf(stderr, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); - fprintf(stderr, " TARG = 0x%lx\n", (long)LvTARG(sv)); + PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv)); + PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); + PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); + PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv)); sv_dump(LvTARG(sv)); break; case SVt_PVAV: - fprintf(stderr, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); - fprintf(stderr, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - fprintf(stderr, " FILL = %ld\n", (long)AvFILL(sv)); - fprintf(stderr, " MAX = %ld\n", (long)AvMAX(sv)); - fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); - if (AvREAL(sv)) - fprintf(stderr, " FLAGS = (REAL)\n"); - else - fprintf(stderr, " FLAGS = ()\n"); + PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); + PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv)); + PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); + PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); + flags = AvFLAGS(sv); + d = tmpbuf; + *d = '\0'; + if (flags & AVf_REAL) strcat(d, "REAL,"); + if (flags & AVf_REIFY) strcat(d, "REIFY,"); + if (flags & AVf_REUSED) strcat(d, "REUSED,"); + if (*d) + d[strlen(d)-1] = '\0'; + PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", d); break; case SVt_PVHV: - fprintf(stderr, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); - fprintf(stderr, " KEYS = %ld\n", (long)HvKEYS(sv)); - fprintf(stderr, " FILL = %ld\n", (long)HvFILL(sv)); - fprintf(stderr, " MAX = %ld\n", (long)HvMAX(sv)); - fprintf(stderr, " RITER = %ld\n", (long)HvRITER(sv)); - fprintf(stderr, " EITER = 0x%lx\n",(long) HvEITER(sv)); + PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); + PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv)); + PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv)); + PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv)); + PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv)); if (HvPMROOT(sv)) - fprintf(stderr, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); + PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); if (HvNAME(sv)) - fprintf(stderr, " NAME = \"%s\"\n", HvNAME(sv)); + PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); break; case SVt_PVFM: case SVt_PVCV: - fprintf(stderr, " STASH = 0x%lx\n", (long)CvSTASH(sv)); - fprintf(stderr, " START = 0x%lx\n", (long)CvSTART(sv)); - fprintf(stderr, " ROOT = 0x%lx\n", (long)CvROOT(sv)); - fprintf(stderr, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); - fprintf(stderr, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); - fprintf(stderr, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); - fprintf(stderr, " DEPTH = %ld\n", (long)CvDEPTH(sv)); - fprintf(stderr, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); - fprintf(stderr, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); + if (SvPOK(sv)) + PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); + PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); + PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv)); + PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); + PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); + PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); + PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv)); + if (CvGV(sv) && GvNAME(CvGV(sv))) { + PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv))); + } else { + PerlIO_printf(Perl_debug_log, "\n"); + } + PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); + PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); + PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); + PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); if (type == SVt_PVFM) - fprintf(stderr, " LINES = %ld\n", (long)FmLINES(sv)); + PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); break; case SVt_PVGV: - fprintf(stderr, " NAME = %s\n", GvNAME(sv)); - fprintf(stderr, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv)); - fprintf(stderr, " GP = 0x%lx\n", (long)GvGP(sv)); - fprintf(stderr, " SV = 0x%lx\n", (long)GvSV(sv)); - fprintf(stderr, " REFCNT = %ld\n", (long)GvREFCNT(sv)); - fprintf(stderr, " IO = 0x%lx\n", (long)GvIOp(sv)); - fprintf(stderr, " FORM = 0x%lx\n", (long)GvFORM(sv)); - fprintf(stderr, " AV = 0x%lx\n", (long)GvAV(sv)); - fprintf(stderr, " HV = 0x%lx\n", (long)GvHV(sv)); - fprintf(stderr, " CV = 0x%lx\n", (long)GvCV(sv)); - fprintf(stderr, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); - fprintf(stderr, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); - fprintf(stderr, " LINE = %ld\n", (long)GvLINE(sv)); - fprintf(stderr, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); - fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv)); - fprintf(stderr, " EGV = 0x%lx\n", (long)GvEGV(sv)); + PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); + PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); + PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); + PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); + PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv)); + PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv)); + PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv)); + PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv)); + PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv)); + PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); + PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); + PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); break; case SVt_PVIO: - fprintf(stderr, " IFP = 0x%lx\n", (long)IoIFP(sv)); - fprintf(stderr, " OFP = 0x%lx\n", (long)IoOFP(sv)); - fprintf(stderr, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); - fprintf(stderr, " LINES = %ld\n", (long)IoLINES(sv)); - fprintf(stderr, " PAGE = %ld\n", (long)IoPAGE(sv)); - fprintf(stderr, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); - fprintf(stderr, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); - fprintf(stderr, " TOP_NAME = %s\n", IoTOP_NAME(sv)); - fprintf(stderr, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); - fprintf(stderr, " FMT_NAME = %s\n", IoFMT_NAME(sv)); - fprintf(stderr, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); - fprintf(stderr, " BOTTOM_NAME = %s\n", IoBOTTOM_NAME(sv)); - fprintf(stderr, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); - fprintf(stderr, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); - fprintf(stderr, " TYPE = %c\n", IoTYPE(sv)); - fprintf(stderr, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); + PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv)); + PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv)); + PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); + PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv)); + PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv)); + PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); + PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); + PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); + PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); + PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); + PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); + PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); + PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); + PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); + PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv)); + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } }