X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=70efde4090547a2269631b7fd5208f09c1edd6fd;hb=bb377ba23d1bb580b4141dcdf05ac5939a8bda12;hp=7f55558106f659ab0bfb210c9597c7c4b13f85e1;hpb=76f68e9bb86f29e34e2aeb5c177571288f05b7ca;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/dump.c b/dump.c
index 7f55558..70efde4 100644
--- a/dump.c
+++ b/dump.c
@@ -9,8 +9,10 @@
  */
 
 /*
- * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
- * it has not been hard for me to read your mind and memory.'"
+ *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
+ *   it has not been hard for me to read your mind and memory.'
+ *
+ *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
  */
 
 /* This file contains utility routines to dump the contents of SV and OP
@@ -90,37 +92,51 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 void
 Perl_dump_all(pTHX)
 {
+    dump_all_perl(FALSE);
+}
+
+void
+Perl_dump_all_perl(pTHX_ bool justperl)
+{
+
     dVAR;
     PerlIO_setlinebuf(Perl_debug_log);
     if (PL_main_root)
 	op_dump(PL_main_root);
-    dump_packsubs(PL_defstash);
+    dump_packsubs_perl(PL_defstash, justperl);
 }
 
 void
 Perl_dump_packsubs(pTHX_ const HV *stash)
 {
+    PERL_ARGS_ASSERT_DUMP_PACKSUBS;
+    dump_packsubs_perl(stash, FALSE);
+}
+
+void
+Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
+{
     dVAR;
     I32	i;
 
-    PERL_ARGS_ASSERT_DUMP_PACKSUBS;
+    PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 
     if (!HvARRAY(stash))
 	return;
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
         const HE *entry;
 	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
-	    const GV * const gv = (GV*)HeVAL(entry);
+	    const GV * const gv = (const GV *)HeVAL(entry);
 	    if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 		continue;
 	    if (GvCVu(gv))
-		dump_sub(gv);
+		dump_sub_perl(gv, justperl);
 	    if (GvFORM(gv))
 		dump_form(gv);
 	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 		const HV * const hv = GvHV(gv);
 		if (hv && (hv != PL_defstash))
-		    dump_packsubs(hv);		/* nested package */
+		    dump_packsubs_perl(hv, justperl); /* nested package */
 	    }
 	}
     }
@@ -129,10 +145,21 @@ Perl_dump_packsubs(pTHX_ const HV *stash)
 void
 Perl_dump_sub(pTHX_ const GV *gv)
 {
-    SV * const sv = sv_newmortal();
-
     PERL_ARGS_ASSERT_DUMP_SUB;
+    dump_sub_perl(gv, FALSE);
+}
+
+void
+Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+    SV * sv;
+
+    PERL_ARGS_ASSERT_DUMP_SUB_PERL;
+
+    if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+	return;
 
+    sv = sv_newmortal();
     gv_fullname3(sv, gv, NULL);
     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
     if (CvISXSUB(GvCV(gv)))
@@ -409,7 +436,7 @@ Perl_sv_peek(pTHX_ SV *sv)
 	sv_catpv(t, "VOID");
 	goto finish;
     }
-    else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+    else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
 	sv_catpv(t, "WILD");
 	goto finish;
     }
@@ -480,7 +507,7 @@ Perl_sv_peek(pTHX_ SV *sv)
 	    sv_catpv(t, "...");
 	    goto finish;
 	}
-	sv = (SV*)SvRV(sv);
+	sv = SvRV(sv);
 	goto retry;
     }
     type = SvTYPE(sv);
@@ -503,8 +530,11 @@ Perl_sv_peek(pTHX_ SV *sv)
 	else {
 	    SV * const tmp = newSVpvs("");
 	    sv_catpv(t, "(");
-	    if (SvOOK(sv))
-		Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
+	    if (SvOOK(sv)) {
+		STRLEN delta;
+		SvOOK_offset(sv, delta);
+		Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
+	    }
 	    Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 	    if (SvUTF8(sv))
 		Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
@@ -530,6 +560,8 @@ Perl_sv_peek(pTHX_ SV *sv)
   finish:
     while (unref--)
 	sv_catpv(t, ")");
+    if (PL_tainting && SvTAINTED(sv))
+	sv_catpv(t, " [tainted]");
     return SvPV_nolen(t);
 }
 
@@ -1036,7 +1068,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 #ifdef USE_ITHREADS
 	Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 #else
-	if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
+	if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
 	    if (cSVOPo->op_sv) {
 		SV * const tmpsv = newSV(0);
 		ENTER;
@@ -1046,7 +1078,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 		   UTF-8 cleanliness of the dump file handle?  */
 		SvUTF8_on(tmpsv);
 #endif
-		gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
+		gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
 		Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
 				 SvPV_nolen_const(tmpsv));
 		LEAVE;
@@ -1254,6 +1286,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
 	    else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
+            else if (v == &PL_vtbl_hints)      s = "hints";
 	    else			       s = NULL;
 	    if (s)
 	        Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
@@ -1328,7 +1361,8 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
             }
 	    else if (mg->mg_len == HEf_SVKEY) {
 		PerlIO_puts(file, " => HEf_SVKEY\n");
-		do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
+		do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
+			   maxnest, dumpops, pvlim); /* MG is already +1 */
 		continue;
 	    }
 	    else
@@ -1472,7 +1506,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (SvCOMPILED(sv))	sv_catpv(d, "COMPILED,");
 	if (CvLVALUE(sv))	sv_catpv(d, "LVALUE,");
 	if (CvMETHOD(sv))	sv_catpv(d, "METHOD,");
-	if (CvLOCKED(sv))	sv_catpv(d, "LOCKED,");
 	if (CvWEAKOUTSIDE(sv))	sv_catpv(d, "WEAKOUTSIDE,");
 	break;
     case SVt_PVHV:
@@ -1487,7 +1520,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (isGV_with_GP(sv)) {
 	    if (GvINTRO(sv))	sv_catpv(d, "INTRO,");
 	    if (GvMULTI(sv))	sv_catpv(d, "MULTI,");
-	    if (GvUNIQUE(sv))   sv_catpv(d, "UNIQUE,");
 	    if (GvASSUMECV(sv))	sv_catpv(d, "ASSUMECV,");
 	    if (GvIN_PAD(sv))   sv_catpv(d, "IN_PAD,");
 	}
@@ -1745,13 +1777,49 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 		Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
 	}
 	if (SvOOK(sv)) {
-	    const AV * const backrefs
+	    AV * const backrefs
 		= *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
+	    struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
 	    if (backrefs) {
 		Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
 				 PTR2UV(backrefs));
-		do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
+		do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
+			   dumpops, pvlim);
+	    }
+	    if (meta) {
+		/* FIXME - mro_algs kflags can signal a UTF-8 name.  */
+		Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
+				 (int)meta->mro_which->length,
+				 meta->mro_which->name,
+				 PTR2UV(meta->mro_which));
+		Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
+				 (UV)meta->cache_gen);
+		Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
+				 (UV)meta->pkg_gen);
+		if (meta->mro_linear_all) {
+		    Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
+				 PTR2UV(meta->mro_linear_all));
+		do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
 			   dumpops, pvlim);
+		}
+		if (meta->mro_linear_current) {
+		    Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
+				 PTR2UV(meta->mro_linear_current));
+		do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
+			   dumpops, pvlim);
+		}
+		if (meta->mro_nextmethod) {
+		    Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
+				 PTR2UV(meta->mro_nextmethod));
+		do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
+			   dumpops, pvlim);
+		}
+		if (meta->isa) {
+		    Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
+				 PTR2UV(meta->isa));
+		do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
+			   dumpops, pvlim);
+		}
 	    }
 	}
 	if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
@@ -1840,7 +1908,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 			 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
 	}
 	if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
-	    do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
+	    do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
 	break;
     case SVt_PVGV:
     case SVt_PVLV:
@@ -1895,8 +1963,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	else {
 	    Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
 			     PTR2UV(IoTOP_GV(sv)));
-	    do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
-			dumpops, pvlim);
+	    do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
+			maxnest, dumpops, pvlim);
 	}
 	/* Source filters hide things that are not GVs in these three, so let's
 	   be careful out there.  */
@@ -1907,8 +1975,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	else {
 	    Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
 			     PTR2UV(IoFMT_GV(sv)));
-	    do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
-			dumpops, pvlim);
+	    do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
+			maxnest, dumpops, pvlim);
 	}
         if (IoBOTTOM_NAME(sv))
             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
@@ -1917,8 +1985,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	else {
 	    Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
 			     PTR2UV(IoBOTTOM_GV(sv)));
-	    do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
-			dumpops, pvlim);
+	    do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
+			maxnest, dumpops, pvlim);
 	}
 	if (isPRINT(IoTYPE(sv)))
             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
@@ -1948,8 +2016,7 @@ Perl_runops_debug(pTHX)
 {
     dVAR;
     if (!PL_op) {
-	if (ckWARN_d(WARN_DEBUGGING))
-	    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
 	return 0;
     }
 
@@ -2147,9 +2214,16 @@ Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *ar
 void
 Perl_xmldump_all(pTHX)
 {
+    xmldump_all_perl(FALSE);
+}
+
+void
+Perl_xmldump_all_perl(pTHX_ bool justperl)
+{
     PerlIO_setlinebuf(PL_xmlfp);
     if (PL_main_root)
 	op_xmldump(PL_main_root);
+    xmldump_packsubs_perl(PL_defstash, justperl);
     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
 	PerlIO_close(PL_xmlfp);
     PL_xmlfp = 0;
@@ -2158,26 +2232,33 @@ Perl_xmldump_all(pTHX)
 void
 Perl_xmldump_packsubs(pTHX_ const HV *stash)
 {
+    PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
+    xmldump_packsubs_perl(stash, FALSE);
+}
+
+void
+Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
+{
     I32	i;
     HE	*entry;
 
-    PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
+    PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
 
     if (!HvARRAY(stash))
 	return;
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
-	    GV *gv = (GV*)HeVAL(entry);
+	    GV *gv = MUTABLE_GV(HeVAL(entry));
 	    HV *hv;
 	    if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 		continue;
 	    if (GvCVu(gv))
-		xmldump_sub(gv);
+		xmldump_sub_perl(gv, justperl);
 	    if (GvFORM(gv))
 		xmldump_form(gv);
 	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
 		&& (hv = GvHV(gv)) && hv != PL_defstash)
-		xmldump_packsubs(hv);		/* nested package */
+		xmldump_packsubs_perl(hv, justperl);	/* nested package */
 	}
     }
 }
@@ -2185,10 +2266,21 @@ Perl_xmldump_packsubs(pTHX_ const HV *stash)
 void
 Perl_xmldump_sub(pTHX_ const GV *gv)
 {
-    SV * const sv = sv_newmortal();
-
     PERL_ARGS_ASSERT_XMLDUMP_SUB;
+    xmldump_sub_perl(gv, FALSE);
+}
 
+void
+Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+    SV * sv;
+
+    PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
+
+    if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+	return;
+
+    sv = sv_newmortal();
     gv_fullname3(sv, gv, NULL);
     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
     if (CvXSUB(GvCV(gv)))
@@ -2372,7 +2464,7 @@ Perl_sv_xmlpeek(pTHX_ SV *sv)
 	sv_catpv(t, "VOID=\"\"");
 	goto finish;
     }
-    else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+    else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
 	sv_catpv(t, "WILD=\"\"");
 	goto finish;
     }
@@ -2536,7 +2628,7 @@ Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
     if (PM_GETRE(pm)) {
 	REGEXP *const r = PM_GETRE(pm);
 	SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
-	sv_catxmlsv(tmpsv, (SV*)r);
+	sv_catxmlsv(tmpsv, MUTABLE_SV(r));
 	Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
 	     SvPVX(tmpsv));
 	SvREFCNT_dec(tmpsv);
@@ -2831,7 +2923,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
 	    ENTER;
 	    SAVEFREESV(tmpsv1);
 	    SAVEFREESV(tmpsv2);
-	    gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
+	    gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
 	    s = SvPV(tmpsv1,len);
 	    sv_catxmlpvn(tmpsv2, s, len, 1);
 	    S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
@@ -2945,7 +3037,7 @@ Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
 		break;
 	    case MAD_SV:
 		sv_catpv(tmpsv, " val=\"");
-		sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
+		sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
 		sv_catpv(tmpsv, "\"");
 		Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
 		break;