X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=eefa4773adbe08fa71fbb9dff2ad5085211c8e8b;hb=6c6463e2a6dcc80d76e91c5aaf19f3816899b04a;hp=ce2c7ca9bcb7dd3319ddf64c2fd7fc68825ebec6;hpb=f5992bc4a0a918eda67e6097aac8bd75a3b524e4;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/dump.c b/dump.c
index ce2c7ca..eefa477 100644
--- a/dump.c
+++ b/dump.c
@@ -27,6 +27,45 @@
 #include "proto.h"
 
 
+static const char* const svtypenames[SVt_LAST] = {
+    "NULL",
+    "IV",
+    "NV",
+    "RV",
+    "BIND",
+    "PV",
+    "PVIV",
+    "PVNV",
+    "PVMG",
+    "PVGV",
+    "PVLV",
+    "PVAV",
+    "PVHV",
+    "PVCV",
+    "PVFM",
+    "PVIO"
+};
+
+
+static const char* const svshorttypenames[SVt_LAST] = {
+    "UNDEF",
+    "IV",
+    "NV",
+    "RV",
+    "BIND",
+    "PV",
+    "PVIV",
+    "PVNV",
+    "PVMG",
+    "GV",
+    "PVLV",
+    "AV",
+    "HV",
+    "CV",
+    "FM",
+    "IO"
+};
+
 #define Sequence PL_op_sequence
 
 void
@@ -280,12 +319,12 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
         sv_setpvn(dsv, "", 0);
         
     if ( start_color != NULL ) 
-        Perl_sv_catpvf( aTHX_ dsv, "%s", start_color);
+        Perl_sv_catpv( aTHX_ dsv, start_color);
     
     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );    
     
     if ( end_color != NULL ) 
-        Perl_sv_catpvf( aTHX_ dsv, "%s", end_color);
+        Perl_sv_catpv( aTHX_ dsv, end_color);
 
     if ( dq == '"' ) 
 	sv_catpvn( dsv, "\"", 1 );
@@ -331,6 +370,7 @@ Perl_sv_peek(pTHX_ SV *sv)
     dVAR;
     SV * const t = sv_newmortal();
     int unref = 0;
+    U32 type;
 
     sv_setpvn(t, "", 0);
   retry:
@@ -412,62 +452,18 @@ Perl_sv_peek(pTHX_ SV *sv)
 	sv = (SV*)SvRV(sv);
 	goto retry;
     }
-    switch (SvTYPE(sv)) {
-    default:
-	sv_catpv(t, "FREED");
+    type = SvTYPE(sv);
+    if (type == SVt_PVCV) {
+	Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 	goto finish;
+    } else if (type < SVt_LAST) {
+	sv_catpv(t, svshorttypenames[type]);
 
-    case SVt_NULL:
-	sv_catpv(t, "UNDEF");
-	goto finish;
-    case SVt_IV:
-	sv_catpv(t, "IV");
-	break;
-    case SVt_NV:
-	sv_catpv(t, "NV");
-	break;
-    case SVt_RV:
-	sv_catpv(t, "RV");
-	break;
-    case SVt_PV:
-	sv_catpv(t, "PV");
-	break;
-    case SVt_PVIV:
-	sv_catpv(t, "PVIV");
-	break;
-    case SVt_PVNV:
-	sv_catpv(t, "PVNV");
-	break;
-    case SVt_PVMG:
-	sv_catpv(t, "PVMG");
-	break;
-    case SVt_PVLV:
-	sv_catpv(t, "PVLV");
-	break;
-    case SVt_PVAV:
-	sv_catpv(t, "AV");
-	break;
-    case SVt_PVHV:
-	sv_catpv(t, "HV");
-	break;
-    case SVt_PVCV:
-	if (CvGV(sv))
-	    Perl_sv_catpvf(aTHX_ t, "CV(%s)", GvNAME(CvGV(sv)));
-	else
-	    sv_catpv(t, "CV()");
+	if (type == SVt_NULL)
+	    goto finish;
+    } else {
+	sv_catpv(t, "FREED");
 	goto finish;
-    case SVt_PVGV:
-	sv_catpv(t, "GV");
-	break;
-    case SVt_PVBM:
-	sv_catpv(t, "BM");
-	break;
-    case SVt_PVFM:
-	sv_catpv(t, "FM");
-	break;
-    case SVt_PVIO:
-	sv_catpv(t, "IO");
-	break;
     }
 
     if (SvPOKp(sv)) {
@@ -557,9 +553,9 @@ S_pm_description(pTHX_ const PMOP *pm)
     if (pmflags & PMf_ONCE)
 	sv_catpv(desc, ",ONCE");
     if (regex && regex->check_substr) {
-	if (!(regex->reganch & ROPT_NOSCAN))
+	if (!(regex->extflags & RXf_NOSCAN))
 	    sv_catpv(desc, ",SCANFIRST");
-	if (regex->reganch & ROPT_CHECK_ALL)
+	if (regex->extflags & RXf_CHECK_ALL)
 	    sv_catpv(desc, ",ALL");
     }
     if (pmflags & PMf_SKIPWHITE)
@@ -743,7 +739,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #ifdef DUMPADDR
     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 #endif
-    if (o->op_flags) {
+    if (o->op_flags || o->op_latefree || o->op_latefreed) {
 	SV * const tmpsv = newSVpvs("");
 	switch (o->op_flags & OPf_WANT) {
 	case OPf_WANT_VOID:
@@ -771,6 +767,10 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 	    sv_catpv(tmpsv, ",MOD");
 	if (o->op_flags & OPf_SPECIAL)
 	    sv_catpv(tmpsv, ",SPECIAL");
+	if (o->op_latefree)
+	    sv_catpv(tmpsv, ",LATEFREE");
+	if (o->op_latefreed)
+	    sv_catpv(tmpsv, ",LATEFREED");
 	Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 	SvREFCNT_dec(tmpsv);
     }
@@ -1127,6 +1127,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
 	{ PERL_MAGIC_sv,             "sv(\\0)" },
 	{ PERL_MAGIC_arylen,         "arylen(#)" },
 	{ PERL_MAGIC_rhash,          "rhash(%)" },
+	{ PERL_MAGIC_regdata_names,  "regdata_names(+)" },
 	{ PERL_MAGIC_pos,            "pos(.)" },
 	{ PERL_MAGIC_symtab,         "symtab(:)" },
 	{ PERL_MAGIC_backref,        "backref(<)" },
@@ -1356,9 +1357,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 		   (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
 		   (int)(PL_dumpindent*level), "");
 
-    if (flags & SVs_PADSTALE)	sv_catpv(d, "PADSTALE,");
-    if (flags & SVs_PADTMP)	sv_catpv(d, "PADTMP,");
-    if (flags & SVs_PADMY)	sv_catpv(d, "PADMY,");
+    if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
+	if (flags & SVs_PADSTALE)	sv_catpv(d, "PADSTALE,");
+    }
+    if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
+	if (flags & SVs_PADTMP)	sv_catpv(d, "PADTMP,");
+	if (flags & SVs_PADMY)	sv_catpv(d, "PADMY,");
+    }
     if (flags & SVs_TEMP)	sv_catpv(d, "TEMP,");
     if (flags & SVs_OBJECT)	sv_catpv(d, "OBJECT,");
     if (flags & SVs_GMG)	sv_catpv(d, "GMG,");
@@ -1380,8 +1385,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     if (flags & SVp_IOK)	sv_catpv(d, "pIOK,");
     if (flags & SVp_NOK)	sv_catpv(d, "pNOK,");
     if (flags & SVp_POK)	sv_catpv(d, "pPOK,");
-    if (flags & SVp_SCREAM && type != SVt_PVHV)
+    if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
+	if (SvPCS_IMPORTED(sv))
+				sv_catpv(d, "PCS_IMPORTED,");
+	else
 				sv_catpv(d, "SCREAM,");
+    }
 
     switch (type) {
     case SVt_PVCV:
@@ -1415,9 +1424,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	    if (GvASSUMECV(sv))	sv_catpv(d, "ASSUMECV,");
 	    if (GvIN_PAD(sv))   sv_catpv(d, "IN_PAD,");
 	}
-	if (SvPAD_OUR(sv))	sv_catpv(d, "OUR,");
-	if (SvPAD_STATE(sv))	sv_catpv(d, "STATE,");
-	if (SvPAD_TYPED(sv))	sv_catpv(d, "TYPED,");
 	if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
 	    sv_catpv(d, "IMPORT");
 	    if (GvIMPORTED(sv) == GVf_IMPORTED)
@@ -1431,18 +1437,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 		sv_catpv(d, " ),");
 	    }
 	}
+	if (SvTAIL(sv))		sv_catpv(d, "TAIL,");
+	if (SvVALID(sv))	sv_catpv(d, "VALID,");
 	/* FALL THROUGH */
     default:
+    evaled_or_uv:
 	if (SvEVALED(sv))	sv_catpv(d, "EVALED,");
 	if (SvIsUV(sv) && !(flags & SVf_ROK))	sv_catpv(d, "IsUV,");
 	break;
-    case SVt_PVBM:
-	if (SvTAIL(sv))		sv_catpv(d, "TAIL,");
-	if (SvVALID(sv))	sv_catpv(d, "VALID,");
-	break;
     case SVt_PVMG:
 	if (SvPAD_TYPED(sv))	sv_catpv(d, "TYPED,");
+	if (SvPAD_OUR(sv))	sv_catpv(d, "OUR,");
+	if (SvPAD_STATE(sv))	sv_catpv(d, "STATE,");
 	break;
+    case SVt_PVNV:
+	if (SvPAD_STATE(sv))	sv_catpv(d, "STATE,");
+	goto evaled_or_uv;
     case SVt_PVAV:
 	break;
     }
@@ -1466,57 +1476,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	sv->sv_debug_cloned ? " (cloned)" : "");
 #endif
     Perl_dump_indent(aTHX_ level, file, "SV = ");
-    switch (type) {
-    case SVt_NULL:
-	PerlIO_printf(file, "NULL%s\n", s);
-	SvREFCNT_dec(d);
-	return;
-    case SVt_IV:
-	PerlIO_printf(file, "IV%s\n", s);
-	break;
-    case SVt_NV:
-	PerlIO_printf(file, "NV%s\n", s);
-	break;
-    case SVt_RV:
-	PerlIO_printf(file, "RV%s\n", s);
-	break;
-    case SVt_PV:
-	PerlIO_printf(file, "PV%s\n", s);
-	break;
-    case SVt_PVIV:
-	PerlIO_printf(file, "PVIV%s\n", s);
-	break;
-    case SVt_PVNV:
-	PerlIO_printf(file, "PVNV%s\n", s);
-	break;
-    case SVt_PVBM:
-	PerlIO_printf(file, "PVBM%s\n", s);
-	break;
-    case SVt_PVMG:
-	PerlIO_printf(file, "PVMG%s\n", s);
-	break;
-    case SVt_PVLV:
-	PerlIO_printf(file, "PVLV%s\n", s);
-	break;
-    case SVt_PVAV:
-	PerlIO_printf(file, "PVAV%s\n", s);
-	break;
-    case SVt_PVHV:
-	PerlIO_printf(file, "PVHV%s\n", s);
-	break;
-    case SVt_PVCV:
-	PerlIO_printf(file, "PVCV%s\n", s);
-	break;
-    case SVt_PVGV:
-	PerlIO_printf(file, "PVGV%s\n", s);
-	break;
-    case SVt_PVFM:
-	PerlIO_printf(file, "PVFM%s\n", s);
-	break;
-    case SVt_PVIO:
-	PerlIO_printf(file, "PVIO%s\n", s);
-	break;
-    default:
+    if (type < SVt_LAST) {
+	PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
+
+	if (type ==  SVt_NULL) {
+	    SvREFCNT_dec(d);
+	    return;
+	}
+    } else {
 	PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
 	SvREFCNT_dec(d);
 	return;
@@ -2380,8 +2347,8 @@ Perl_sv_xmlpeek(pTHX_ SV *sv)
     case SVt_PVGV:
 	sv_catpv(t, " GV=\"");
 	break;
-    case SVt_PVBM:
-	sv_catpv(t, " BM=\"");
+    case SVt_BIND:
+	sv_catpv(t, " BIND=\"");
 	break;
     case SVt_PVFM:
 	sv_catpv(t, " FM=\"");
@@ -2430,7 +2397,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     level++;
     if (PM_GETRE(pm)) {
 	char *s = PM_GETRE(pm)->precomp;
-	SV *tmpsv = newSV(0);
+	SV *tmpsv = newSVpvn("",0);
 	SvUTF8_on(tmpsv);
 	sv_catxmlpvn(tmpsv, s, strlen(s), 1);
 	Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
@@ -2722,7 +2689,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #else
 	if (cSVOPo->op_sv) {
 	    SV *tmpsv1 = newSV(0);
-	    SV *tmpsv2 = newSV(0);
+	    SV *tmpsv2 = newSVpvn("",0);
 	    char *s;
 	    STRLEN len;
 	    SvUTF8_on(tmpsv1);