X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=9fb9985050e4052495aa0e6e5c4ecbd5b4f3c3f0;hb=80589958147be1b203a8dbab685aa65994207e8a;hp=ed8dc5228cd638c20c438d98101579dd33866f67;hpb=adbc6bb137ce1026e8a7cba251bb82b41f398aae;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index ed8dc52..9fb9985 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,6 +34,11 @@ #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)); @@ -51,6 +63,16 @@ static void sv_unglob _((SV* sv)); #define new_SV() sv = (SV*)safemalloc(sizeof(SV)) #define del_SV(p) free((char*)p) +void +sv_add_arena(ptr, size, flags) +char* ptr; +U32 size; +U32 flags; +{ + if (!(flags & SVf_FAKE)) + free(ptr); +} + #else #define new_SV() \ @@ -61,7 +83,6 @@ static void sv_unglob _((SV* sv)); } \ else \ sv = more_sv(); -#endif static SV* new_sv() @@ -82,6 +103,7 @@ new_sv() del_sv(p); \ else { \ SvANY(p) = (void *)sv_root; \ + SvFLAGS(p) = SVTYPEMASK; \ sv_root = p; \ --sv_count; \ } @@ -91,11 +113,13 @@ 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; } @@ -116,38 +140,65 @@ SV* p; #endif -static SV* -more_sv() +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; + SvFLAGS(sv) = SVTYPEMASK; +} + +static SV* +more_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); + } return new_sv(); } +#endif void sv_report_used() { + SV* sva; SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { - fprintf(stderr, "****\n"); + PerlIO_printf(PerlIO_stderr(), "****\n"); sv_dump(sv); } ++sv; @@ -158,15 +209,38 @@ sv_report_used() void sv_clean_objs() { + SV* sva; register SV* sv; register SV* svend; SV* rv; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; +#ifndef DISABLE_DESTRUCTOR_KLUDGE + register GV* gv; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + gv = (GV*)sva + 1; + svend = &sva[SvREFCNT(sva)]; + while ((SV*)gv < svend) { + if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && + SvROK(sv) && SvOBJECT(rv = SvRV(sv))) + { + DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), + sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } + ++gv; + } + } + if (!sv_objcount) + return; +#endif + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), + DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; @@ -178,23 +252,48 @@ sv_clean_objs() } } +static int in_clean_all = 0; + void sv_clean_all() { + SV* sva; register SV* sv; register SV* svend; - for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) { - svend = &sv[1008 / sizeof(SV)]; + in_clean_all = 1; + for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) { + sv = sva + 1; + svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { - DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } ++sv; } } + in_clean_all = 0; +} + +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); + } } static XPVIV* @@ -433,6 +532,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; @@ -490,6 +592,10 @@ U32 mt; magic = 0; stash = 0; del_XPV(SvANY(sv)); + if (mt <= SVt_IV) + mt = SVt_PVIV; + else if (mt == SVt_NV) + mt = SVt_PVNV; break; case SVt_PVIV: nv = 0.0; @@ -623,6 +729,7 @@ U32 mt; break; case SVt_PVCV: SvANY(sv) = new_XPVCV(); + Zero(SvANY(sv), 1, XPVCV); SvPVX(sv) = pv; SvCUR(sv) = cur; SvLEN(sv) = len; @@ -630,15 +737,6 @@ U32 mt; SvNVX(sv) = nv; SvMAGIC(sv) = magic; SvSTASH(sv) = stash; - CvSTASH(sv) = 0; - CvSTART(sv) = 0; - CvROOT(sv) = 0; - CvXSUB(sv) = 0; - CvXSUBANY(sv).any_ptr = 0; - CvFILEGV(sv) = 0; - CvDEPTH(sv) = 0; - CvPADLIST(sv) = 0; - CvOLDSTYLE(sv) = 0; break; case SVt_PVGV: SvANY(sv) = new_XPVGV(); @@ -653,6 +751,7 @@ U32 mt; GvNAME(sv) = 0; GvNAMELEN(sv) = 0; GvSTASH(sv) = 0; + GvFLAGS(sv) = 0; break; case SVt_PVBM: SvANY(sv) = new_XPVBM(); @@ -669,6 +768,7 @@ U32 mt; break; case SVt_PVFM: SvANY(sv) = new_XPVFM(); + Zero(SvANY(sv), 1, XPVFM); SvPVX(sv) = pv; SvCUR(sv) = cur; SvLEN(sv) = len; @@ -676,10 +776,10 @@ U32 mt; SvNVX(sv) = nv; SvMAGIC(sv) = magic; SvSTASH(sv) = stash; - FmLINES(sv) = 0; break; case SVt_PVIO: SvANY(sv) = new_XPVIO(); + Zero(SvANY(sv), 1, XPVIO); SvPVX(sv) = pv; SvCUR(sv) = cur; SvLEN(sv) = len; @@ -687,22 +787,7 @@ U32 mt; SvNVX(sv) = nv; SvMAGIC(sv) = magic; SvSTASH(sv) = stash; - IoIFP(sv) = 0; - IoOFP(sv) = 0; - IoDIRP(sv) = 0; - IoLINES(sv) = 0; - IoPAGE(sv) = 0; IoPAGE_LEN(sv) = 60; - IoLINES_LEFT(sv)= 0; - IoTOP_NAME(sv) = 0; - IoTOP_GV(sv) = 0; - IoFMT_NAME(sv) = 0; - IoFMT_GV(sv) = 0; - IoBOTTOM_NAME(sv)= 0; - IoBOTTOM_GV(sv) = 0; - IoSUBPROCESS(sv)= 0; - IoTYPE(sv) = 0; - IoFLAGS(sv) = 0; break; } SvFLAGS(sv) &= ~SVTYPEMASK; @@ -886,7 +971,7 @@ unsigned long newlen; #ifdef MSDOS if (newlen >= 0x10000) { - fprintf(stderr, "Allocation too large: %lx\n", newlen); + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ @@ -952,8 +1037,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); } @@ -1036,7 +1121,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); @@ -1052,14 +1137,20 @@ register SV *sv; mg_get(sv); if (SvIOKp(sv)) return SvIVX(sv); - if (SvNOKp(sv)) - return I_V(SvNVX(sv)); + if (SvNOKp(sv)) { + if (SvNVX(sv) < 0.0) + return I_V(SvNVX(sv)); + else + return (IV) U_V(SvNVX(sv)); + } if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !looks_like_number(sv)) not_a_number(sv); return (IV)atol(SvPVX(sv)); } - return 0; + if (!SvROK(sv)) { + return 0; + } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { @@ -1071,9 +1162,13 @@ register SV *sv; return (IV)SvRV(sv); } if (SvREADONLY(sv)) { - if (SvNOK(sv)) - return I_V(SvNVX(sv)); - if (SvPOK(sv) && SvLEN(sv)) { + if (SvNOKp(sv)) { + if (SvNVX(sv) < 0.0) + return I_V(SvNVX(sv)); + else + return (IV) U_V(SvNVX(sv)); + } + if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !looks_like_number(sv)) not_a_number(sv); return (IV)atol(SvPVX(sv)); @@ -1094,20 +1189,26 @@ register SV *sv; sv_upgrade(sv, SVt_PVNV); break; } - if (SvNOK(sv)) - SvIVX(sv) = I_V(SvNVX(sv)); - else if (SvPOK(sv) && SvLEN(sv)) { + if (SvNOKp(sv)) { + (void)SvIOK_on(sv); + if (SvNVX(sv) < 0.0) + SvIVX(sv) = I_V(SvNVX(sv)); + else + SvIVX(sv) = (IV) U_V(SvNVX(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); } @@ -1123,13 +1224,15 @@ register SV *sv; if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); return atof(SvPVX(sv)); } if (SvIOKp(sv)) return (double)SvIVX(sv); - return 0; + if (!SvROK(sv)) { + return 0; + } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { @@ -1141,12 +1244,12 @@ register SV *sv; return (double)(unsigned long)SvRV(sv); } if (SvREADONLY(sv)) { - if (SvPOK(sv) && SvLEN(sv)) { - if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + if (SvPOKp(sv) && SvLEN(sv)) { + if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); return atof(SvPVX(sv)); } - if (SvIOK(sv)) + if (SvIOKp(sv)) return (double)SvIVX(sv); if (dowarn) warn(warn_uninit); @@ -1158,27 +1261,27 @@ 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); - if (SvIOK(sv) && - (!SvPOK(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) + if (SvIOKp(sv) && + (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { SvNVX(sv) = (double)SvIVX(sv); } - else if (SvPOK(sv) && SvLEN(sv)) { - if (dowarn && !SvIOK(sv) && !looks_like_number(sv)) + else if (SvPOKp(sv) && SvLEN(sv)) { + if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(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); } @@ -1208,8 +1311,10 @@ STRLEN *lp; Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); goto tokensave; } - *lp = 0; - return ""; + if (!SvROK(sv)) { + *lp = 0; + return ""; + } } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { @@ -1252,12 +1357,12 @@ STRLEN *lp; return s; } if (SvREADONLY(sv)) { - if (SvIOK(sv)) { - (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + if (SvNOKp(sv)) { + Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); goto tokensave; } - if (SvNOK(sv)) { - Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + if (SvIOKp(sv)) { + (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); goto tokensave; } if (dowarn) @@ -1268,7 +1373,7 @@ STRLEN *lp; } if (!SvUPGRADE(sv, SVt_PV)) return 0; - if (SvNOK(sv)) { + if (SvNOKp(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvGROW(sv, 28); @@ -1291,7 +1396,7 @@ STRLEN *lp; s--; #endif } - else if (SvIOK(sv)) { + else if (SvIOKp(sv)) { if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); SvGROW(sv, 11); @@ -1302,7 +1407,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 +1416,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 +1515,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 +1554,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 +1578,26 @@ register SV *sstr; if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; + + case SVt_PVLV: + sv_upgrade(dstr, SVt_PVNV); + 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,17 +1608,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 */ + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_on(dstr); + GvMULTI_on(dstr); return; } /* FALL THROUGH */ @@ -1497,20 +1633,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) @@ -1518,6 +1654,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) @@ -1525,14 +1663,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); + 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); + } + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_CV_on(dstr); + break; + case SVt_PVIO: + if (intro) + SAVESPTR(GvIOp(dstr)); else - dref = (SV*)GvCV(dstr); - GvFLAGS(dstr) |= GVf_IMPORTED; - GvCV(dstr) = (CV*)sref; + dref = (SV*)GvIOp(dstr); + GvIOp(dstr) = (IO*)sref; break; default: if (intro) @@ -1540,6 +1701,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) @@ -1550,6 +1713,7 @@ register SV *sstr; return; } if (SvPVX(dstr)) { + (void)SvOOK_off(dstr); /* backoff */ Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } @@ -1580,20 +1744,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); @@ -1638,6 +1809,7 @@ register SV *sv; register char *ptr; register STRLEN len; { + assert(len >= 0); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); @@ -1648,7 +1820,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); @@ -1676,7 +1852,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); @@ -1751,10 +1931,12 @@ register char *ptr; register STRLEN len; { STRLEN tlen; - char *s; + char *junk; - s = SvPV_force(sv, tlen); + 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'; @@ -1782,13 +1964,15 @@ register char *ptr; { register STRLEN len; STRLEN tlen; - char *s; + char *junk; if (!ptr) return; - s = SvPV_force(sv, tlen); + 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 */ @@ -1817,6 +2001,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; @@ -1829,9 +2015,12 @@ I32 namlen; if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how)) croak(no_modify); - if (SvMAGICAL(sv)) { - if (SvMAGIC(sv) && mg_find(sv, how)) + if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + if (how == 't') + mg->mg_len |= 1; return; + } } else { if (!SvUPGRADE(sv, SVt_PVMG)) @@ -1841,7 +2030,7 @@ I32 namlen; mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - if (obj == sv || how == '#') + if (!obj || obj == sv || how == '#') mg->mg_obj = obj; else { mg->mg_obj = SvREFCNT_inc(obj); @@ -1849,8 +2038,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; @@ -1906,6 +2099,7 @@ I32 namlen; break; case 't': mg->mg_virtual = &vtbl_taint; + mg->mg_len = 1; break; case 'U': mg->mg_virtual = &vtbl_uvar; @@ -1925,7 +2119,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); @@ -1942,7 +2140,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) { @@ -1952,7 +2150,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); @@ -2079,6 +2280,7 @@ register SV *nsv; sv_clear(sv); StructCopy(nsv,sv,SV); SvREFCNT(sv) = refcnt; + SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ del_SV(nsv); } @@ -2103,7 +2305,6 @@ register SV *sv; Zero(&ref, 1, SV); sv_upgrade(&ref, SVt_RV); - SAVEI32(SvREFCNT(sv)); SvRV(&ref) = SvREFCNT_inc(sv); SvROK_on(&ref); @@ -2111,28 +2312,46 @@ 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)); /* FALL THROUGH */ - case SVt_PVFM: case SVt_PVBM: goto freescalar; case SVt_PVCV: + case SVt_PVFM: cv_undef((CV*)sv); goto freescalar; case SVt_PVHV: @@ -2142,7 +2361,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: @@ -2156,7 +2375,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; /* @@ -2242,6 +2461,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; } @@ -2261,7 +2482,7 @@ STRLEN sv_len(sv) register SV *sv; { - char *s; + char *junk; STRLEN len; if (!sv) @@ -2270,7 +2491,7 @@ register SV *sv; if (SvGMAGICAL(sv)) len = mg_len(sv); else - s = SvPV(sv, len); + junk = SvPV(sv, len); return len; } @@ -2351,16 +2572,15 @@ 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 */ - register I32 cnt; /* from the stdio struct and put EVERYTHING */ - register STDCHAR *ptr; /* in the innermost loop into registers */ - register I32 newline = rschar;/* (assuming >= 6 registers) */ + char *rsptr; + STRLEN rslen; + register STDCHAR rslast; + register STDCHAR *bp; + register I32 cnt; I32 i; - STRLEN bpx; - I32 shortbuffered; if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) @@ -2370,21 +2590,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_STD_STDIO /* Here is some breathtakingly efficient cheating */ - cnt = fp->_cnt; /* 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) { @@ -2398,105 +2652,117 @@ I32 append; } else shortbuffered = 0; - bp = SvPVX(sv) + append; /* move these two too to registers */ - ptr = fp->_ptr; + 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 */ + 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; } - fp->_cnt = cnt; /* deregisterize cnt and ptr */ - fp->_ptr = ptr; - i = _filbuf(fp); /* get more characters */ - cnt = fp->_cnt; - ptr = fp->_ptr; /* reregisterize cnt and ptr */ + PerlIO_set_ptrcnt(fp,(char *) 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; - } - else if (i == EOF) /* all done for ever? */ - goto thats_really_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)) || + bcmp((char*)bp - rslen, rsptr, rslen)) + goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; - fp->_cnt = cnt; /* put these back or we're in trouble */ - fp->_ptr = ptr; + PerlIO_set_ptrcnt(fp,(char *) ptr, cnt); /* put these back or we're in trouble */ *bp = '\0'; - SvCUR_set(sv, bp - SvPVX(sv)); /* set length */ - -#else /* !USE_STD_STDIO */ /* 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 || + bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; - goto screamer; + goto screamer2; } } -#endif /* USE_STD_STDIO */ - - 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; @@ -2520,8 +2786,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) { @@ -2530,8 +2796,8 @@ register SV *sv; return; } if (!(flags & SVp_POK) || !*SvPVX(sv)) { - if (!SvUPGRADE(sv, SVt_NV)) - return; + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = 1.0; (void)SvNOK_only(sv); return; @@ -2590,8 +2856,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) { @@ -2600,8 +2866,8 @@ register SV *sv; return; } if (!(flags & SVp_POK)) { - if (!SvUPGRADE(sv, SVt_NV)) - return; + if ((flags & SVTYPEMASK) < SVt_PVNV) + sv_upgrade(sv, SVt_NV); SvNVX(sv) = -1.0; (void)SvNOK_only(sv); return; @@ -2799,10 +3065,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) { @@ -2876,11 +3142,17 @@ I32 lref; *st = GvESTASH(gv); fix_gv: if (lref && !GvCV(gv)) { - sv = NEWSV(704,0); - gv_efullname(sv, gv); - newSUB(savestack_ix, - newSVOP(OP_CONST, 0, sv), + SV *tmpsv; + ENTER; + tmpsv = NEWSV(704,0); + gv_efullname(tmpsv, gv); + newSUB(start_subparse(), + newSVOP(OP_CONST, 0, tmpsv), + Nullop, Nullop); + LEAVE; + if (!GvCV(gv)) + croak("Unable to create sub named \"%s\"", SvPV(sv,na)); } return GvCV(gv); } @@ -2969,14 +3241,18 @@ STRLEN *lp; *lp = SvCUR(sv); } else { - if (SvTYPE(sv) > SVt_PVLV) { - if (SvFAKE(sv)) + if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { + 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; @@ -2991,7 +3267,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))); } } @@ -3144,6 +3420,7 @@ HV* stash; SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); #ifdef OVERLOAD + SvAMAGIC_off(sv); if (Gv_AMG(stash)) { SvAMAGIC_on(sv); } @@ -3159,9 +3436,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; } @@ -3174,7 +3452,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 @@ -3188,7 +3469,7 @@ SV* sv; U32 type; if (!sv) { - fprintf(stderr, "SV = 0\n"); + PerlIO_printf(Perl_debug_log, "SV = 0\n"); return; } @@ -3217,76 +3498,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; } @@ -3294,98 +3592,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)); + 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(PerlIO_stderr(), " GV = 0x%lx", (long)CvGV(sv)); + if (CvGV(sv) && GvNAME(CvGV(sv))) { + PerlIO_printf(PerlIO_stderr(), " \"%s\"\n", GvNAME(CvGV(sv))); + } else { + PerlIO_printf(PerlIO_stderr(), "\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; } }